]> 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
Write trigger digits if SAVEDIGITS activated (Bogdan)
[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
2730 COMMON/W50512/QCDL4,QCDL5
2731 SAVE /W50511/,/W50512/
2732 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2733 CHARACTER*20 PARM(20)
2734 DATA VALUE/20*0D0/,PARM/20*' '/
2735
2736C...Data:Lambda and n_f values for parton distributions..
2737 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2738 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2739 &NFIN/20*4/
2740 DATA CHLH/'lepton','hadron'/
2741
2742C...Check that BLOCK DATA PYDATA has been loaded.
2743 CALL PYCKBD
2744
2745C...Reset MINT and VINT arrays. Write headers.
2746 MSTI(53)=0
2747 DO 100 J=1,400
2748 MINT(J)=0
2749 VINT(J)=0D0
2750 100 CONTINUE
2751 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2752 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2753
2754C...Reset error counters.
2755 MSTU(23)=0
2756 MSTU(27)=0
2757 MSTU(30)=0
2758
2759C...Reset processes that should not be on.
2760 MSUB(96)=0
2761 MSUB(97)=0
2762
2763C...Select global FSR/ISR/UE parameter set = 'tune'
2764C...See routine PYTUNE for details
2765 IF (MSTP(5).NE.0) THEN
2766 MSTP5=MSTP(5)
2767 CALL PYTUNE(MSTP5)
2768 ENDIF
2769
2770C...Call user process initialization routine.
2771 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2772 MSEL=0
2773 CALL UPINIT
2774 MSEL=0
2775 ENDIF
2776
2777C...Maximum 4 generations; set maximum number of allowed flavours.
2778 MSTP(1)=MIN(4,MSTP(1))
2779 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2780 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2781
2782C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2783 DO 120 I=-20,20
2784 VINT(180+I)=0D0
2785 IA=IABS(I)
2786 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2787 DO 110 J=1,MSTP(1)
2788 IB=2*J-1+MOD(IA,2)
2789 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2790 IPM=(5-ISIGN(1,I))/2
2791 IDC=J+MDCY(IA,2)+2
2792 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2793 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2794 110 CONTINUE
2795 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2796 VINT(180+I)=1D0
2797 ENDIF
2798 120 CONTINUE
2799
2800C...Initialize parton distributions: PDFLIB.
2801 IF(MSTP(52).EQ.2) THEN
2802 PARM(1)='NPTYPE'
2803 VALUE(1)=1
2804 PARM(2)='NGROUP'
2805 VALUE(2)=MSTP(51)/1000
2806 PARM(3)='NSET'
2807 VALUE(3)=MOD(MSTP(51),1000)
2808 PARM(4)='TMAS'
2809 VALUE(4)=PMAS(6,1)
2810 CALL PDFSET_ALICE(PARM,VALUE)
2811 MINT(93)=1000000+MSTP(51)
2812 ENDIF
2813
2814C...Choose Lambda value to use in alpha-strong.
2815 MSTU(111)=MSTP(2)
2816 IF(MSTP(3).GE.2) THEN
2817 ALAM=0.2D0
2818 NF=4
2819 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2820 ALAM=ALAMIN(MSTP(51))
2821 NF=NFIN(MSTP(51))
2822 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2823 ALAM=QCDL5
2824 NF=5
2825 ELSEIF(MSTP(52).EQ.2) THEN
2826 ALAM=QCDL4
2827 NF=4
2828 ENDIF
2829 PARP(1)=ALAM
2830 PARP(61)=ALAM
2831 PARP(72)=ALAM
2832 PARU(112)=ALAM
2833 MSTU(112)=NF
2834 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2835 ENDIF
2836
2837C...Initialize the SUSY generation: couplings, masses,
2838C...decay modes, branching ratios, and so on.
2839 CALL PYMSIN
2840C...Initialize widths and partial widths for resonances.
2841 CALL PYINRE
2842C...Set Z0 mass and width for e+e- routines.
2843 PARJ(123)=PMAS(23,1)
2844 PARJ(124)=PMAS(23,2)
2845
2846C...Identify beam and target particles and frame of process.
2847 CHFRAM=FRAME//' '
2848 CHBEAM=BEAM//' '
2849 CHTARG=TARGET//' '
2850 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2851 IF(MINT(65).EQ.1) GOTO 170
2852
2853C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
2854C...For e-gamma allow 2 alternatives.
2855 MINT(121)=1
2856 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2857 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2858 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2859 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
2860 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2861 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
2862 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2863 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2864 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
2865 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
2866 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2867 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2868 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
2869 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
2870 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
2871 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
2872 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
2873 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
2874 ENDIF
2875 MINT(123)=MSTP(14)
2876 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
2877 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
2878 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
2879 IF(MSTP(14).EQ.11) MINT(123)=0
2880 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
2881 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
2882 IF(MSTP(14).EQ.15) MINT(123)=2
2883 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
2884 IF(MSTP(14).EQ.19) MINT(123)=3
2885 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
2886 IF(MSTP(14).EQ.21) MINT(123)=0
2887 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
2888 IF(MSTP(14).EQ.24) MINT(123)=1
2889 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
2890 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
2891 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
2892 ENDIF
2893
2894C...Set up kinematics of process.
2895 CALL PYINKI(0)
2896
2897C...Set up kinematics for photons inside leptons.
2898 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
2899
2900C...Precalculate flavour selection weights.
2901 CALL PYKFIN
2902
2903C...Loop over gamma-p or gamma-gamma alternatives.
2904 CKIN3=CKIN(3)
2905 MSAV48=0
2906 DO 160 IGA=1,MINT(121)
2907 CKIN(3)=CKIN3
2908 MINT(122)=IGA
2909
2910C...Select partonic subprocesses to be included in the simulation.
2911 CALL PYINPR
2912 MINT(101)=1
2913 MINT(102)=1
2914 MINT(103)=MINT(11)
2915 MINT(104)=MINT(12)
2916
2917C...Count number of subprocesses on.
2918 MINT(48)=0
2919 DO 130 ISUB=1,500
2920 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2921 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
2922 MSUB(ISUB)=0
2923 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
2924 & MSUB(ISUB).EQ.1) THEN
2925 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
2926 CALL PYSTOP(1)
2927 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
2928 WRITE(MSTU(11),5300) ISUB
2929 CALL PYSTOP(1)
2930 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
2931 WRITE(MSTU(11),5400) ISUB
2932 CALL PYSTOP(1)
2933 ELSEIF(MSUB(ISUB).EQ.1) THEN
2934 MINT(48)=MINT(48)+1
2935 ENDIF
2936 130 CONTINUE
2937
2938C...Stop or raise warning flag if no subprocesses on.
2939 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
2940 IF(MSTP(127).NE.1) THEN
2941 WRITE(MSTU(11),5500)
2942 CALL PYSTOP(1)
2943 ELSE
2944 WRITE(MSTU(11),5700)
2945 MSTI(53)=1
2946 ENDIF
2947 ENDIF
2948 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
2949 MSAV48=MSAV48+MINT(48)
2950
2951C...Reset variables for cross-section calculation.
2952 DO 150 I=0,500
2953 DO 140 J=1,3
2954 NGEN(I,J)=0
2955 XSEC(I,J)=0D0
2956 140 CONTINUE
2957 150 CONTINUE
2958
2959C...Find parametrized total cross-sections.
2960 CALL PYXTOT
2961 VINT(318)=VINT(317)
2962
2963C...Maxima of differential cross-sections.
2964 IF(MSTP(121).LE.1) CALL PYMAXI
2965
2966C...Initialize possibility of pileup events.
2967 IF(MINT(121).GT.1) MSTP(131)=0
2968 IF(MSTP(131).NE.0) CALL PYPILE(1)
2969
2970C...Initialize multiple interactions with variable impact parameter.
2971 IF(MINT(50).EQ.1) THEN
2972 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
2973 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
2974 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
2975 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
2976 MINT(35)=1
2977 CALL PYMULT(1)
2978 MINT(35)=3
2979 CALL PYMIGN(1)
2980 ENDIF
2981 ENDIF
2982
2983C...Save results for gamma-p and gamma-gamma alternatives.
2984 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
2985 160 CONTINUE
2986
2987C...Initialization finished.
2988 IF(MSAV48.EQ.0) THEN
2989 IF(MSTP(127).NE.1) THEN
2990 WRITE(MSTU(11),5500)
2991 CALL PYSTOP(1)
2992 ELSE
2993 WRITE(MSTU(11),5700)
2994 MSTI(53)=1
2995 ENDIF
2996 ENDIF
2997 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
2998
2999C...Formats for initialization information.
3000 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3001 &'routines',1X,17('*'))
3002 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3003 &'-',A6,' interactions.'/1X,'Execution stopped!')
3004 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3005 &1X,'Execution stopped!')
3006 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3007 &1X,'Execution stopped!')
3008 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3009 &1X,'Execution stopped.')
3010 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3011 &22('*'))
3012 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3013 &1X,'Execution will stop if you try to generate events.')
3014
3015 RETURN
3016 END
3017
3018C*********************************************************************
3019
3020C...PYEVNT
3021C...Administers the generation of a high-pT event via calls to
3022C...a number of subroutines.
3023
3024 SUBROUTINE PYEVNT
3025
3026C...Double precision and integer declarations.
3027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3028 IMPLICIT INTEGER(I-N)
3029 INTEGER PYK,PYCHGE,PYCOMP
3030C...Commonblocks.
3031 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3032 COMMON/PYCTAG/NCT,MCT(4000,2)
3033 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3034 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3035 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3036 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3037 COMMON/PYINT1/MINT(400),VINT(400)
3038 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3039 COMMON/PYINT4/MWID(500),WIDS(500,5)
3040 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3041 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3042 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3043C...Local array.
3044 DIMENSION VTX(4)
3045
3046C...Optionally let PYEVNW do the whole job.
3047 IF(MSTP(81).GE.20) THEN
3048 CALL PYEVNW
3049 RETURN
3050 ENDIF
3051
3052C...Stop if no subprocesses on.
3053 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3054 WRITE(MSTU(11),5100)
3055 CALL PYSTOP(1)
3056 ENDIF
3057
3058C...Initial values for some counters.
3059 MSTU(1)=0
3060 MSTU(2)=0
3061 N=0
3062 MINT(5)=MINT(5)+1
3063 MINT(7)=0
3064 MINT(8)=0
3065 MINT(30)=0
3066 MINT(83)=0
3067 MINT(84)=MSTP(126)
3068 MSTU(24)=0
3069 MSTU70=0
3070 MSTJ14=MSTJ(14)
3071C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3072 NCT=0
3073 MINT(33)=0
3074
3075C...Let called routines know call is from PYEVNT (not PYEVNW).
3076 MINT(35)=1
3077 IF (MSTP(81).GE.10) MINT(35)=2
3078
3079C...If variable energies: redo incoming kinematics and cross-section.
3080 MSTI(61)=0
3081 IF(MSTP(171).EQ.1) THEN
3082 CALL PYINKI(1)
3083 IF(MSTI(61).EQ.1) THEN
3084 MINT(5)=MINT(5)-1
3085 RETURN
3086 ENDIF
3087 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3088 CALL PYXTOT
3089 ENDIF
3090
3091C...Loop over number of pileup events; check space left.
3092 IF(MSTP(131).LE.0) THEN
3093 NPILE=1
3094 ELSE
3095 CALL PYPILE(2)
3096 NPILE=MINT(81)
3097 ENDIF
3098 DO 270 IPILE=1,NPILE
3099 IF(MINT(84)+100.GE.MSTU(4)) THEN
3100 CALL PYERRM(11,
3101 & '(PYEVNT:) no more space in PYJETS for pileup events')
3102 IF(MSTU(21).GE.1) GOTO 280
3103 ENDIF
3104 MINT(82)=IPILE
3105
3106C...Generate variables of hard scattering.
3107 MINT(51)=0
3108 MSTI(52)=0
3109 100 CONTINUE
3110 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3111 MINT(31)=0
3112 MINT(39)=0
3113 MINT(51)=0
3114 MINT(57)=0
3115 CALL PYRAND
3116 IF(MSTI(61).EQ.1) THEN
3117 MINT(5)=MINT(5)-1
3118 RETURN
3119 ENDIF
3120 IF(MINT(51).EQ.2) RETURN
3121 ISUB=MINT(1)
3122 IF(MSTP(111).EQ.-1) GOTO 260
3123
3124C...Loopback point if PYPREP fails, especially for junction topologies.
3125 NPREP=0
3126 MNT31S=MINT(31)
3127 110 NPREP=NPREP+1
3128 MINT(31)=MNT31S
3129
3130 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3131C...Hard scattering (including low-pT):
3132C...reconstruct kinematics and colour flow of hard scattering.
3133 MINT31=MINT(31)
3134 120 MINT(31)=MINT31
3135 MINT(51)=0
3136 CALL PYSCAT
3137 IF(MINT(51).EQ.1) GOTO 100
3138 IPU1=MINT(84)+1
3139 IPU2=MINT(84)+2
3140 IF(ISUB.EQ.95) GOTO 140
3141
3142C...Reset statistics on activity in event.
3143 DO 130 J=351,359
3144 MINT(J)=0
3145 VINT(J)=0D0
3146 130 CONTINUE
3147
3148C...Showering of initial state partons (optional).
3149 NFIN=N
3150 ALAMSV=PARJ(81)
3151 PARJ(81)=PARP(72)
3152 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3153 & CALL PYSSPA(IPU1,IPU2)
3154 PARJ(81)=ALAMSV
3155 IF(MINT(51).EQ.1) GOTO 100
3156
3157C...Showering of final state partons (optional).
3158 ALAMSV=PARJ(81)
3159 PARJ(81)=PARP(72)
3160 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3161 & THEN
3162 IPU3=MINT(84)+3
3163 IPU4=MINT(84)+4
3164 IF(ISET(ISUB).EQ.5) IPU4=-3
3165 QMAX=VINT(55)
3166 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3167 CALL PYSHOW(IPU3,IPU4,QMAX)
3168 ELSEIF(ISET(ISUB).EQ.11) THEN
3169 CALL PYADSH(NFIN)
3170 ENDIF
3171 PARJ(81)=ALAMSV
3172
3173C...Allow possibility for user to abort event generation.
3174 IVETO=0
3175 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3176 IF(IVETO.EQ.1) GOTO 100
3177
3178C...Decay of final state resonances.
3179 MINT(32)=0
3180 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3181 IF(MINT(51).EQ.1) GOTO 100
3182 MINT(52)=N
3183
3184
3185C...Multiple interactions - PYTHIA 6.3 intermediate style.
3186 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3187 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3188 CALL PYMIGN(6)
3189 IF(MINT(51).EQ.1) GOTO 100
3190 MINT(53)=N
3191
3192C...Beam remnant flavour and colour assignments - new scheme.
3193 CALL PYMIHK
3194 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3195 & GOTO 120
3196 IF(MINT(51).EQ.1) GOTO 100
3197
3198C...Primordial kT and beam remnant momentum sharing - new scheme.
3199 CALL PYMIRM
3200 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3201 & GOTO 120
3202 IF(MINT(51).EQ.1) GOTO 100
3203 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3204
3205C...Multiple interactions - PYTHIA 6.2 style.
3206 ELSEIF(MINT(111).NE.12) THEN
3207 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3208 CALL PYMULT(6)
3209 MINT(53)=N
3210 ENDIF
3211
3212C...Hadron remnants and primordial kT.
3213 CALL PYREMN(IPU1,IPU2)
3214 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3215 & 110
3216 IF(MINT(51).EQ.1) GOTO 100
3217 ENDIF
3218
3219 ELSEIF(ISUB.NE.99) THEN
3220C...Diffractive and elastic scattering.
3221 CALL PYDIFF
3222
3223 ELSE
3224C...DIS scattering (photon flux external).
3225 CALL PYDISG
3226 IF(MINT(51).EQ.1) GOTO 100
3227 ENDIF
3228
3229C...Check that no odd resonance left undecayed.
3230 MINT(54)=N
3231 IF(MSTP(111).GE.1) THEN
3232 NFIX=N
3233 DO 150 I=MINT(84)+1,NFIX
3234 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3235 & K(I,2).NE.22) THEN
3236 KCA=PYCOMP(K(I,2))
3237 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3238 CALL PYRESD(I)
3239 IF(MINT(51).EQ.1) GOTO 100
3240 ENDIF
3241 ENDIF
3242 150 CONTINUE
3243 ENDIF
3244
3245C...Boost hadronic subsystem to overall rest frame.
3246C..(Only relevant when photon inside lepton beam.)
3247 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3248
3249C...Recalculate energies from momenta and masses (if desired).
3250 IF(MSTP(113).GE.1) THEN
3251 DO 160 I=MINT(83)+1,N
3252 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3253 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3254 160 CONTINUE
3255 NRECAL=N
3256 ENDIF
3257
3258C...Colour reconnection before string formation
3259 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3260
3261C...Rearrange partons along strings, check invariant mass cuts.
3262 MSTU(28)=0
3263 IF(MSTP(111).LE.0) MSTJ(14)=-1
3264 CALL PYPREP(MINT(84)+1)
3265 MSTJ(14)=MSTJ14
3266 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3267 MSTU(24)=0
3268 GOTO 100
3269 ENDIF
3270 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3271 IF (MINT(51).EQ.1) GOTO 100
3272 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3273 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3274 DO 190 I=MINT(84)+1,N
3275 IF(K(I,2).EQ.94) THEN
3276 DO 180 I1=I+1,MIN(N,I+10)
3277 IF(K(I1,3).EQ.I) THEN
3278 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3279 IF(K(I1,3).EQ.0) THEN
3280 DO 170 II=MINT(84)+1,I-1
3281 IF(K(II,2).EQ.K(I1,2)) THEN
3282 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3283 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3284 ENDIF
3285 170 CONTINUE
3286 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3287 ENDIF
3288 ENDIF
3289 180 CONTINUE
3290 ENDIF
3291 190 CONTINUE
3292 CALL PYEDIT(12)
3293 CALL PYEDIT(14)
3294 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3295 IF(MSTP(125).EQ.0) MINT(4)=0
3296 DO 210 I=MINT(83)+1,N
3297 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3298 DO 200 I1=I+1,N
3299 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3300 IF(K(I1,3).EQ.I) K(I,5)=I1
3301 200 CONTINUE
3302 ENDIF
3303 210 CONTINUE
3304 ENDIF
3305
3306C...Introduce separators between sections in PYLIST event listing.
3307 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3308 MSTU70=1
3309 MSTU(71)=N
3310 ELSEIF(IPILE.EQ.1) THEN
3311 MSTU70=3
3312 MSTU(71)=2
3313 MSTU(72)=MINT(4)
3314 MSTU(73)=N
3315 ENDIF
3316
3317C...Go back to lab frame (needed for vertices, also in fragmentation).
3318 CALL PYFRAM(1)
3319
3320C...Set nonvanishing production vertex (optional).
3321 IF(MSTP(151).EQ.1) THEN
3322 DO 220 J=1,4
3323 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3324 & SIN(PARU(2)*PYR(0))
3325 220 CONTINUE
3326 DO 240 I=MINT(83)+1,N
3327 DO 230 J=1,4
3328 V(I,J)=V(I,J)+VTX(J)
3329 230 CONTINUE
3330 240 CONTINUE
3331 ENDIF
3332
3333C...Perform hadronization (if desired).
3334 IF(MSTP(111).GE.1) THEN
3335 CALL PYEXEC
3336 IF(MSTU(24).NE.0) GOTO 100
3337 ENDIF
3338 IF(MSTP(113).GE.1) THEN
3339 DO 250 I=NRECAL,N
3340 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3341 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3342 250 CONTINUE
3343 ENDIF
3344 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3345
3346C...Store event information and calculate Monte Carlo estimates of
3347C...subprocess cross-sections.
3348 260 IF(IPILE.EQ.1) CALL PYDOCU
3349
3350C...Set counters for current pileup event and loop to next one.
3351 MSTI(41)=IPILE
3352 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3353 IF(MSTU70.LT.10) THEN
3354 MSTU70=MSTU70+1
3355 MSTU(70+MSTU70)=N
3356 ENDIF
3357 MINT(83)=N
3358 MINT(84)=N+MSTP(126)
3359 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3360 270 CONTINUE
3361
3362C...Generic information on pileup events. Reconstruct missing history.
3363 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3364 PARI(91)=VINT(132)
3365 PARI(92)=VINT(133)
3366 PARI(93)=VINT(134)
3367 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3368 ENDIF
3369 CALL PYEDIT(16)
3370
3371C...Transform to the desired coordinate frame.
3372 280 CALL PYFRAM(MSTP(124))
3373 MSTU(70)=MSTU70
3374 PARU(21)=VINT(1)
3375
3376C...Error messages
3377 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3378 &1X,'Execution stopped.')
3379
3380 RETURN
3381 END
3382
3383C*********************************************************************
3384
3385C...PYEVNW
3386C...Administers the generation of a high-pT event via calls to
3387C...a number of subroutines for the new multiple interactions and
3388C...showering framework.
3389
3390 SUBROUTINE PYEVNW
3391
3392C...Double precision and integer declarations.
3393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3394 IMPLICIT INTEGER(I-N)
3395 INTEGER PYK,PYCHGE,PYCOMP
3396C...Commonblocks.
3397 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3398 COMMON/PYCTAG/NCT,MCT(4000,2)
3399 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3400 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3401 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3402 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3403 COMMON/PYINT1/MINT(400),VINT(400)
3404 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3405 COMMON/PYINT4/MWID(500),WIDS(500,5)
3406 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3407 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3408 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3409 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3410 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3411 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3412C...Local arrays.
3413 DIMENSION VTX(4)
3414
3415C...Stop if no subprocesses on.
3416 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3417 WRITE(MSTU(11),5100)
3418 CALL PYSTOP(1)
3419 ENDIF
3420
3421C...Initial values for some counters.
3422 MSTU(1)=0
3423 MSTU(2)=0
3424 N=0
3425 MINT(5)=MINT(5)+1
3426 MINT(7)=0
3427 MINT(8)=0
3428 MINT(30)=0
3429 MINT(83)=0
3430 MINT(84)=MSTP(126)
3431 MSTU(24)=0
3432 MSTU70=0
3433 MSTJ14=MSTJ(14)
3434C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3435 NCT=0
3436 MINT(33)=0
3437
3438C...Let called routines know call is from PYEVNW (not PYEVNT).
3439 MINT(35)=3
3440
3441C...If variable energies: redo incoming kinematics and cross-section.
3442 MSTI(61)=0
3443 IF(MSTP(171).EQ.1) THEN
3444 CALL PYINKI(1)
3445 IF(MSTI(61).EQ.1) THEN
3446 MINT(5)=MINT(5)-1
3447 RETURN
3448 ENDIF
3449 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3450 CALL PYXTOT
3451 ENDIF
3452
3453C...Loop over number of pileup events; check space left.
3454 IF(MSTP(131).LE.0) THEN
3455 NPILE=1
3456 ELSE
3457 CALL PYPILE(2)
3458 NPILE=MINT(81)
3459 ENDIF
3460 DO 300 IPILE=1,NPILE
3461 IF(MINT(84)+100.GE.MSTU(4)) THEN
3462 CALL PYERRM(11,
3463 & '(PYEVNW:) no more space in PYJETS for pileup events')
3464 IF(MSTU(21).GE.1) GOTO 310
3465 ENDIF
3466 MINT(82)=IPILE
3467
3468C...Generate variables of hard scattering.
3469 MINT(51)=0
3470 MSTI(52)=0
3471 100 CONTINUE
3472 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3473 MINT(31)=0
3474 MINT(39)=0
3475 MINT(36)=0
3476 MINT(51)=0
3477 MINT(57)=0
3478 CALL PYRAND
3479 IF(MSTI(61).EQ.1) THEN
3480 MINT(5)=MINT(5)-1
3481 RETURN
3482 ENDIF
3483 IF(MINT(51).EQ.2) RETURN
3484 ISUB=MINT(1)
3485 IF(MSTP(111).EQ.-1) GOTO 290
3486
3487C...Loopback point if PYPREP fails, especially for junction topologies.
3488 NPREP=0
3489 MNT31S=MINT(31)
3490 110 NPREP=NPREP+1
3491 MINT(31)=MNT31S
3492
3493 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3494C...Hard scattering (including low-pT):
3495C...reconstruct kinematics and colour flow of hard scattering.
3496 MINT31=MINT(31)
3497 120 MINT(31)=MINT31
3498 MINT(51)=0
3499 CALL PYSCAT
3500 IF(MINT(51).EQ.1) GOTO 100
3501 NPARTD=N
3502 NFIN=N
3503
3504C...Intertwined initial state showers and multiple interactions.
3505C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3506C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3507 MSTP61=MSTP(61)
3508 IF (MINT(47).LT.2) MSTP(61)=0
3509 MSTP81=MSTP(81)
3510 IF (MINT(50).EQ.0) MSTP(81)=0
3511 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3512 & MINT(111).NE.12) THEN
3513C...Absolute max pT2 scale for evolution: phase space limit.
3514 PT2MXS=0.25D0*VINT(2)
3515C...Check if more constrained by ISR and MI max scales:
3516 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3517C...Loopback point in case of failure in evolution.
3518 LOOP=0
3519 130 LOOP=LOOP+1
3520 MINT(51)=0
3521 IF(LOOP.GT.100) THEN
3522 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3523 & //'multiple interactions.')
3524 MINT(51)=1
3525 RETURN
3526 ENDIF
3527
3528C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3529C...once per event. (E.g. compute constants and save variables to be
3530C...restored later in case of failure.)
3531 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3532
3533C...Initialize interleaved MI/ISR/JI evolution.
3534C...PT2MAX: absolute upper limit for evolution - Initialization may
3535C... return a PT2MAX which is lower than this.
3536C...PT2MIN: absolute lower limit for evolution - Initialization may
3537C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3538 PT2MAX=PT2MXS
3539 PT2MIN=0D0
3540 CALL PYEVOL(0,PT2MAX,PT2MIN)
3541 IF (MINT(51).EQ.1) GOTO 130
3542
3543C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3544C...In principle factorized, so can be stopped and restarted.
3545C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3546C PT2MED=MAX(10D0**2,PT2MIN)
3547C CALL PYEVOL(1,PT2MAX,PT2MED)
3548C IF (MINT(51).EQ.1) GOTO 160
3549C PT2MAX=PT2MED
3550 CALL PYEVOL(1,PT2MAX,PT2MIN)
3551 IF (MINT(51).EQ.1) GOTO 130
3552
3553C...Finalize interleaved MI/ISR/JI evolution.
3554 CALL PYEVOL(2,PT2MAX,PT2MIN)
3555 IF (MINT(51).EQ.1) GOTO 130
3556
3557 ENDIF
3558 MSTP(61)=MSTP61
3559 MSTP(81)=MSTP81
3560 IF(MINT(51).EQ.1) GOTO 100
3561C...(MINT(52) is actually obsolete in this routine. Set anyway
3562C...to ensure PYDOCU stable.)
3563 MINT(52)=N
3564 MINT(53)=N
3565
3566C...Beam remnants - new scheme.
3567 140 IF(MINT(50).EQ.1) THEN
3568 IF (ISUB.EQ.95) MINT(31)=1
3569
3570C...Beam remnant flavour and colour assignments - new scheme.
3571 CALL PYMIHK
3572 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3573 & GOTO 120
3574 IF(MINT(51).EQ.1) GOTO 100
3575
3576C...Primordial kT and beam remnant momentum sharing - new scheme.
3577 CALL PYMIRM
3578 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3579 & GOTO 120
3580 IF(MINT(51).EQ.1) GOTO 100
3581 IF (ISUB.EQ.95) MINT(31)=0
3582 ELSEIF(MINT(111).NE.12) THEN
3583C...Hadron remnants and primordial kT - old model.
3584C...Happens e.g. for direct photon on one side.
3585 IPU1=IMI(1,1,1)
3586 IPU2=IMI(2,1,1)
3587 CALL PYREMN(IPU1,IPU2)
3588 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3589 & 110
3590 IF(MINT(51).EQ.1) GOTO 100
3591C...PYREMN does not set colour tags for BRs, so needs to be done now.
3592 DO 160 I=MINT(53)+1,N
3593 DO 150 KCS=4,5
3594 IDA=MOD(K(I,KCS),MSTU(5))
3595 IF (IDA.NE.0) THEN
3596 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3597 ELSE
3598 MCT(I,KCS-3)=0
3599 ENDIF
3600 150 CONTINUE
3601 160 CONTINUE
3602C...Instruct PYPREP to use colour tags
3603 MINT(33)=1
3604
3605 DO 360 MQGST=1,2
3606 DO 350 I=MINT(84)+1,N
3607
3608C...Look for coloured string endpoint, or (later) leftover gluon.
3609 IF (K(I,1).NE.3) GOTO 350
3610 KC=PYCOMP(K(I,2))
3611 IF(KC.EQ.0) GOTO 350
3612 KQ=KCHG(KC,2)
3613 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3614
3615C... Pick up loose string end with no previous tag.
3616 KCS=4
3617 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3618 IF(MCT(I,KCS-3).NE.0) GOTO 350
3619
3620 CALL PYCTTR(I,KCS,I)
3621 IF(MINT(51).NE.0) RETURN
3622
3623 350 CONTINUE
3624 360 CONTINUE
3625C...Now delete any colour processing information if set (since partons
3626C...otherwise not FS showered!)
3627 DO 170 I=MINT(84)+1,N
3628 IF (I.LE.N) THEN
3629 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3630 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3631 ENDIF
3632 170 CONTINUE
3633 ENDIF
3634
3635C...Showering of final state partons (optional).
3636 ALAMSV=PARJ(81)
3637 PARJ(81)=PARP(72)
3638 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3639 & THEN
3640 QMAX=VINT(55)
3641 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3642 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3643C...External processes: handle successive showers.
3644 ELSEIF(ISET(ISUB).EQ.11) THEN
3645 CALL PYADSH(NFIN)
3646 ENDIF
3647 PARJ(81)=ALAMSV
3648
3649C...Allow possibility for user to abort event generation.
3650 IVETO=0
3651 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3652 IF(IVETO.EQ.1) GOTO 100
3653
3654
3655C...Decay of final state resonances.
3656 MINT(32)=0
3657 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3658 CALL PYRESD(0)
3659 IF(MINT(51).NE.0) GOTO 100
3660 ENDIF
3661
3662 IF(MINT(51).EQ.1) GOTO 100
3663
3664 ELSEIF(ISUB.NE.99) THEN
3665C...Diffractive and elastic scattering.
3666 CALL PYDIFF
3667
3668 ELSE
3669C...DIS scattering (photon flux external).
3670 CALL PYDISG
3671 IF(MINT(51).EQ.1) GOTO 100
3672 ENDIF
3673
3674C...Check that no odd resonance left undecayed.
3675 MINT(54)=N
3676 IF(MSTP(111).GE.1) THEN
3677 NFIX=N
3678 DO 180 I=MINT(84)+1,NFIX
3679 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3680 & K(I,2).NE.22) THEN
3681 KCA=PYCOMP(K(I,2))
3682 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3683 CALL PYRESD(I)
3684 IF(MINT(51).EQ.1) GOTO 100
3685 ENDIF
3686 ENDIF
3687 180 CONTINUE
3688 ENDIF
3689
3690C...Boost hadronic subsystem to overall rest frame.
3691C..(Only relevant when photon inside lepton beam.)
3692 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3693
3694C...Recalculate energies from momenta and masses (if desired).
3695 IF(MSTP(113).GE.1) THEN
3696 DO 190 I=MINT(83)+1,N
3697 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3698 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3699 190 CONTINUE
3700 NRECAL=N
3701 ENDIF
3702
3703C...Colour reconnection before string formation
3704 CALL PYFSCR(MINT(84)+1)
3705
3706C...Rearrange partons along strings, check invariant mass cuts.
3707 MSTU(28)=0
3708 IF(MSTP(111).LE.0) MSTJ(14)=-1
3709 CALL PYPREP(MINT(84)+1)
3710 MSTJ(14)=MSTJ14
3711 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3712 MSTU(24)=0
3713 GOTO 100
3714 ENDIF
3715 IF(MINT(51).EQ.1) GOTO 110
3716 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3717 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3718 DO 220 I=MINT(84)+1,N
3719 IF(K(I,2).EQ.94) THEN
3720 DO 210 I1=I+1,MIN(N,I+10)
3721 IF(K(I1,3).EQ.I) THEN
3722 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3723 IF(K(I1,3).EQ.0) THEN
3724 DO 200 II=MINT(84)+1,I-1
3725 IF(K(II,2).EQ.K(I1,2)) THEN
3726 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3727 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3728 ENDIF
3729 200 CONTINUE
3730 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3731 ENDIF
3732 ENDIF
3733 210 CONTINUE
3734 ENDIF
3735 220 CONTINUE
3736 CALL PYEDIT(12)
3737 CALL PYEDIT(14)
3738 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3739 IF(MSTP(125).EQ.0) MINT(4)=0
3740 DO 240 I=MINT(83)+1,N
3741 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3742 DO 230 I1=I+1,N
3743 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3744 IF(K(I1,3).EQ.I) K(I,5)=I1
3745 230 CONTINUE
3746 ENDIF
3747 240 CONTINUE
3748 ENDIF
3749
3750C...Introduce separators between sections in PYLIST event listing.
3751 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3752 MSTU70=1
3753 MSTU(71)=N
3754 ELSEIF(IPILE.EQ.1) THEN
3755 MSTU70=3
3756 MSTU(71)=2
3757 MSTU(72)=MINT(4)
3758 MSTU(73)=N
3759 ENDIF
3760
3761C...Go back to lab frame (needed for vertices, also in fragmentation).
3762 CALL PYFRAM(1)
3763
3764C...Set nonvanishing production vertex (optional).
3765 IF(MSTP(151).EQ.1) THEN
3766 DO 250 J=1,4
3767 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3768 & SIN(PARU(2)*PYR(0))
3769 250 CONTINUE
3770 DO 270 I=MINT(83)+1,N
3771 DO 260 J=1,4
3772 V(I,J)=V(I,J)+VTX(J)
3773 260 CONTINUE
3774 270 CONTINUE
3775 ENDIF
3776
3777C...Perform hadronization (if desired).
3778 IF(MSTP(111).GE.1) THEN
3779 CALL PYEXEC
3780 IF(MSTU(24).NE.0) GOTO 100
3781 ENDIF
3782 IF(MSTP(113).GE.1) THEN
3783 DO 280 I=NRECAL,N
3784 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3785 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3786 280 CONTINUE
3787 ENDIF
3788 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3789
3790C...Store event information and calculate Monte Carlo estimates of
3791C...subprocess cross-sections.
3792 290 IF(IPILE.EQ.1) CALL PYDOCU
3793
3794C...Set counters for current pileup event and loop to next one.
3795 MSTI(41)=IPILE
3796 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3797 IF(MSTU70.LT.10) THEN
3798 MSTU70=MSTU70+1
3799 MSTU(70+MSTU70)=N
3800 ENDIF
3801 MINT(83)=N
3802 MINT(84)=N+MSTP(126)
3803 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3804 300 CONTINUE
3805
3806C...Generic information on pileup events. Reconstruct missing history.
3807 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3808 PARI(91)=VINT(132)
3809 PARI(92)=VINT(133)
3810 PARI(93)=VINT(134)
3811 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3812 ENDIF
3813 CALL PYEDIT(16)
3814
3815C...Transform to the desired coordinate frame.
3816 310 CALL PYFRAM(MSTP(124))
3817 MSTU(70)=MSTU70
3818 PARU(21)=VINT(1)
3819
3820C...Error messages
3821 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3822 &1X,'Execution stopped.')
3823
3824 RETURN
3825 END
3826
3827
3828C***********************************************************************
3829
3830C...PYSTAT
3831C...Prints out information about cross-sections, decay widths, branching
3832C...ratios, kinematical limits, status codes and parameter values.
3833
3834 SUBROUTINE PYSTAT(MSTAT)
3835
3836C...Double precision and integer declarations.
3837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3838 IMPLICIT INTEGER(I-N)
3839 INTEGER PYK,PYCHGE,PYCOMP
3840C...Parameter statement to help give large particle numbers.
3841 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
3842 &KEXCIT=4000000,KDIMEN=5000000)
3843 PARAMETER (EPS=1D-3)
3844C...Commonblocks.
3845 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3846 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3847 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3848 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
3849 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3850 COMMON/PYINT1/MINT(400),VINT(400)
3851 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3852 COMMON/PYINT4/MWID(500),WIDS(500,5)
3853 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3854 COMMON/PYINT6/PROC(0:500)
3855 CHARACTER PROC*28, CHTMP*16
3856 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
3857 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
3858 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
3859 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
3860C...Local arrays, character variables and data.
3861 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
3862 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
3863 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
3864 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
3865 CHARACTER*24 CHD0, CHDC(10)
3866 CHARACTER*6 DNAME(3)
3867 DATA PROGA/
3868 &'VMD/hadron * VMD ','VMD/hadron * direct ',
3869 &'VMD/hadron * anomalous ','direct * direct ',
3870 &'direct * anomalous ','anomalous * anomalous '/
3871 DATA DISGA/'e * VMD','e * anomalous'/
3872 DATA PROGG9/
3873 &'direct * direct ','direct * VMD ',
3874 &'direct * anomalous ','VMD * direct ',
3875 &'VMD * VMD ','VMD * anomalous ',
3876 &'anomalous * direct ','anomalous * VMD ',
3877 &'anomalous * anomalous ','DIS * VMD ',
3878 &'DIS * anomalous ','VMD * DIS ',
3879 &'anomalous * DIS '/
3880 DATA PROGG4/
3881 &'direct * direct ','direct * resolved ',
3882 &'resolved * direct ','resolved * resolved '/
3883 DATA PROGG2/
3884 &'direct * hadron ','resolved * hadron '/
3885 DATA PROGP4/
3886 &'VMD * hadron ','direct * hadron ',
3887 &'anomalous * hadron ','DIS * hadron '/
3888 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
3889 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
3890 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
3891 &' y*_small ',' eta*_large ',' eta*_small ',
3892 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
3893 &' x_2 ',' x_F ',' cos(theta_hard) ',
3894 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
3895 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
3896 &' tau'' '/
3897 DATA DNAME /'q ','lepton','nu '/
3898
3899C...Cross-sections.
3900 IF(MSTAT.LE.1) THEN
3901 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
3902 WRITE(MSTU(11),5000)
3903 WRITE(MSTU(11),5100)
3904 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
3905 DO 100 I=1,500
3906 IF(MSUB(I).NE.1) GOTO 100
3907 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
3908 100 CONTINUE
3909 IF(MINT(121).GT.1) THEN
3910 WRITE(MSTU(11),5300)
3911 DO 110 IGA=1,MINT(121)
3912 CALL PYSAVE(3,IGA)
3913 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
3914 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
3915 & XSEC(0,3)
3916 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
3917 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
3918 & XSEC(0,3)
3919 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
3920 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
3921 & XSEC(0,3)
3922 ELSEIF(MINT(121).EQ.4) THEN
3923 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
3924 & XSEC(0,3)
3925 ELSEIF(MINT(121).EQ.2) THEN
3926 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
3927 & XSEC(0,3)
3928 ELSE
3929 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
3930 & XSEC(0,3)
3931 ENDIF
3932 110 CONTINUE
3933 CALL PYSAVE(5,0)
3934 ENDIF
3935 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
3936 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
3937
3938C...Decay widths and branching ratios.
3939 ELSEIF(MSTAT.EQ.2) THEN
3940 WRITE(MSTU(11),5500)
3941 WRITE(MSTU(11),5600)
3942 DO 140 KC=1,500
3943 KF=KCHG(KC,4)
3944 CALL PYNAME(KF,CHKF)
3945 IOFF=0
3946 IF(KC.LE.22) THEN
3947 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
3948 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
3949 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
3950 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
3951 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
3952 ELSE
3953 IF(MWID(KC).LE.0) GOTO 140
3954 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
3955 & KF/KSUSY1.EQ.2)) GOTO 140
3956 ENDIF
3957C...Off-shell branchings.
3958 IF(IOFF.EQ.1) THEN
3959 NGP=0
3960 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
3961 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
3962 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
3963 DO 120 J=1,MDCY(KC,3)
3964 IDC=J+MDCY(KC,2)-1
3965 NGP1=0
3966 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3967 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3968 NGP2=0
3969 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3970 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3971 CALL PYNAME(KFDP(IDC,1),CHD1)
3972 CALL PYNAME(KFDP(IDC,2),CHD2)
3973 IF(KFDP(IDC,3).EQ.0) THEN
3974 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3975 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
3976 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3977 ELSE
3978 CALL PYNAME(KFDP(IDC,3),CHD3)
3979 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
3980 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
3981 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
3982 ENDIF
3983 120 CONTINUE
3984C...On-shell decays.
3985 ELSE
3986 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
3987 BRFIN=1D0
3988 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
3989 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
3990 & STATE(MDCY(KC,1)),BRFIN
3991 DO 130 J=1,MDCY(KC,3)
3992 IDC=J+MDCY(KC,2)-1
3993 NGP1=0
3994 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
3995 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
3996 NGP2=0
3997 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
3998 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
3999 BRPRI=0D0
4000 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4001 BRFIN=0D0
4002 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4003 CALL PYNAME(KFDP(IDC,1),CHD1)
4004 CALL PYNAME(KFDP(IDC,2),CHD2)
4005 IF(KFDP(IDC,3).EQ.0) THEN
4006 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4007 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4008 & CHD2(1:10),WDTP(J),BRPRI,
4009 & STATE(MDME(IDC,1)),BRFIN
4010 ELSE
4011 CALL PYNAME(KFDP(IDC,3),CHD3)
4012 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4013 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4014 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4015 & STATE(MDME(IDC,1)),BRFIN
4016 ENDIF
4017 130 CONTINUE
4018 ENDIF
4019 140 CONTINUE
4020 WRITE(MSTU(11),6000)
4021
4022C...Allowed incoming partons/particles at hard interaction.
4023 ELSEIF(MSTAT.EQ.3) THEN
4024 WRITE(MSTU(11),6100)
4025 CALL PYNAME(MINT(11),CHAU)
4026 CHIN(1)=CHAU(1:12)
4027 CALL PYNAME(MINT(12),CHAU)
4028 CHIN(2)=CHAU(1:12)
4029 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4030 DO 150 I=-20,22
4031 IF(I.EQ.0) GOTO 150
4032 IA=IABS(I)
4033 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4034 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4035 CALL PYNAME(I,CHAU)
4036 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4037 & STATE(KFIN(2,I))
4038 150 CONTINUE
4039 WRITE(MSTU(11),6400)
4040
4041C...User-defined limits on kinematical variables.
4042 ELSEIF(MSTAT.EQ.4) THEN
4043 WRITE(MSTU(11),6500)
4044 WRITE(MSTU(11),6600)
4045 SHRMAX=CKIN(2)
4046 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4047 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4048 PTHMIN=MAX(CKIN(3),CKIN(5))
4049 PTHMAX=CKIN(4)
4050 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4051 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4052 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4053 DO 160 I=4,14
4054 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4055 160 CONTINUE
4056 SPRMAX=CKIN(32)
4057 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4058 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4059 WRITE(MSTU(11),7000)
4060
4061C...Status codes and parameter values.
4062 ELSEIF(MSTAT.EQ.5) THEN
4063 WRITE(MSTU(11),7100)
4064 WRITE(MSTU(11),7200)
4065 DO 170 I=1,100
4066 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4067 & PARP(100+I)
4068 170 CONTINUE
4069
4070C...List of all processes implemented in the program.
4071 ELSEIF(MSTAT.EQ.6) THEN
4072 WRITE(MSTU(11),7400)
4073 WRITE(MSTU(11),7500)
4074 DO 180 I=1,500
4075 IF(ISET(I).LT.0) GOTO 180
4076 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4077 180 CONTINUE
4078 WRITE(MSTU(11),7700)
4079
4080 ELSEIF(MSTAT.EQ.7) THEN
4081 WRITE (MSTU(11),8000)
4082 NMODES(0)=0
4083 NMODES(10)=0
4084 NMODES(9)=0
4085 DO 290 ILR=1,2
4086 DO 280 KFSM=1,16
4087 KFSUSY=ILR*KSUSY1+KFSM
4088 NRVDC=0
4089C...SDOWN DECAYS
4090 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4091 NRVDC=3
4092 DO 190 I=1,NRVDC
4093 PBRAT(I)=0D0
4094 NMODES(I)=0
4095 190 CONTINUE
4096 CALL PYNAME(KFSUSY,CHTMP)
4097 CHD0=CHTMP//' '
4098 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4099 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4100 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4101 KC=PYCOMP(KFSUSY)
4102 DO 200 J=1,MDCY(KC,3)
4103 IDC=J+MDCY(KC,2)-1
4104 ID1=IABS(KFDP(IDC,1))
4105 ID2=IABS(KFDP(IDC,2))
4106 IF (KFDP(IDC,3).EQ.0) THEN
4107 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4108 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4109 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4110 NMODES(1)=NMODES(1)+1
4111 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4112 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4113 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4114 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4115 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4116 NMODES(2)=NMODES(2)+1
4117 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4118 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4119 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4120 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4121 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4122 NMODES(3)=NMODES(3)+1
4123 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4124 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4125 ENDIF
4126 ENDIF
4127 200 CONTINUE
4128 ENDIF
4129C...SUP DECAYS
4130 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4131 NRVDC=2
4132 DO 210 I=1,NRVDC
4133 NMODES(I)=0
4134 PBRAT(I)=0D0
4135 210 CONTINUE
4136 CALL PYNAME(KFSUSY,CHTMP)
4137 CHD0=CHTMP//' '
4138 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4139 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4140 KC=PYCOMP(KFSUSY)
4141 DO 220 J=1,MDCY(KC,3)
4142 IDC=J+MDCY(KC,2)-1
4143 ID1=IABS(KFDP(IDC,1))
4144 ID2=IABS(KFDP(IDC,2))
4145 IF (KFDP(IDC,3).EQ.0) THEN
4146 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4147 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4148 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4149 NMODES(1)=NMODES(1)+1
4150 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4151 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4152 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4153 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4154 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4155 NMODES(2)=NMODES(2)+1
4156 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4157 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4158 ENDIF
4159 ENDIF
4160 220 CONTINUE
4161 ENDIF
4162C...SLEPTON DECAYS
4163 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4164 NRVDC=2
4165 DO 230 I=1,NRVDC
4166 PBRAT(I)=0D0
4167 NMODES(I)=0
4168 230 CONTINUE
4169 CALL PYNAME(KFSUSY,CHTMP)
4170 CHD0=CHTMP//' '
4171 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4172 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4173 KC=PYCOMP(KFSUSY)
4174 DO 240 J=1,MDCY(KC,3)
4175 IDC=J+MDCY(KC,2)-1
4176 ID1=IABS(KFDP(IDC,1))
4177 ID2=IABS(KFDP(IDC,2))
4178 IF (KFDP(IDC,3).EQ.0) THEN
4179 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4180 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4181 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4182 NMODES(1)=NMODES(1)+1
4183 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4184 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4185 ENDIF
4186 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4187 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4188 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4189 NMODES(2)=NMODES(2)+1
4190 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4191 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4192 ENDIF
4193 ENDIF
4194 240 CONTINUE
4195 ENDIF
4196C...SNEUTRINO DECAYS
4197 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4198 & THEN
4199 NRVDC=2
4200 DO 250 I=1,NRVDC
4201 PBRAT(I)=0D0
4202 NMODES(I)=0
4203 250 CONTINUE
4204 CALL PYNAME(KFSUSY,CHTMP)
4205 CHD0=CHTMP//' '
4206 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4207 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4208 KC=PYCOMP(KFSUSY)
4209 DO 260 J=1,MDCY(KC,3)
4210 IDC=J+MDCY(KC,2)-1
4211 ID1=IABS(KFDP(IDC,1))
4212 ID2=IABS(KFDP(IDC,2))
4213 IF (KFDP(IDC,3).EQ.0) THEN
4214 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4215 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4216 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4217 NMODES(1)=NMODES(1)+1
4218 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4219 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4220 ENDIF
4221 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4222 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4223 NMODES(2)=NMODES(2)+1
4224 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4225 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4226 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4227 ENDIF
4228 ENDIF
4229 260 CONTINUE
4230 ENDIF
4231 IF (NRVDC.NE.0) THEN
4232 DO 270 I=1,NRVDC
4233 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4234 NMODES(0)=NMODES(0)+NMODES(I)
4235 270 CONTINUE
4236 ENDIF
4237 280 CONTINUE
4238 290 CONTINUE
4239 DO 370 KFSM=21,37
4240 KFSUSY=KSUSY1+KFSM
4241 NRVDC=0
4242C...NEUTRALINO DECAYS
4243 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4244 NRVDC=4
4245 DO 300 I=1,NRVDC
4246 PBRAT(I)=0D0
4247 NMODES(I)=0
4248 300 CONTINUE
4249 CALL PYNAME(KFSUSY,CHTMP)
4250 CHD0=CHTMP//' '
4251 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4252 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4253 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4254 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4255 KC=PYCOMP(KFSUSY)
4256 DO 310 J=1,MDCY(KC,3)
4257 IDC=J+MDCY(KC,2)-1
4258 ID1=IABS(KFDP(IDC,1))
4259 ID2=IABS(KFDP(IDC,2))
4260 ID3=IABS(KFDP(IDC,3))
4261 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4262 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4263 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4264 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4265 NMODES(1)=NMODES(1)+1
4266 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4267 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4268 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4269 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4270 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4271 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4272 NMODES(2)=NMODES(2)+1
4273 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4274 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4275 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4276 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4277 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4278 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4279 NMODES(3)=NMODES(3)+1
4280 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4281 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4282 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4283 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4284 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4285 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4286 NMODES(4)=NMODES(4)+1
4287 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4288 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4289 ENDIF
4290 310 CONTINUE
4291 ENDIF
4292C...CHARGINO DECAYS
4293 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4294 NRVDC=5
4295 DO 320 I=1,NRVDC
4296 PBRAT(I)=0D0
4297 NMODES(I)=0
4298 320 CONTINUE
4299 CALL PYNAME(KFSUSY,CHTMP)
4300 CHD0=CHTMP//' '
4301 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4302 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4303 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4304 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4305 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4306 KC=PYCOMP(KFSUSY)
4307 DO 330 J=1,MDCY(KC,3)
4308 IDC=J+MDCY(KC,2)-1
4309 ID1=IABS(KFDP(IDC,1))
4310 ID2=IABS(KFDP(IDC,2))
4311 ID3=IABS(KFDP(IDC,3))
4312 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4313 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4314 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4315 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4316 NMODES(1)=NMODES(1)+1
4317 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4318 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4319 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4320 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4321 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4322 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4323 NMODES(1)=NMODES(1)+1
4324 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4325 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4326 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4327 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4328 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4329 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4330 NMODES(2)=NMODES(2)+1
4331 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4332 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4333 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4334 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4335 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4336 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4337 NMODES(3)=NMODES(3)+1
4338 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4339 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4340 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4341 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4342 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4343 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4344 NMODES(3)=NMODES(3)+1
4345 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4346 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4347 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4348 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4349 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4350 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4351 NMODES(4)=NMODES(4)+1
4352 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4353 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4354 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4355 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4356 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4357 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4358 NMODES(4)=NMODES(4)+1
4359 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4360 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4361 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4362 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4363 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4364 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4365 NMODES(5)=NMODES(5)+1
4366 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4367 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4368 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4369 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4370 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4371 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4372 NMODES(5)=NMODES(5)+1
4373 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4374 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4375 ENDIF
4376 330 CONTINUE
4377 ENDIF
4378C...GLUINO DECAYS
4379 IF (KFSM.EQ.21) THEN
4380 NRVDC=3
4381 DO 340 I=1,NRVDC
4382 PBRAT(I)=0D0
4383 NMODES(I)=0
4384 340 CONTINUE
4385 CALL PYNAME(KFSUSY,CHTMP)
4386 CHD0=CHTMP//' '
4387 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4388 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4389 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4390 KC=PYCOMP(KFSUSY)
4391 DO 350 J=1,MDCY(KC,3)
4392 IDC=J+MDCY(KC,2)-1
4393 ID1=IABS(KFDP(IDC,1))
4394 ID2=IABS(KFDP(IDC,2))
4395 ID3=IABS(KFDP(IDC,3))
4396 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4397 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4398 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4399 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4400 NMODES(1)=NMODES(1)+1
4401 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4402 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4403 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4404 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4405 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4406 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4407 NMODES(2)=NMODES(2)+1
4408 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4409 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4410 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4411 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4412 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4413 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4414 NMODES(3)=NMODES(3)+1
4415 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4416 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4417 ENDIF
4418 350 CONTINUE
4419 ENDIF
4420
4421 IF (NRVDC.NE.0) THEN
4422 DO 360 I=1,NRVDC
4423 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4424 NMODES(0)=NMODES(0)+NMODES(I)
4425 360 CONTINUE
4426 ENDIF
4427 370 CONTINUE
4428 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4429
4430 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4431 WRITE (MSTU(11),8500)
4432 DO 400 IRV=1,3
4433 DO 390 JRV=1,3
4434 DO 380 KRV=1,3
4435 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4436 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4437 380 CONTINUE
4438 390 CONTINUE
4439 400 CONTINUE
4440 WRITE (MSTU(11),8600)
4441 ENDIF
4442 ENDIF
4443
4444C...Formats for printouts.
4445 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4446 &'Events and Cross-sections',1X,9('*'))
4447 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4448 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4449 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4450 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4451 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4452 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4453 &'I',12X,'I')
4454 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4455 &D10.3,1X,'I')
4456 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4457 &1X,'I',34X,'I',28X,'I',12X,'I')
4458 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4459 &1X,'********* Total number of errors, excluding junctions =',
4460 &1X,I8,' *************'/
4461 &1X,'********* Total number of errors, including junctions =',
4462 &1X,I8,' *************'/
4463 &1X,'********* Total number of warnings = ',
4464 &1X,I8,' *************'/
4465 &1X,'********* Fraction of events that fail fragmentation ',
4466 &'cuts =',1X,F8.5,' *********'/)
4467 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4468 &'Ratios',1X,27('*'))
4469 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4470 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4471 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4472 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4473 &1X,98('='))
4474 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4475 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4476 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4477 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4478 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4479 &1P,D10.3,0P,1X,'I')
4480 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4481 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4482 &1P,D10.3,0P,1X,'I')
4483 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4484 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4485 &'Particles at Hard Interaction',1X,7('*'))
4486 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4487 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4488 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4489 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4490 &78('=')/1X,'I',38X,'I',37X,'I')
4491 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4492 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4493 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4494 &'Kinematical Variables',1X,12('*'))
4495 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4496 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4497 &16X,'I')
4498 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4499 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4500 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4501 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4502 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4503 &'Parameter Values',1X,12('*'))
4504 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4505 &'PARP(I)'/)
4506 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4507 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4508 &1X,13('*'))
4509 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4510 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4511 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4512 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4513 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4514 8000 FORMAT(1X/ 1X/
4515 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4516 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4517 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4518 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4519 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4520 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4521 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4522 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4523 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4524 & /1X,70('='))
4525 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4526 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4527 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4528 8500 FORMAT(1X/ 1X/
4529 & 1X,'R-Violating couplings',1X/ 1X /
4530 & 1X,55('=')/
4531 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4532 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4533 & ,'I',15X,'I',15X,'I',15X,'I')
4534 8600 FORMAT(1X,55('='))
4535 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4536 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4537
4538 RETURN
4539 END
4540
4541C*********************************************************************
4542
4543C...PYUPEV
4544C...Administers the hard-process generation required for output to the
4545C...Les Houches event record.
4546
4547 SUBROUTINE PYUPEV
4548
4549C...Double precision and integer declarations.
4550 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4551 IMPLICIT INTEGER(I-N)
4552 INTEGER PYK,PYCHGE,PYCOMP
4553
4554C...Commonblocks.
4555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4556 COMMON/PYCTAG/NCT,MCT(4000,2)
4557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4561 COMMON/PYINT1/MINT(400),VINT(400)
4562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4563 COMMON/PYINT4/MWID(500),WIDS(500,5)
4564 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4565 &/PYINT1/,/PYINT2/,/PYINT4/
4566
4567C...HEPEUP for output.
4568 INTEGER MAXNUP
4569 PARAMETER (MAXNUP=500)
4570 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4571 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4572 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4573 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4574 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4575 SAVE /HEPEUP/
4576
4577C...Stop if no subprocesses on.
4578 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4579 WRITE(MSTU(11),5100)
4580 STOP
4581 ENDIF
4582
4583C...Special flags for hard-process generation only.
4584 MSTP71=MSTP(71)
4585 MSTP(71)=0
4586 MST128=MSTP(128)
4587 MSTP(128)=1
4588
4589C...Initial values for some counters.
4590 N=0
4591 MINT(5)=MINT(5)+1
4592 MINT(7)=0
4593 MINT(8)=0
4594 MINT(30)=0
4595 MINT(83)=0
4596 MINT(84)=MSTP(126)
4597 MSTU(24)=0
4598 MSTU70=0
4599 MSTJ14=MSTJ(14)
4600C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4601 MINT(33)=0
4602
4603C...If variable energies: redo incoming kinematics and cross-section.
4604 MSTI(61)=0
4605 IF(MSTP(171).EQ.1) THEN
4606 CALL PYINKI(1)
4607 IF(MSTI(61).EQ.1) THEN
4608 MINT(5)=MINT(5)-1
4609 RETURN
4610 ENDIF
4611 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4612 CALL PYXTOT
4613 ENDIF
4614
4615C...Do not allow pileup events.
4616 MINT(82)=1
4617
4618C...Generate variables of hard scattering.
4619 MINT(51)=0
4620 MSTI(52)=0
4621 100 CONTINUE
4622 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4623 MINT(31)=0
4624 MINT(51)=0
4625 MINT(57)=0
4626 CALL PYRAND
4627 IF(MSTI(61).EQ.1) THEN
4628 MINT(5)=MINT(5)-1
4629 RETURN
4630 ENDIF
4631 IF(MINT(51).EQ.2) RETURN
4632 ISUB=MINT(1)
4633
4634 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4635C...Hard scattering (including low-pT):
4636C...reconstruct kinematics and colour flow of hard scattering.
4637 MINT31=MINT(31)
4638 110 MINT(31)=MINT31
4639 MINT(51)=0
4640 CALL PYSCAT
4641 IF(MINT(51).EQ.1) GOTO 100
4642 IPU1=MINT(84)+1
4643 IPU2=MINT(84)+2
4644
4645C...Decay of final state resonances.
4646 MINT(32)=0
4647 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4648 & CALL PYRESD(0)
4649 IF(MINT(51).EQ.1) GOTO 100
4650 MINT(52)=N
4651
4652C...Longitudinal boost of hard scattering.
4653 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4654 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4655
4656 ELSEIF(ISUB.NE.99) THEN
4657C...Diffractive and elastic scattering.
4658 CALL PYDIFF
4659
4660 ELSE
4661C...DIS scattering (photon flux external).
4662 CALL PYDISG
4663 IF(MINT(51).EQ.1) GOTO 100
4664 ENDIF
4665
4666C...Check that no odd resonance left undecayed.
4667 MINT(54)=N
4668 NFIX=N
4669 DO 120 I=MINT(84)+1,NFIX
4670 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4671 & K(I,2).NE.22) THEN
4672 KCA=PYCOMP(K(I,2))
4673 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4674 CALL PYRESD(I)
4675 IF(MINT(51).EQ.1) GOTO 100
4676 ENDIF
4677 ENDIF
4678 120 CONTINUE
4679
4680C...Boost hadronic subsystem to overall rest frame.
4681C..(Only relevant when photon inside lepton beam.)
4682 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4683
4684C...Store event information and calculate Monte Carlo estimates of
4685C...subprocess cross-sections.
4686 130 CALL PYDOCU
4687
4688C...Transform to the desired coordinate frame.
4689 140 CALL PYFRAM(MSTP(124))
4690 MSTU(70)=MSTU70
4691 PARU(21)=VINT(1)
4692
4693C...Restore special flags for hard-process generation only.
4694 MSTP(71)=MSTP71
4695 MSTP(128)=MST128
4696
4697C...Trace colour tags; convert to LHA style labels.
4698 NCT=100
4699 DO 150 I=MINT(84)+1,N
4700 MCT(I,1)=0
4701 MCT(I,2)=0
4702 150 CONTINUE
4703 DO 160 I=MINT(84)+1,N
4704 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4705 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4706 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4707 & THEN
4708 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4709 IDA=MOD(K(I,4),MSTU(5))
4710 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4711 & MCT(IMO,2).NE.0) THEN
4712 MCT(I,1)=MCT(IMO,2)
4713 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4714 & MCT(IMO,1).NE.0) THEN
4715 MCT(I,1)=MCT(IMO,1)
4716 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4717 & MCT(IDA,2).NE.0) THEN
4718 MCT(I,1)=MCT(IDA,2)
4719 ELSE
4720 NCT=NCT+1
4721 MCT(I,1)=NCT
4722 ENDIF
4723 ENDIF
4724 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4725 & THEN
4726 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4727 IDA=MOD(K(I,5),MSTU(5))
4728 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4729 & MCT(IMO,1).NE.0) THEN
4730 MCT(I,2)=MCT(IMO,1)
4731 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4732 & MCT(IMO,2).NE.0) THEN
4733 MCT(I,2)=MCT(IMO,2)
4734 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4735 & MCT(IDA,1).NE.0) THEN
4736 MCT(I,2)=MCT(IDA,1)
4737 ELSE
4738 NCT=NCT+1
4739 MCT(I,2)=NCT
4740 ENDIF
4741 ENDIF
4742 ENDIF
4743 160 CONTINUE
4744
4745C...Put event in HEPEUP commonblock.
4746 NUP=N-MINT(84)
4747 IDPRUP=MINT(1)
4748 XWGTUP=1D0
4749 SCALUP=VINT(53)
4750 AQEDUP=VINT(57)
4751 AQCDUP=VINT(58)
4752 DO 180 I=1,NUP
4753 IDUP(I)=K(I+MINT(84),2)
4754 IF(I.LE.2) THEN
4755 ISTUP(I)=-1
4756 MOTHUP(1,I)=0
4757 MOTHUP(2,I)=0
4758 ELSEIF(K(I+4,3).EQ.0) THEN
4759 ISTUP(I)=1
4760 MOTHUP(1,I)=1
4761 MOTHUP(2,I)=2
4762 ELSE
4763 ISTUP(I)=1
4764 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4765 MOTHUP(2,I)=0
4766 ENDIF
4767 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4768 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4769 ICOLUP(1,I)=MCT(I+MINT(84),1)
4770 ICOLUP(2,I)=MCT(I+MINT(84),2)
4771 DO 170 J=1,5
4772 PUP(J,I)=P(I+MINT(84),J)
4773 170 CONTINUE
4774 VTIMUP(I)=V(I,5)
4775 SPINUP(I)=9D0
4776 180 CONTINUE
4777
4778C...Optionally write out event to disk. Minimal size for time/spin fields.
4779 IF(MSTP(162).GT.0) THEN
4780 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4781 DO 190 I=1,NUP
4782 IF(VTIMUP(I).EQ.0D0) THEN
4783 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4784 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4785 & ' 0. 9.'
4786 ELSE
4787 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4788 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4789 & VTIMUP(I),' 9.'
4790 ENDIF
4791 190 CONTINUE
4792
4793C...Optional extra line with parton-density information.
4794 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4795 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4796 ENDIF
4797
4798C...Error messages and other print formats.
4799 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4800 &1X,'Execution stopped.')
4801 5200 FORMAT(1P,2I6,4E14.6)
4802 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4803 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4804 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4805
4806 RETURN
4807 END
4808
4809C*********************************************************************
4810
4811C...PYUPIN
4812C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4813C...processes, and optionally stores that information on file.
4814
4815 SUBROUTINE PYUPIN
4816
4817C...Double precision and integer declarations.
4818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4819 IMPLICIT INTEGER(I-N)
4820
4821C...Commonblocks.
4822 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4823 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4824 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4825 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4826 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
4827
4828C...User process initialization commonblock.
4829 INTEGER MAXPUP
4830 PARAMETER (MAXPUP=100)
4831 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4832 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4833 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4834 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4835 &LPRUP(MAXPUP)
4836 SAVE /HEPRUP/
4837
4838C...Store info on incoming beams.
4839 IDBMUP(1)=K(1,2)
4840 IDBMUP(2)=K(2,2)
4841 EBMUP(1)=P(1,4)
4842 EBMUP(2)=P(2,4)
4843 PDFGUP(1)=0
4844 PDFGUP(2)=0
4845 PDFSUP(1)=MSTP(51)
4846 PDFSUP(2)=MSTP(51)
4847
4848C...Event weighting strategy.
4849 IDWTUP=3
4850
4851C...Info on individual processes.
4852 NPRUP=0
4853 DO 100 ISUB=1,500
4854 IF(MSUB(ISUB).EQ.1) THEN
4855 NPRUP=NPRUP+1
4856 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
4857 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
4858 XMAXUP(NPRUP)=1D0
4859 LPRUP(NPRUP)=ISUB
4860 ENDIF
4861 100 CONTINUE
4862
4863C...Write info to file.
4864 IF(MSTP(161).GT.0) THEN
4865 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
4866 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4867 DO 110 IPR=1,NPRUP
4868 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
4869 & LPRUP(IPR)
4870 110 CONTINUE
4871 ENDIF
4872
4873C...Formats for printout.
4874 5100 FORMAT(1P,2I8,2E14.6,6I6)
4875 5200 FORMAT(1P,3E14.6,I6)
4876
4877 RETURN
4878 END
4879
4880
4881C*********************************************************************
4882
4883C...Combine the two old-style Pythia initialization and event files
4884C...into a single Les Houches Event File.
4885
4886 SUBROUTINE PYLHEF
4887
4888C...Double precision and integer declarations.
4889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4890 IMPLICIT INTEGER(I-N)
4891
4892C...PYTHIA commonblock: only used to provide read/write units and version.
4893 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4894 SAVE /PYPARS/
4895
4896C...User process initialization commonblock.
4897 INTEGER MAXPUP
4898 PARAMETER (MAXPUP=100)
4899 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
4900 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
4901 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
4902 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
4903 &LPRUP(MAXPUP)
4904 SAVE /HEPRUP/
4905
4906C...User process event common block.
4907 INTEGER MAXNUP
4908 PARAMETER (MAXNUP=500)
4909 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4910 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4911 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4912 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4913 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4914 SAVE /HEPEUP/
4915
4916C...Lines to read in assumed never longer than 200 characters.
4917 PARAMETER (MAXLEN=200)
4918 CHARACTER*(MAXLEN) STRING
4919
4920C...Format for reading lines.
4921 CHARACTER*6 STRFMT
4922 STRFMT='(A000)'
4923 WRITE(STRFMT(3:5),'(I3)') MAXLEN
4924
4925C...Rewind initialization and event files.
4926 REWIND MSTP(161)
4927 REWIND MSTP(162)
4928
4929C...Write header info.
4930 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
4931 WRITE(MSTP(163),'(A)') '<!--'
4932 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
4933 &MSTP(181),'.',MSTP(182)
4934 WRITE(MSTP(163),'(A)') '-->'
4935
4936C...Read first line of initialization info and get number of processes.
4937 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4938 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
4939 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
4940
4941C...Copy initialization lines, omitting trailing blanks.
4942C...Embed in <init> ... </init> block.
4943 WRITE(MSTP(163),'(A)') '<init>'
4944 DO 140 IPR=0,NPRUP
4945 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
4946 LEN=MAXLEN+1
4947 120 LEN=LEN-1
4948 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
4949 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4950 140 CONTINUE
4951 WRITE(MSTP(163),'(A)') '</init>'
4952
4953C...Begin event loop. Read first line of event info or already done.
4954 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
4955 200 CONTINUE
4956
4957C...Look at first line to know number of particles in event.
4958 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4959
4960C...Begin an <event> block. Copy event lines, omitting trailing blanks.
4961 WRITE(MSTP(163),'(A)') '<event>'
4962 DO 240 I=0,NUP
4963 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
4964 LEN=MAXLEN+1
4965 220 LEN=LEN-1
4966 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
4967 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4968 240 CONTINUE
4969
4970C...Copy trailing comment lines - with a # in the first column - as is.
4971 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
4972 IF(STRING(1:1).EQ.'#') THEN
4973 LEN=MAXLEN+1
4974 280 LEN=LEN-1
4975 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
4976 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
4977 GOTO 260
4978 ENDIF
4979
4980C..End the <event> block. Loop back to look for next event.
4981 WRITE(MSTP(163),'(A)') '</event>'
4982 GOTO 200
4983
4984C...Successfully reached end of event loop: write closing tag
4985C...and remove temporary intermediate files (unless asked not to).
4986 300 WRITE(MSTP(163),'(A)') '</event>'
4987 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
4988 IF(MSTP(164).EQ.1) RETURN
4989 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
4990 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
4991 RETURN
4992
4993C...Error exit.
4994 400 WRITE(*,*) ' PYLHEF file joining failed!'
4995
4996 RETURN
4997 END
4998
4999C*********************************************************************
5000
5001C...PYINRE
5002C...Calculates full and effective widths of gauge bosons, stores
5003C...masses and widths, rescales coefficients to be used for
5004C...resonance production generation.
5005
5006 SUBROUTINE PYINRE
5007
5008C...Double precision and integer declarations.
5009 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5010 IMPLICIT INTEGER(I-N)
5011 INTEGER PYK,PYCHGE,PYCOMP
5012C...Parameter statement to help give large particle numbers.
5013 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5014 &KEXCIT=4000000,KDIMEN=5000000)
5015C...Commonblocks.
5016 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5017 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5018 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5019 COMMON/PYDAT4/CHAF(500,2)
5020 CHARACTER CHAF*16
5021 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5022 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5023 COMMON/PYINT1/MINT(400),VINT(400)
5024 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5025 COMMON/PYINT4/MWID(500),WIDS(500,5)
5026 COMMON/PYINT6/PROC(0:500)
5027 CHARACTER PROC*28
5028 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5029 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5030 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5031C...Local arrays and data.
5032 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5033 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5034
5035C...Born level couplings in MSSM Higgs doublet sector.
5036 XW=PARU(102)
5037 XWV=XW
5038 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5039 XW1=1D0-XW
5040 IF(MSTP(4).EQ.2) THEN
5041 TANBE=PARU(141)
5042 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5043 SQMZ=PMAS(23,1)**2
5044 SQMW=PMAS(24,1)**2
5045 SQMH=PMAS(25,1)**2
5046 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5047 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5048 SQMHC=SQMA+SQMW
5049 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5050 WRITE(MSTU(11),5000)
5051 CALL PYSTOP(101)
5052 ENDIF
5053 PMAS(35,1)=SQRT(SQMHP)
5054 PMAS(36,1)=SQRT(SQMA)
5055 PMAS(37,1)=SQRT(SQMHC)
5056 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5057 & (SQMA-SQMZ)))
5058 BESU=ATAN(TANBE)
5059 PARU(142)=1D0
5060 PARU(143)=1D0
5061 PARU(161)=-SIN(ALSU)/COS(BESU)
5062 PARU(162)=COS(ALSU)/SIN(BESU)
5063 PARU(163)=PARU(161)
5064 PARU(164)=SIN(BESU-ALSU)
5065 PARU(165)=PARU(164)
5066 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5067 PARU(171)=COS(ALSU)/COS(BESU)
5068 PARU(172)=SIN(ALSU)/SIN(BESU)
5069 PARU(173)=PARU(171)
5070 PARU(174)=COS(BESU-ALSU)
5071 PARU(175)=PARU(174)
5072 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5073 & SIN(BESU+ALSU)
5074 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5075 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5076 PARU(181)=TANBE
5077 PARU(182)=1D0/TANBE
5078 PARU(183)=PARU(181)
5079 PARU(184)=0D0
5080 PARU(185)=PARU(184)
5081 PARU(186)=COS(BESU-ALSU)
5082 PARU(187)=SIN(BESU-ALSU)
5083 PARU(188)=PARU(186)
5084 PARU(189)=PARU(187)
5085 PARU(190)=0D0
5086 PARU(195)=COS(BESU-ALSU)
5087 ENDIF
5088
5089C...Reset effective widths of gauge bosons.
5090 DO 110 I=1,500
5091 DO 100 J=1,5
5092 WIDS(I,J)=1D0
5093 100 CONTINUE
5094 110 CONTINUE
5095
5096C...Order resonances by increasing mass (except Z0 and W+/-).
5097 NRES=0
5098 DO 140 KC=1,500
5099 KF=KCHG(KC,4)
5100 IF(KF.EQ.0) GOTO 140
5101 IF(MWID(KC).EQ.0) GOTO 140
5102 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5103 IF(MSTP(1).LE.3) GOTO 140
5104 ENDIF
5105 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5106 IF(IMSS(1).LE.0) GOTO 140
5107 ENDIF
5108 NRES=NRES+1
5109 PMRES=PMAS(KC,1)
5110 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5111 DO 120 I1=NRES-1,1,-1
5112 IF(PMRES.GE.PMORD(I1)) GOTO 130
5113 KCORD(I1+1)=KCORD(I1)
5114 PMORD(I1+1)=PMORD(I1)
5115 120 CONTINUE
5116 130 KCORD(I1+1)=KC
5117 PMORD(I1+1)=PMRES
5118 140 CONTINUE
5119
5120C...Loop over possible resonances.
5121 DO 180 I=1,NRES
5122 KC=KCORD(I)
5123 KF=KCHG(KC,4)
5124
5125C...Check that no fourth generation channels on by mistake.
5126 IF(MSTP(1).LE.3) THEN
5127 DO 150 J=1,MDCY(KC,3)
5128 IDC=J+MDCY(KC,2)-1
5129 KFA1=IABS(KFDP(IDC,1))
5130 KFA2=IABS(KFDP(IDC,2))
5131 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5132 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5133 & MDME(IDC,1)=-1
5134 150 CONTINUE
5135 ENDIF
5136
5137C...Check that no supersymmetric channels on by mistake.
5138 IF(IMSS(1).LE.0) THEN
5139 DO 160 J=1,MDCY(KC,3)
5140 IDC=J+MDCY(KC,2)-1
5141 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5142 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5143 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5144 & MDME(IDC,1)=-1
5145 160 CONTINUE
5146 ENDIF
5147
5148C...Find mass and evaluate width.
5149 PMR=PMAS(KC,1)
5150 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5151 IF(MWID(KC).EQ.3) MINT(63)=1
5152 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5153 MINT(51)=0
5154
5155C...Evaluate suppression factors due to non-simulated channels.
5156 IF(KCHG(KC,3).EQ.0) THEN
5157 WDTP0I=0D0
5158 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5159 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5160 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5161 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5162 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5163 WIDS(KC,3)=0D0
5164 WIDS(KC,4)=0D0
5165 WIDS(KC,5)=0D0
5166 ELSE
5167 IF(MWID(KC).EQ.3) MINT(63)=1
5168 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5169 MINT(51)=0
5170 WDTP0I=0D0
5171 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5172 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5173 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5174 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5175 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5176 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5177 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5178 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5179 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5180 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5181 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5182 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5183 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5184 ENDIF
5185
5186C...Set resonance widths and branching ratios;
5187C...also on/off switch for decays.
5188 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5189 PMAS(KC,2)=WDTP(0)
5190 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5191 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5192 DO 170 J=1,MDCY(KC,3)
5193 IDC=J+MDCY(KC,2)-1
5194 BRAT(IDC)=0D0
5195 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5196 170 CONTINUE
5197 ENDIF
5198 180 CONTINUE
5199
5200C...Flavours of leptoquark: redefine charge and name.
5201 KFLQQ=KFDP(MDCY(42,2),1)
5202 KFLQL=KFDP(MDCY(42,2),2)
5203 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5204 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5205 LL=1
5206 IF(IABS(KFLQL).EQ.13) LL=2
5207 IF(IABS(KFLQL).EQ.15) LL=3
5208 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5209 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5210 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5211
5212C...Special cases in treatment of gamma*/Z0: redefine process name.
5213 IF(MSTP(43).EQ.1) THEN
5214 PROC(1)='f + fbar -> gamma*'
5215 PROC(15)='f + fbar -> g + gamma*'
5216 PROC(19)='f + fbar -> gamma + gamma*'
5217 PROC(30)='f + g -> f + gamma*'
5218 PROC(35)='f + gamma -> f + gamma*'
5219 ELSEIF(MSTP(43).EQ.2) THEN
5220 PROC(1)='f + fbar -> Z0'
5221 PROC(15)='f + fbar -> g + Z0'
5222 PROC(19)='f + fbar -> gamma + Z0'
5223 PROC(30)='f + g -> f + Z0'
5224 PROC(35)='f + gamma -> f + Z0'
5225 ELSEIF(MSTP(43).EQ.3) THEN
5226 PROC(1)='f + fbar -> gamma*/Z0'
5227 PROC(15)='f + fbar -> g + gamma*/Z0'
5228 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5229 PROC(30)='f + g -> f + gamma*/Z0'
5230 PROC(35)='f + gamma -> f + gamma*/Z0'
5231 ENDIF
5232
5233C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5234 IF(MSTP(44).EQ.1) THEN
5235 PROC(141)='f + fbar -> gamma*'
5236 ELSEIF(MSTP(44).EQ.2) THEN
5237 PROC(141)='f + fbar -> Z0'
5238 ELSEIF(MSTP(44).EQ.3) THEN
5239 PROC(141)='f + fbar -> Z''0'
5240 ELSEIF(MSTP(44).EQ.4) THEN
5241 PROC(141)='f + fbar -> gamma*/Z0'
5242 ELSEIF(MSTP(44).EQ.5) THEN
5243 PROC(141)='f + fbar -> gamma*/Z''0'
5244 ELSEIF(MSTP(44).EQ.6) THEN
5245 PROC(141)='f + fbar -> Z0/Z''0'
5246 ELSEIF(MSTP(44).EQ.7) THEN
5247 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5248 ENDIF
5249
5250C...Special cases in treatment of WW -> WW: redefine process name.
5251 IF(MSTP(45).EQ.1) THEN
5252 PROC(77)='W+ + W+ -> W+ + W+'
5253 ELSEIF(MSTP(45).EQ.2) THEN
5254 PROC(77)='W+ + W- -> W+ + W-'
5255 ELSEIF(MSTP(45).EQ.3) THEN
5256 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5257 ENDIF
5258
5259C...Format for error information.
5260 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5261 &'combination'/1X,'Execution stopped!')
5262
5263 RETURN
5264 END
5265
5266C*********************************************************************
5267
5268C...PYINBM
5269C...Identifies the two incoming particles and the choice of frame.
5270
5271 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5272
5273C...Double precision and integer declarations.
5274 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5275 IMPLICIT INTEGER(I-N)
5276 INTEGER PYK,PYCHGE,PYCOMP
5277
5278C...User process initialization commonblock.
5279 INTEGER MAXPUP
5280 PARAMETER (MAXPUP=100)
5281 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5282 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5283 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5284 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5285 &LPRUP(MAXPUP)
5286 SAVE /HEPRUP/
5287
5288C...Commonblocks.
5289 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5290 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5291 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5292 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5293 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5294 COMMON/PYINT1/MINT(400),VINT(400)
5295 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5296
5297C...Local arrays, character variables and data.
5298 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5299 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5300 DIMENSION LEN(3),KCDE(39),PM(2)
5301 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5302 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5303 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5304 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5305 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5306 &'nu_taubar ','pi+ ','pi- ','n0 ',
5307 &'nbar0 ','p+ ','pbar- ','gamma ',
5308 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5309 &'xi- ','xi0 ','omega- ','pi0 ',
5310 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5311 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5312 &'k+ ','k- ','ks0 ','kl0 '/
5313 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5314 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5315 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5316
5317C...Store initial energy. Default frame.
5318 VINT(290)=WIN
5319 MINT(111)=0
5320
5321C...Special user process initialization; convert to normal input.
5322 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5323 MINT(111)=11
5324 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5325 CALL PYNAME(IDBMUP(1),CHNAME)
5326 CHBEAM=CHNAME(1:12)
5327 CALL PYNAME(IDBMUP(2),CHNAME)
5328 CHTARG=CHNAME(1:12)
5329 ENDIF
5330
5331C...Convert character variables to lowercase and find their length.
5332 CHCOM(1)=CHFRAM
5333 CHCOM(2)=CHBEAM
5334 CHCOM(3)=CHTARG
5335 DO 130 I=1,3
5336 LEN(I)=12
5337 DO 110 LL=12,1,-1
5338 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5339 DO 100 LA=1,26
5340 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5341 & CHALP(1)(LA:LA)
5342 100 CONTINUE
5343 110 CONTINUE
5344 CHIDNT(I)=CHCOM(I)
5345
5346C...Fix up bar, underscore and charge in particle name (if needed).
5347 DO 120 LL=1,10
5348 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5349 CHTEMP=CHIDNT(I)
5350 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5351 ENDIF
5352 120 CONTINUE
5353 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5354 CHTEMP=CHIDNT(I)
5355 CHIDNT(I)='nu_'//CHTEMP(3:7)
5356 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5357 CHIDNT(I)(1:3)='n0 '
5358 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5359 CHIDNT(I)(1:5)='nbar0'
5360 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5361 CHIDNT(I)(1:3)='p+ '
5362 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5363 & CHIDNT(I)(1:2).EQ.'p-') THEN
5364 CHIDNT(I)(1:5)='pbar-'
5365 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5366 CHIDNT(I)(7:7)='0'
5367 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5368 CHIDNT(I)(1:7)='reggeon'
5369 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5370 CHIDNT(I)(1:7)='pomeron'
5371 ENDIF
5372 130 CONTINUE
5373
5374C...Identify free initialization.
5375 IF(CHCOM(1)(1:2).EQ.'no') THEN
5376 MINT(65)=1
5377 RETURN
5378 ENDIF
5379
5380C...Identify incoming beam and target particles.
5381 DO 160 I=1,2
5382 DO 140 J=1,39
5383 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5384 140 CONTINUE
5385 PM(I)=PYMASS(MINT(10+I))
5386 VINT(2+I)=PM(I)
5387 MINT(140+I)=0
5388 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5389 CHTEMP=CHIDNT(I+1)(7:12)//' '
5390 DO 150 J=1,12
5391 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5392 150 CONTINUE
5393 PM(I)=PYMASS(MINT(140+I))
5394 VINT(302+I)=PM(I)
5395 ENDIF
5396 160 CONTINUE
5397 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5398 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5399 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5400
5401C...Identify choice of frame and input energies.
5402 CHINIT=' '
5403
5404C...Events defined in the CM frame.
5405 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5406 MINT(111)=1
5407 S=WIN**2
5408 IF(MSTP(122).GE.1) THEN
5409 IF(CHCOM(2)(1:1).NE.'e') THEN
5410 LOFFS=(31-(LEN(2)+LEN(3)))/2
5411 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5412 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5413 & ' collider'//' '
5414 ELSE
5415 LOFFS=(30-(LEN(2)+LEN(3)))/2
5416 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5417 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5418 & ' collider'//' '
5419 ENDIF
5420 WRITE(MSTU(11),5200) CHINIT
5421 WRITE(MSTU(11),5300) WIN
5422 ENDIF
5423
5424C...Events defined in fixed target frame.
5425 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5426 MINT(111)=2
5427 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5428 IF(MSTP(122).GE.1) THEN
5429 LOFFS=(29-(LEN(2)+LEN(3)))/2
5430 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5431 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5432 & ' fixed target'//' '
5433 WRITE(MSTU(11),5200) CHINIT
5434 WRITE(MSTU(11),5400) WIN
5435 WRITE(MSTU(11),5500) SQRT(S)
5436 ENDIF
5437
5438C...Frame defined by user three-vectors.
5439 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5440 MINT(111)=3
5441 P(1,5)=PM(1)
5442 P(2,5)=PM(2)
5443 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5444 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5445 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5446 & (P(1,3)+P(2,3))**2
5447 IF(MSTP(122).GE.1) THEN
5448 LOFFS=(22-(LEN(2)+LEN(3)))/2
5449 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5450 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5451 & ' user configuration'//' '
5452 WRITE(MSTU(11),5200) CHINIT
5453 WRITE(MSTU(11),5600)
5454 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5455 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5456 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5457 ENDIF
5458
5459C...Frame defined by user four-vectors.
5460 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5461 MINT(111)=4
5462 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5463 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5464 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5465 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5466 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5467 & (P(1,3)+P(2,3))**2
5468 IF(MSTP(122).GE.1) THEN
5469 LOFFS=(22-(LEN(2)+LEN(3)))/2
5470 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5471 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5472 & ' user configuration'//' '
5473 WRITE(MSTU(11),5200) CHINIT
5474 WRITE(MSTU(11),5600)
5475 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5476 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5477 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5478 ENDIF
5479
5480C...Frame defined by user five-vectors.
5481 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5482 MINT(111)=5
5483 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5484 & (P(1,3)+P(2,3))**2
5485 IF(MSTP(122).GE.1) THEN
5486 LOFFS=(22-(LEN(2)+LEN(3)))/2
5487 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5488 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5489 & ' user configuration'//' '
5490 WRITE(MSTU(11),5200) CHINIT
5491 WRITE(MSTU(11),5600)
5492 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5493 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5494 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5495 ENDIF
5496
5497C...Frame defined by HEPRUP common block.
5498 ELSEIF(MINT(111).GE.11) THEN
5499 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5500 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5501 IF(MSTP(122).GE.1) THEN
5502 LOFFS=(22-(LEN(2)+LEN(3)))/2
5503 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5504 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5505 & ' user configuration'//' '
5506 WRITE(MSTU(11),5200) CHINIT
5507 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5508 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5509 ENDIF
5510
5511C...Unknown frame. Error for too low CM energy.
5512 ELSE
5513 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5514 CALL PYSTOP(7)
5515 ENDIF
5516 IF(S.LT.PARP(2)**2) THEN
5517 WRITE(MSTU(11),5900) SQRT(S)
5518 CALL PYSTOP(7)
5519 ENDIF
5520
5521C...Formats for initialization and error information.
5522 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5523 &1X,'Execution stopped!')
5524 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5525 &1X,'Execution stopped!')
5526 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5527 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5528 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5529 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5530 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5531 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5532 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5533 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5534 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5535 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5536 &1X,'Execution stopped!')
5537 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5538 &'generation.'/1X,'Execution stopped!')
5539 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5540 &'GeV beam energies',13X,'I')
5541
5542 RETURN
5543 END
5544
5545C*********************************************************************
5546
5547C...PYINKI
5548C...Sets up kinematics, including rotations and boosts to/from CM frame.
5549
5550 SUBROUTINE PYINKI(MODKI)
5551
5552C...Double precision and integer declarations.
5553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5554 IMPLICIT INTEGER(I-N)
5555 INTEGER PYK,PYCHGE,PYCOMP
5556
5557C...User process initialization commonblock.
5558 INTEGER MAXPUP
5559 PARAMETER (MAXPUP=100)
5560 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5561 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5562 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5563 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5564 &LPRUP(MAXPUP)
5565 SAVE /HEPRUP/
5566
5567C...Commonblocks.
5568 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5570 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5571 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5572 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5573 COMMON/PYINT1/MINT(400),VINT(400)
5574 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5575
5576C...Set initial flavour state.
5577 N=2
5578 DO 100 I=1,2
5579 K(I,1)=1
5580 K(I,2)=MINT(10+I)
5581 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5582 100 CONTINUE
5583
5584C...Reset boost. Do kinematics for various cases.
5585 DO 110 J=6,10
5586 VINT(J)=0D0
5587 110 CONTINUE
5588
5589C...Set up kinematics for events defined in CM frame.
5590 IF(MINT(111).EQ.1) THEN
5591 WIN=VINT(290)
5592 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5593 S=WIN**2
5594 P(1,5)=VINT(3)
5595 P(2,5)=VINT(4)
5596 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5597 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5598 P(1,1)=0D0
5599 P(1,2)=0D0
5600 P(2,1)=0D0
5601 P(2,2)=0D0
5602 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5603 & (4D0*S))
5604 P(2,3)=-P(1,3)
5605 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5606 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5607
5608C...Set up kinematics for fixed target events.
5609 ELSEIF(MINT(111).EQ.2) THEN
5610 WIN=VINT(290)
5611 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5612 P(1,5)=VINT(3)
5613 P(2,5)=VINT(4)
5614 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5615 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5616 P(1,1)=0D0
5617 P(1,2)=0D0
5618 P(2,1)=0D0
5619 P(2,2)=0D0
5620 P(1,3)=WIN
5621 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5622 P(2,3)=0D0
5623 P(2,4)=P(2,5)
5624 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5625 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5626 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5627
5628C...Set up kinematics for events in user-defined frame.
5629 ELSEIF(MINT(111).EQ.3) THEN
5630 P(1,5)=VINT(3)
5631 P(2,5)=VINT(4)
5632 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5633 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5634 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5635 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5636 DO 120 J=1,3
5637 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5638 120 CONTINUE
5639 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5640 VINT(7)=PYANGL(P(1,1),P(1,2))
5641 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5642 VINT(6)=PYANGL(P(1,3),P(1,1))
5643 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5644 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5645
5646C...Set up kinematics for events with user-defined four-vectors.
5647 ELSEIF(MINT(111).EQ.4) THEN
5648 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5649 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5650 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5651 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5652 DO 130 J=1,3
5653 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5654 130 CONTINUE
5655 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5656 VINT(7)=PYANGL(P(1,1),P(1,2))
5657 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5658 VINT(6)=PYANGL(P(1,3),P(1,1))
5659 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5660 S=(P(1,4)+P(2,4))**2
5661
5662C...Set up kinematics for events with user-defined five-vectors.
5663 ELSEIF(MINT(111).EQ.5) THEN
5664 DO 140 J=1,3
5665 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5666 140 CONTINUE
5667 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5668 VINT(7)=PYANGL(P(1,1),P(1,2))
5669 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5670 VINT(6)=PYANGL(P(1,3),P(1,1))
5671 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5672 S=(P(1,4)+P(2,4))**2
5673
5674C...Set up kinematics for events with external user processes.
5675 ELSEIF(MINT(111).GE.11) THEN
5676 P(1,5)=VINT(3)
5677 P(2,5)=VINT(4)
5678 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5679 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5680 P(1,1)=0D0
5681 P(1,2)=0D0
5682 P(2,1)=0D0
5683 P(2,2)=0D0
5684 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5685 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5686 P(1,4)=EBMUP(1)
5687 P(2,4)=EBMUP(2)
5688 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5689 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5690 S=(P(1,4)+P(2,4))**2
5691 ENDIF
5692
5693C...Return or error for too low CM energy.
5694 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5695 IF(MSTP(172).LE.1) THEN
5696 CALL PYERRM(23,
5697 & '(PYINKI:) too low invariant mass in this event')
5698 ELSE
5699 MSTI(61)=1
5700 RETURN
5701 ENDIF
5702 ENDIF
5703
5704C...Save information on incoming particles.
5705 VINT(1)=SQRT(S)
5706 VINT(2)=S
5707 IF(MINT(111).GE.4) THEN
5708 IF(MINT(141).EQ.0) THEN
5709 VINT(3)=P(1,5)
5710 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5711 ELSE
5712 VINT(303)=P(1,5)
5713 ENDIF
5714 IF(MINT(142).EQ.0) THEN
5715 VINT(4)=P(2,5)
5716 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5717 ELSE
5718 VINT(304)=P(2,5)
5719 ENDIF
5720 ENDIF
5721 VINT(5)=P(1,3)
5722 IF(MODKI.EQ.0) VINT(289)=S
5723 DO 150 J=1,5
5724 V(1,J)=0D0
5725 V(2,J)=0D0
5726 VINT(290+J)=P(1,J)
5727 VINT(295+J)=P(2,J)
5728 150 CONTINUE
5729
5730C...Store pT cut-off and related constants to be used in generation.
5731 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5732 IF(MSTP(82).LE.1) THEN
5733 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5734 ELSE
5735 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5736 ENDIF
5737 VINT(149)=4D0*PTMN**2/S
5738 VINT(154)=PTMN
5739
5740 RETURN
5741 END
5742
5743C*********************************************************************
5744
5745C...PYINPR
5746C...Selects partonic subprocesses to be included in the simulation.
5747
5748 SUBROUTINE PYINPR
5749
5750C...Double precision and integer declarations.
5751 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5752 IMPLICIT INTEGER(I-N)
5753 INTEGER PYK,PYCHGE,PYCOMP
5754
5755C...User process initialization commonblock.
5756 INTEGER MAXPUP
5757 PARAMETER (MAXPUP=100)
5758 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5759 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5760 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5761 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5762 &LPRUP(MAXPUP)
5763 SAVE /HEPRUP/
5764
5765C...Commonblocks and character variables.
5766 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5767 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5768 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5769 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5770 COMMON/PYINT1/MINT(400),VINT(400)
5771 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5772 COMMON/PYINT6/PROC(0:500)
5773 CHARACTER PROC*28
5774 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5775 &/PYINT6/
5776 CHARACTER CHIPR*10
5777
5778C...Reset processes to be included.
5779 IF(MSEL.NE.0) THEN
5780 DO 100 I=1,500
5781 MSUB(I)=0
5782 100 CONTINUE
5783 ENDIF
5784
5785C...Set running pTmin scale.
5786 IF(MSTP(82).LE.1) THEN
5787 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5788 ELSE
5789 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5790 ENDIF
5791
5792C...Begin by assuming incoming photon to enter subprocess.
5793 IF(MINT(11).EQ.22) MINT(15)=22
5794 IF(MINT(12).EQ.22) MINT(16)=22
5795
5796C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5797 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5798 MSUB(10)=1
5799 MINT(123)=MINT(122)+1
5800
5801C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5802C...allow mixture.
5803C...Here also set a few parameters otherwise normally not touched.
5804 ELSEIF(MINT(121).GT.1) THEN
5805
5806C...Parton distributions dampened at small Q2; go to low energies,
5807C...alpha_s <1; no minimum pT cut-off a priori.
5808 IF(MSTP(18).EQ.2) THEN
5809 MSTP(57)=3
5810 PARP(2)=2D0
5811 PARU(115)=1D0
5812 CKIN(5)=0.2D0
5813 CKIN(6)=0.2D0
5814 ENDIF
5815
5816C...Define pT cut-off parameters and whether run involves low-pT.
5817 PTMVMD=PTMRUN
5818 VINT(154)=PTMVMD
5819 PTMDIR=PTMVMD
5820 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
5821 PTMANO=PTMVMD
5822 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
5823 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
5824 IPTL=1
5825 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
5826 IF(MSEL.EQ.2) IPTL=1
5827
5828C...Set up for p/gamma * gamma; real or virtual photons.
5829 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
5830 & MSTP(14).EQ.30)) THEN
5831
5832C...Set up for p/VMD * VMD.
5833 IF(MINT(122).EQ.1) THEN
5834 MINT(123)=2
5835 MSUB(11)=1
5836 MSUB(12)=1
5837 MSUB(13)=1
5838 MSUB(28)=1
5839 MSUB(53)=1
5840 MSUB(68)=1
5841 IF(IPTL.EQ.1) MSUB(95)=1
5842 IF(MSEL.EQ.2) THEN
5843 MSUB(91)=1
5844 MSUB(92)=1
5845 MSUB(93)=1
5846 MSUB(94)=1
5847 ENDIF
5848 IF(IPTL.EQ.1) CKIN(3)=0D0
5849
5850C...Set up for p/VMD * direct gamma.
5851 ELSEIF(MINT(122).EQ.2) THEN
5852 MINT(123)=0
5853 IF(MINT(121).EQ.6) MINT(123)=5
5854 MSUB(131)=1
5855 MSUB(132)=1
5856 MSUB(135)=1
5857 MSUB(136)=1
5858 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5859
5860C...Set up for p/VMD * anomalous gamma.
5861 ELSEIF(MINT(122).EQ.3) THEN
5862 MINT(123)=3
5863 IF(MINT(121).EQ.6) MINT(123)=7
5864 MSUB(11)=1
5865 MSUB(12)=1
5866 MSUB(13)=1
5867 MSUB(28)=1
5868 MSUB(53)=1
5869 MSUB(68)=1
5870 IF(IPTL.EQ.1) MSUB(95)=1
5871 IF(MSEL.EQ.2) THEN
5872 MSUB(91)=1
5873 MSUB(92)=1
5874 MSUB(93)=1
5875 MSUB(94)=1
5876 ENDIF
5877 IF(IPTL.EQ.1) CKIN(3)=0D0
5878
5879C...Set up for DIS * p.
5880 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
5881 & IABS(MINT(12)).GT.100)) THEN
5882 MINT(123)=8
5883 IF(IPTL.EQ.1) MSUB(99)=1
5884
5885C...Set up for direct * direct gamma (switch off leptons).
5886 ELSEIF(MINT(122).EQ.4) THEN
5887 MINT(123)=0
5888 MSUB(137)=1
5889 MSUB(138)=1
5890 MSUB(139)=1
5891 MSUB(140)=1
5892 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5893 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5894 110 CONTINUE
5895 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5896
5897C...Set up for direct * anomalous gamma.
5898 ELSEIF(MINT(122).EQ.5) THEN
5899 MINT(123)=6
5900 MSUB(131)=1
5901 MSUB(132)=1
5902 MSUB(135)=1
5903 MSUB(136)=1
5904 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5905
5906C...Set up for anomalous * anomalous gamma.
5907 ELSEIF(MINT(122).EQ.6) THEN
5908 MINT(123)=3
5909 MSUB(11)=1
5910 MSUB(12)=1
5911 MSUB(13)=1
5912 MSUB(28)=1
5913 MSUB(53)=1
5914 MSUB(68)=1
5915 IF(IPTL.EQ.1) MSUB(95)=1
5916 IF(MSEL.EQ.2) THEN
5917 MSUB(91)=1
5918 MSUB(92)=1
5919 MSUB(93)=1
5920 MSUB(94)=1
5921 ENDIF
5922 IF(IPTL.EQ.1) CKIN(3)=0D0
5923 ENDIF
5924
5925C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
5926 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
5927
5928C...Set up for direct * direct gamma (switch off leptons).
5929 IF(MINT(122).EQ.1) THEN
5930 MINT(123)=0
5931 MSUB(137)=1
5932 MSUB(138)=1
5933 MSUB(139)=1
5934 MSUB(140)=1
5935 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
5936 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
5937 120 CONTINUE
5938 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5939
5940C...Set up for direct * VMD and VMD * direct gamma.
5941 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
5942 MINT(123)=5
5943 MSUB(131)=1
5944 MSUB(132)=1
5945 MSUB(135)=1
5946 MSUB(136)=1
5947 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
5948
5949C...Set up for direct * anomalous and anomalous * direct gamma.
5950 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
5951 MINT(123)=6
5952 MSUB(131)=1
5953 MSUB(132)=1
5954 MSUB(135)=1
5955 MSUB(136)=1
5956 IF(IPTL.EQ.1) CKIN(3)=PTMANO
5957
5958C...Set up for VMD*VMD.
5959 ELSEIF(MINT(122).EQ.5) THEN
5960 MINT(123)=2
5961 MSUB(11)=1
5962 MSUB(12)=1
5963 MSUB(13)=1
5964 MSUB(28)=1
5965 MSUB(53)=1
5966 MSUB(68)=1
5967 IF(IPTL.EQ.1) MSUB(95)=1
5968 IF(MSEL.EQ.2) THEN
5969 MSUB(91)=1
5970 MSUB(92)=1
5971 MSUB(93)=1
5972 MSUB(94)=1
5973 ENDIF
5974 IF(IPTL.EQ.1) CKIN(3)=0D0
5975
5976C...Set up for VMD * anomalous and anomalous * VMD gamma.
5977 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
5978 MINT(123)=7
5979 MSUB(11)=1
5980 MSUB(12)=1
5981 MSUB(13)=1
5982 MSUB(28)=1
5983 MSUB(53)=1
5984 MSUB(68)=1
5985 IF(IPTL.EQ.1) MSUB(95)=1
5986 IF(MSEL.EQ.2) THEN
5987 MSUB(91)=1
5988 MSUB(92)=1
5989 MSUB(93)=1
5990 MSUB(94)=1
5991 ENDIF
5992 IF(IPTL.EQ.1) CKIN(3)=0D0
5993
5994C...Set up for anomalous * anomalous gamma.
5995 ELSEIF(MINT(122).EQ.9) THEN
5996 MINT(123)=3
5997 MSUB(11)=1
5998 MSUB(12)=1
5999 MSUB(13)=1
6000 MSUB(28)=1
6001 MSUB(53)=1
6002 MSUB(68)=1
6003 IF(IPTL.EQ.1) MSUB(95)=1
6004 IF(MSEL.EQ.2) THEN
6005 MSUB(91)=1
6006 MSUB(92)=1
6007 MSUB(93)=1
6008 MSUB(94)=1
6009 ENDIF
6010 IF(IPTL.EQ.1) CKIN(3)=0D0
6011
6012C...Set up for DIS * VMD and VMD * DIS gamma.
6013 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6014 MINT(123)=8
6015 IF(IPTL.EQ.1) MSUB(99)=1
6016
6017C...Set up for DIS * anomalous and anomalous * DIS gamma.
6018 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6019 MINT(123)=9
6020 IF(IPTL.EQ.1) MSUB(99)=1
6021 ENDIF
6022
6023C...Set up for gamma* * p; virtual photons = dir, res.
6024 ELSEIF(MINT(121).EQ.2) THEN
6025
6026C...Set up for direct * p.
6027 IF(MINT(122).EQ.1) THEN
6028 MINT(123)=0
6029 MSUB(131)=1
6030 MSUB(132)=1
6031 MSUB(135)=1
6032 MSUB(136)=1
6033 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6034
6035C...Set up for resolved * p.
6036 ELSEIF(MINT(122).EQ.2) THEN
6037 MINT(123)=1
6038 MSUB(11)=1
6039 MSUB(12)=1
6040 MSUB(13)=1
6041 MSUB(28)=1
6042 MSUB(53)=1
6043 MSUB(68)=1
6044 IF(IPTL.EQ.1) MSUB(95)=1
6045 IF(MSEL.EQ.2) THEN
6046 MSUB(91)=1
6047 MSUB(92)=1
6048 MSUB(93)=1
6049 MSUB(94)=1
6050 ENDIF
6051 IF(IPTL.EQ.1) CKIN(3)=0D0
6052 ENDIF
6053
6054C...Set up for gamma* * gamma*; virtual photons = dir, res.
6055 ELSEIF(MINT(121).EQ.4) THEN
6056
6057C...Set up for direct * direct gamma (switch off leptons).
6058 IF(MINT(122).EQ.1) THEN
6059 MINT(123)=0
6060 MSUB(137)=1
6061 MSUB(138)=1
6062 MSUB(139)=1
6063 MSUB(140)=1
6064 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6065 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6066 130 CONTINUE
6067 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6068
6069C...Set up for direct * resolved and resolved * direct gamma.
6070 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6071 MINT(123)=5
6072 MSUB(131)=1
6073 MSUB(132)=1
6074 MSUB(135)=1
6075 MSUB(136)=1
6076 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6077
6078C...Set up for resolved * resolved gamma.
6079 ELSEIF(MINT(122).EQ.4) THEN
6080 MINT(123)=2
6081 MSUB(11)=1
6082 MSUB(12)=1
6083 MSUB(13)=1
6084 MSUB(28)=1
6085 MSUB(53)=1
6086 MSUB(68)=1
6087 IF(IPTL.EQ.1) MSUB(95)=1
6088 IF(MSEL.EQ.2) THEN
6089 MSUB(91)=1
6090 MSUB(92)=1
6091 MSUB(93)=1
6092 MSUB(94)=1
6093 ENDIF
6094 IF(IPTL.EQ.1) CKIN(3)=0D0
6095 ENDIF
6096
6097C...End of special set up for gamma-p and gamma-gamma.
6098 ENDIF
6099 CKIN(1)=2D0*CKIN(3)
6100 ENDIF
6101
6102C...Flavour information for individual beams.
6103 DO 140 I=1,2
6104 MINT(40+I)=1
6105 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6106 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6107 MINT(44+I)=MINT(40+I)
6108 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6109 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6110 140 CONTINUE
6111
6112C...If two real gammas, whereof one direct, pick the first.
6113C...For two virtual photons, keep requested order.
6114 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6115 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6116 MINT(41)=1
6117 MINT(45)=1
6118 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6119 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6120 MINT(41)=1
6121 MINT(45)=1
6122 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6123 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6124 MINT(42)=1
6125 MINT(46)=1
6126 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6127 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6128 MINT(41)=1
6129 MINT(45)=1
6130 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6131 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6132 MINT(42)=1
6133 MINT(46)=1
6134 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6135 MINT(41)=1
6136 MINT(45)=1
6137 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6138 MINT(42)=1
6139 MINT(46)=1
6140 ENDIF
6141 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6142 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6143 IF(MINT(11).EQ.22) THEN
6144 MINT(41)=1
6145 MINT(45)=1
6146 ELSE
6147 MINT(42)=1
6148 MINT(46)=1
6149 ENDIF
6150 ENDIF
6151 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6152 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6153 ENDIF
6154
6155C...Flavour information on combination of incoming particles.
6156 MINT(43)=2*MINT(41)+MINT(42)-2
6157 MINT(44)=MINT(43)
6158 IF(MINT(123).LE.0) THEN
6159 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6160 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6161 ELSEIF(MINT(123).LE.3) THEN
6162 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6163 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6164 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6165 MINT(43)=4
6166 MINT(44)=1
6167 ENDIF
6168 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6169 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6170 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6171 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6172 MINT(50)=0
6173 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6174 MINT(107)=0
6175 MINT(108)=0
6176 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6177 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6178 & MINT(107)=2
6179 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6180 & MINT(107)=3
6181 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6182 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6183 & MINT(122).EQ.10) MINT(108)=2
6184 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6185 & MINT(122).EQ.11) MINT(108)=3
6186 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6187 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6188 IF(MINT(122).GE.3) MINT(107)=1
6189 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6190 ELSEIF(MINT(121).EQ.2) THEN
6191 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6192 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6193 ELSE
6194 IF(MINT(11).EQ.22) THEN
6195 MINT(107)=MINT(123)
6196 IF(MINT(123).GE.4) MINT(107)=0
6197 IF(MINT(123).EQ.7) MINT(107)=2
6198 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6199 IF(MSTP(14).EQ.28) MINT(107)=2
6200 IF(MSTP(14).EQ.29) MINT(107)=3
6201 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6202 & MINT(107)=4
6203 ENDIF
6204 IF(MINT(12).EQ.22) THEN
6205 MINT(108)=MINT(123)
6206 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6207 IF(MINT(123).EQ.7) MINT(108)=3
6208 IF(MSTP(14).EQ.26) MINT(108)=2
6209 IF(MSTP(14).EQ.27) MINT(108)=3
6210 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6211 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6212 & MINT(108)=4
6213 ENDIF
6214 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6215 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6216 MINTTP=MINT(107)
6217 MINT(107)=MINT(108)
6218 MINT(108)=MINTTP
6219 ENDIF
6220 ENDIF
6221 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6222 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6223
6224C...Select default processes according to incoming beams
6225C...(already done for gamma-p and gamma-gamma with
6226C...MSTP(14) = 10, 20, 25 or 30).
6227 IF(MINT(121).GT.1) THEN
6228 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6229
6230 IF(MINT(43).EQ.1) THEN
6231C...Lepton + lepton -> gamma/Z0 or W.
6232 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6233 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6234
6235 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6236 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6237C...Unresolved photon + lepton: Compton scattering.
6238 MSUB(133)=1
6239 MSUB(134)=1
6240
6241 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6242 & .OR.MINT(12).EQ.22)) THEN
6243C...DIS as pure gamma* + f -> f process.
6244 MSUB(99)=1
6245
6246 ELSEIF(MINT(43).LE.3) THEN
6247C...Lepton + hadron: deep inelastic scattering.
6248 MSUB(10)=1
6249
6250 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6251 & MINT(12).EQ.22) THEN
6252C...Two unresolved photons: fermion pair production,
6253C...exclude lepton pairs.
6254 DO 150 ISUB=137,140
6255 MSUB(ISUB)=1
6256 150 CONTINUE
6257 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6258 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6259 160 CONTINUE
6260 PTMDIR=PTMRUN
6261 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6262 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6263 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6264
6265 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6266 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6267 & MINT(12).EQ.22)) THEN
6268C...Unresolved photon + hadron: photon-parton scattering.
6269 DO 170 ISUB=131,136
6270 MSUB(ISUB)=1
6271 170 CONTINUE
6272
6273 ELSEIF(MSEL.EQ.1) THEN
6274C...High-pT QCD processes:
6275 MSUB(11)=1
6276 MSUB(12)=1
6277 MSUB(13)=1
6278 MSUB(28)=1
6279 MSUB(53)=1
6280 MSUB(68)=1
6281 PTMN=PTMRUN
6282 VINT(154)=PTMN
6283 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6284 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6285
6286 ELSE
6287C...All QCD processes:
6288 MSUB(11)=1
6289 MSUB(12)=1
6290 MSUB(13)=1
6291 MSUB(28)=1
6292 MSUB(53)=1
6293 MSUB(68)=1
6294 MSUB(91)=1
6295 MSUB(92)=1
6296 MSUB(93)=1
6297 MSUB(94)=1
6298 MSUB(95)=1
6299 ENDIF
6300
6301 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6302C...Heavy quark production.
6303 MSUB(81)=1
6304 MSUB(82)=1
6305 MSUB(84)=1
6306 DO 180 J=1,MIN(8,MDCY(21,3))
6307 MDME(MDCY(21,2)+J-1,1)=0
6308 180 CONTINUE
6309 MDME(MDCY(21,2)+MSEL-1,1)=1
6310 MSUB(85)=1
6311 DO 190 J=1,MIN(12,MDCY(22,3))
6312 MDME(MDCY(22,2)+J-1,1)=0
6313 190 CONTINUE
6314 MDME(MDCY(22,2)+MSEL-1,1)=1
6315
6316 ELSEIF(MSEL.EQ.10) THEN
6317C...Prompt photon production:
6318 MSUB(14)=1
6319 MSUB(18)=1
6320 MSUB(29)=1
6321
6322 ELSEIF(MSEL.EQ.11) THEN
6323C...Z0/gamma* production:
6324 MSUB(1)=1
6325
6326 ELSEIF(MSEL.EQ.12) THEN
6327C...W+/- production:
6328 MSUB(2)=1
6329
6330 ELSEIF(MSEL.EQ.13) THEN
6331C...Z0 + jet:
6332 MSUB(15)=1
6333 MSUB(30)=1
6334
6335 ELSEIF(MSEL.EQ.14) THEN
6336C...W+/- + jet:
6337 MSUB(16)=1
6338 MSUB(31)=1
6339
6340 ELSEIF(MSEL.EQ.15) THEN
6341C...Z0 & W+/- pair production:
6342 MSUB(19)=1
6343 MSUB(20)=1
6344 MSUB(22)=1
6345 MSUB(23)=1
6346 MSUB(25)=1
6347
6348 ELSEIF(MSEL.EQ.16) THEN
6349C...h0 production:
6350 MSUB(3)=1
6351 MSUB(102)=1
6352 MSUB(103)=1
6353 MSUB(123)=1
6354 MSUB(124)=1
6355
6356 ELSEIF(MSEL.EQ.17) THEN
6357C...h0 & Z0 or W+/- pair production:
6358 MSUB(24)=1
6359 MSUB(26)=1
6360
6361 ELSEIF(MSEL.EQ.18) THEN
6362C...h0 production; interesting processes in e+e-.
6363 MSUB(24)=1
6364 MSUB(103)=1
6365 MSUB(123)=1
6366 MSUB(124)=1
6367
6368 ELSEIF(MSEL.EQ.19) THEN
6369C...h0, H0 and A0 production; interesting processes in e+e-.
6370 MSUB(24)=1
6371 MSUB(103)=1
6372 MSUB(123)=1
6373 MSUB(124)=1
6374 MSUB(153)=1
6375 MSUB(171)=1
6376 MSUB(173)=1
6377 MSUB(174)=1
6378 MSUB(158)=1
6379 MSUB(176)=1
6380 MSUB(178)=1
6381 MSUB(179)=1
6382
6383 ELSEIF(MSEL.EQ.21) THEN
6384C...Z'0 production:
6385 MSUB(141)=1
6386
6387 ELSEIF(MSEL.EQ.22) THEN
6388C...W'+/- production:
6389 MSUB(142)=1
6390
6391 ELSEIF(MSEL.EQ.23) THEN
6392C...H+/- production:
6393 MSUB(143)=1
6394
6395 ELSEIF(MSEL.EQ.24) THEN
6396C...R production:
6397 MSUB(144)=1
6398
6399 ELSEIF(MSEL.EQ.25) THEN
6400C...LQ (leptoquark) production.
6401 MSUB(145)=1
6402 MSUB(162)=1
6403 MSUB(163)=1
6404 MSUB(164)=1
6405
6406 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6407C...Production of one heavy quark (W exchange):
6408 MSUB(83)=1
6409 DO 200 J=1,MIN(8,MDCY(21,3))
6410 MDME(MDCY(21,2)+J-1,1)=0
6411 200 CONTINUE
6412 MDME(MDCY(21,2)+MSEL-31,1)=1
6413
6414CMRENNA++Define SUSY alternatives.
6415 ELSEIF(MSEL.EQ.39) THEN
6416C...Turn on all SUSY processes.
6417 IF(MINT(43).EQ.4) THEN
6418C...Hadron-hadron processes.
6419 DO 210 I=201,301
6420 IF(ISET(I).GE.0) MSUB(I)=1
6421 210 CONTINUE
6422 ELSEIF(MINT(43).EQ.1) THEN
6423C...Lepton-lepton processes: QED production of squarks.
6424 DO 220 I=201,214
6425 MSUB(I)=1
6426 220 CONTINUE
6427 MSUB(210)=0
6428 MSUB(211)=0
6429 MSUB(212)=0
6430 DO 230 I=216,228
6431 MSUB(I)=1
6432 230 CONTINUE
6433 DO 240 I=261,263
6434 MSUB(I)=1
6435 240 CONTINUE
6436 MSUB(277)=1
6437 MSUB(278)=1
6438 ENDIF
6439
6440 ELSEIF(MSEL.EQ.40) THEN
6441C...Gluinos and squarks.
6442 IF(MINT(43).EQ.4) THEN
6443 MSUB(243)=1
6444 MSUB(244)=1
6445 MSUB(258)=1
6446 MSUB(259)=1
6447 MSUB(261)=1
6448 MSUB(262)=1
6449 MSUB(264)=1
6450 MSUB(265)=1
6451 DO 250 I=271,296
6452 MSUB(I)=1
6453 250 CONTINUE
6454 ELSEIF(MINT(43).EQ.1) THEN
6455 MSUB(277)=1
6456 MSUB(278)=1
6457 ENDIF
6458
6459 ELSEIF(MSEL.EQ.41) THEN
6460C...Stop production.
6461 MSUB(261)=1
6462 MSUB(262)=1
6463 MSUB(263)=1
6464 IF(MINT(43).EQ.4) THEN
6465 MSUB(264)=1
6466 MSUB(265)=1
6467 ENDIF
6468
6469 ELSEIF(MSEL.EQ.42) THEN
6470C...Slepton production.
6471 DO 260 I=201,214
6472 MSUB(I)=1
6473 260 CONTINUE
6474 IF(MINT(43).NE.4) THEN
6475 MSUB(210)=0
6476 MSUB(211)=0
6477 MSUB(212)=0
6478 ENDIF
6479
6480 ELSEIF(MSEL.EQ.43) THEN
6481C...Neutralino/Chargino + Gluino/Squark.
6482 IF(MINT(43).EQ.4) THEN
6483 DO 270 I=237,242
6484 MSUB(I)=1
6485 270 CONTINUE
6486 DO 280 I=246,254
6487 MSUB(I)=1
6488 280 CONTINUE
6489 MSUB(256)=1
6490 ENDIF
6491
6492 ELSEIF(MSEL.EQ.44) THEN
6493C...Neutralino/Chargino pair production.
6494 IF(MINT(43).EQ.4) THEN
6495 DO 290 I=216,236
6496 MSUB(I)=1
6497 290 CONTINUE
6498 ELSEIF(MINT(43).EQ.1) THEN
6499 DO 300 I=216,228
6500 MSUB(I)=1
6501 300 CONTINUE
6502 ENDIF
6503
6504 ELSEIF(MSEL.EQ.45) THEN
6505C...Sbottom production.
6506 MSUB(287)=1
6507 MSUB(288)=1
6508 IF(MINT(43).EQ.4) THEN
6509 DO 310 I=281,296
6510 MSUB(I)=1
6511 310 CONTINUE
6512 ENDIF
6513
6514 ELSEIF(MSEL.EQ.50) THEN
6515C...Pair production of technipions and gauge bosons.
6516 DO 320 I=361,368
6517 MSUB(I)=1
6518 320 CONTINUE
6519 IF(MINT(43).EQ.4) THEN
6520 DO 330 I=370,377
6521 MSUB(I)=1
6522 330 CONTINUE
6523 ENDIF
6524
6525 ELSEIF(MSEL.EQ.51) THEN
6526C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6527 DO 340 I=381,386
6528 MSUB(I)=1
6529 340 CONTINUE
6530
6531 ELSEIF(MSEL.EQ.61) THEN
6532C...Charmonium production in colour octet model, with recoiling parton.
6533 DO 342 I=421,439
6534 MSUB(I)=1
6535 342 CONTINUE
6536
6537 ELSEIF(MSEL.EQ.62) THEN
6538C...Bottomonium production in colour octet model, with recoiling parton.
6539 DO 344 I=461,479
6540 MSUB(I)=1
6541 344 CONTINUE
6542
6543 ELSEIF(MSEL.EQ.63) THEN
6544C...Charmonium and bottomonium production in colour octet model.
6545 DO 346 I=421,439
6546 MSUB(I)=1
6547 MSUB(I+40)=1
6548 346 CONTINUE
6549 ENDIF
6550
6551C...Find heaviest new quark flavour allowed in processes 81-84.
6552 KFLQM=1
6553 DO 350 I=1,MIN(8,MDCY(21,3))
6554 IDC=I+MDCY(21,2)-1
6555 IF(MDME(IDC,1).LE.0) GOTO 350
6556 KFLQM=I
6557 350 CONTINUE
6558 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6559 &KFLQM=MSTP(7)
6560 MINT(55)=KFLQM
6561 KFPR(81,1)=KFLQM
6562 KFPR(81,2)=KFLQM
6563 KFPR(82,1)=KFLQM
6564 KFPR(82,2)=KFLQM
6565 KFPR(83,1)=KFLQM
6566 KFPR(84,1)=KFLQM
6567 KFPR(84,2)=KFLQM
6568
6569C...Find heaviest new fermion flavour allowed in process 85.
6570 KFLFM=1
6571 DO 360 I=1,MIN(12,MDCY(22,3))
6572 IDC=I+MDCY(22,2)-1
6573 IF(MDME(IDC,1).LE.0) GOTO 360
6574 KFLFM=KFDP(IDC,1)
6575 360 CONTINUE
6576 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6577 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6578 MINT(56)=KFLFM
6579 KFPR(85,1)=KFLFM
6580 KFPR(85,2)=KFLFM
6581
6582C...Import relevant information on external user processes.
6583 IF(MINT(111).GE.11) THEN
6584 IPYPR=0
6585 DO 390 IUP=1,NPRUP
6586C...Find next empty PYTHIA process number slot and enable it.
6587 370 IPYPR=IPYPR+1
6588 IF(IPYPR.GT.500) CALL PYERRM(26,
6589 & '(PYINPR.) no more empty slots for user processes')
6590 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6591 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6592 ISET(IPYPR)=11
6593C...Overwrite KFPR with references back to process number and ID.
6594 KFPR(IPYPR,1)=IUP
6595 KFPR(IPYPR,2)=LPRUP(IUP)
6596C...Process title.
6597 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6598 ICHIN=1
6599 DO 380 ICH=1,9
6600 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6601 380 CONTINUE
6602 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6603C...Switch on process.
6604 MSUB(IPYPR)=1
6605 390 CONTINUE
6606 ENDIF
6607
6608 RETURN
6609 END
6610
6611C*********************************************************************
6612
6613C...PYXTOT
6614C...Parametrizes total, elastic and diffractive cross-sections
6615C...for different energies and beams. Donnachie-Landshoff for
6616C...total and Schuler-Sjostrand for elastic and diffractive.
6617C...Process code IPROC:
6618C...= 1 : p + p;
6619C...= 2 : pbar + p;
6620C...= 3 : pi+ + p;
6621C...= 4 : pi- + p;
6622C...= 5 : pi0 + p;
6623C...= 6 : phi + p;
6624C...= 7 : J/psi + p;
6625C...= 11 : rho + rho;
6626C...= 12 : rho + phi;
6627C...= 13 : rho + J/psi;
6628C...= 14 : phi + phi;
6629C...= 15 : phi + J/psi;
6630C...= 16 : J/psi + J/psi;
6631C...= 21 : gamma + p (DL);
6632C...= 22 : gamma + p (VDM).
6633C...= 23 : gamma + pi (DL);
6634C...= 24 : gamma + pi (VDM);
6635C...= 25 : gamma + gamma (DL);
6636C...= 26 : gamma + gamma (VDM).
6637
6638 SUBROUTINE PYXTOT
6639
6640C...Double precision and integer declarations.
6641 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6642 IMPLICIT INTEGER(I-N)
6643 INTEGER PYK,PYCHGE,PYCOMP
6644C...Commonblocks.
6645 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6646 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6647 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6648 COMMON/PYINT1/MINT(400),VINT(400)
6649 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6650 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6651 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6652C...Local arrays.
6653 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6654 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6655 &CEFFD(10,9),SIGTMP(6,0:5)
6656
6657C...Common constants.
6658 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6659 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6660 &FACDD/0.0084D0/
6661
6662C...Number of multiple processes to be evaluated (= 0 : undefined).
6663 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6664C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6665 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6666 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6667 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6668 DATA YPAR/
6669 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6670 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6671 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6672
6673C...Beam and target hadron class:
6674C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6675 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6676 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6677C...Characteristic class masses, slope parameters, beta = sqrt(X).
6678 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6679 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6680 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6681
6682C...Fitting constants used in parametrizations of diffractive results.
6683 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6684 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6685 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6686 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6687 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6688 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6689 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6690 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6691 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6692 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6693 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6694 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6695 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6696 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6697 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6698 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6699 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6700 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6701 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6702 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6703 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6704 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6705 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6706 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6707 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6708 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6709 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6710 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6711 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6712
6713C...Parameters. Combinations of the energy.
6714 AEM=PARU(101)
6715 PMTH=PARP(102)
6716 S=VINT(2)
6717 SRT=VINT(1)
6718 SEPS=S**EPS
6719 SETA=S**ETA
6720 SLOG=LOG(S)
6721
6722C...Ratio of gamma/pi (for rescaling in parton distributions).
6723 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6724 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6725 VINT(317)=1D0
6726 IF(MINT(50).NE.1) RETURN
6727
6728C...Order flavours of incoming particles: KF1 < KF2.
6729 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6730 KF1=IABS(MINT(11))
6731 KF2=IABS(MINT(12))
6732 IORD=1
6733 ELSE
6734 KF1=IABS(MINT(12))
6735 KF2=IABS(MINT(11))
6736 IORD=2
6737 ENDIF
6738 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6739
6740C...Find process number (for lookup tables).
6741 IF(KF1.GT.1000) THEN
6742 IPROC=1
6743 IF(ISGN12.LT.0) IPROC=2
6744 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6745 IPROC=3
6746 IF(ISGN12.LT.0) IPROC=4
6747 IF(KF1.EQ.111) IPROC=5
6748 ELSEIF(KF1.GT.100) THEN
6749 IPROC=11
6750 ELSEIF(KF2.GT.1000) THEN
6751 IPROC=21
6752 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6753 ELSEIF(KF2.GT.100) THEN
6754 IPROC=23
6755 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6756 ELSE
6757 IPROC=25
6758 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6759 ENDIF
6760
6761C... Number of multiple processes to be stored; beam/target side.
6762 NPR=NPROC(IPROC)
6763 MINT(101)=1
6764 MINT(102)=1
6765 IF(NPR.EQ.3) THEN
6766 MINT(100+IORD)=4
6767 ELSEIF(NPR.EQ.6) THEN
6768 MINT(101)=4
6769 MINT(102)=4
6770 ENDIF
6771 N1=0
6772 IF(MINT(101).EQ.4) N1=4
6773 N2=0
6774 IF(MINT(102).EQ.4) N2=4
6775
6776C...Do not do any more for user-set or undefined cross-sections.
6777 IF(MSTP(31).LE.0) RETURN
6778 IF(NPR.EQ.0) CALL PYERRM(26,
6779 &'(PYXTOT:) cross section for this process not yet implemented')
6780
6781C...Parameters. Combinations of the energy.
6782 AEM=PARU(101)
6783 PMTH=PARP(102)
6784 S=VINT(2)
6785 SRT=VINT(1)
6786 SEPS=S**EPS
6787 SETA=S**ETA
6788 SLOG=LOG(S)
6789
6790C...Loop over multiple processes (for VDM).
6791 DO 110 I=1,NPR
6792 IF(NPR.EQ.1) THEN
6793 IPR=IPROC
6794 ELSEIF(NPR.EQ.3) THEN
6795 IPR=I+4
6796 IF(KF2.LT.1000) IPR=I+10
6797 ELSEIF(NPR.EQ.6) THEN
6798 IPR=I+10
6799 ENDIF
6800
6801C...Evaluate hadron species, mass, slope contribution and fit number.
6802 IHA=IHADA(IPR)
6803 IHB=IHADB(IPR)
6804 PMA=PMHAD(IHA)
6805 PMB=PMHAD(IHB)
6806 BHA=BHAD(IHA)
6807 BHB=BHAD(IHB)
6808 ISD=IFITSD(IPR)
6809 IDD=IFITDD(IPR)
6810
6811C...Skip if energy too low relative to masses.
6812 DO 100 J=0,5
6813 SIGTMP(I,J)=0D0
6814 100 CONTINUE
6815 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
6816
6817C...Total cross-section. Elastic slope parameter and cross-section.
6818 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
6819 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
6820 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
6821
6822C...Diffractive scattering A + B -> X + B.
6823 BSD=2D0*BHB
6824 SQML=(PMA+PMTH)**2
6825 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
6826 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6827 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6828 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
6829 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
6830 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
6831 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
6832
6833C...Diffractive scattering A + B -> A + X.
6834 BSD=2D0*BHA
6835 SQML=(PMB+PMTH)**2
6836 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
6837 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
6838 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
6839 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
6840 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
6841 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
6842 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
6843
6844C...Order single diffractive correctly.
6845 IF(IORD.EQ.2) THEN
6846 SIGSAV=SIGTMP(I,2)
6847 SIGTMP(I,2)=SIGTMP(I,3)
6848 SIGTMP(I,3)=SIGSAV
6849 ENDIF
6850
6851C...Double diffractive scattering A + B -> X1 + X2.
6852 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
6853 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
6854 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
6855 IF(YEFF.LE.0) SUM1=0D0
6856 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
6857 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
6858 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
6859 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
6860 & (2D0*ALP)
6861 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
6862 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
6863 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
6864 & (2D0*ALP)
6865 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
6866 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
6867 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
6868 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
6869 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
6870
6871C...Non-diffractive by unitarity.
6872 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
6873 & SIGTMP(I,4)
6874 110 CONTINUE
6875
6876C...Put temporary results in output array: only one process.
6877 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
6878 DO 120 J=0,5
6879 SIGT(0,0,J)=SIGTMP(1,J)
6880 120 CONTINUE
6881
6882C...Beam multiple processes.
6883 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
6884 IF(MINT(107).EQ.2) THEN
6885 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6886 ELSE
6887 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6888 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6889 ENDIF
6890 IF(MSTP(20).GT.0) THEN
6891 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
6892 ENDIF
6893 DO 140 I=1,4
6894 IF(MINT(107).EQ.2) THEN
6895 CONV=(AEM/PARP(160+I))*VINT(317)
6896 ELSEIF(VINT(154).GT.PARP(15)) THEN
6897 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6898 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6899 ELSE
6900 CONV=0D0
6901 ENDIF
6902 I1=MAX(1,I-1)
6903 DO 130 J=0,5
6904 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
6905 130 CONTINUE
6906 140 CONTINUE
6907 DO 150 J=0,5
6908 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6909 150 CONTINUE
6910
6911C...Target multiple processes.
6912 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
6913 IF(MINT(108).EQ.2) THEN
6914 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6915 ELSE
6916 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6917 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6918 ENDIF
6919 IF(MSTP(20).GT.0) THEN
6920 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
6921 ENDIF
6922 DO 170 I=1,4
6923 IF(MINT(108).EQ.2) THEN
6924 CONV=(AEM/PARP(160+I))*VINT(317)
6925 ELSEIF(VINT(154).GT.PARP(15)) THEN
6926 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
6927 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6928 ELSE
6929 CONV=0D0
6930 ENDIF
6931 IV=MAX(1,I-1)
6932 DO 160 J=0,5
6933 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
6934 160 CONTINUE
6935 170 CONTINUE
6936 DO 180 J=0,5
6937 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
6938 180 CONTINUE
6939
6940C...Both beam and target multiple processes.
6941 ELSE
6942 IF(MINT(107).EQ.2) THEN
6943 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
6944 ELSE
6945 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
6946 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
6947 ENDIF
6948 IF(MINT(108).EQ.2) THEN
6949 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
6950 ELSE
6951 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
6952 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
6953 ENDIF
6954 IF(MSTP(20).GT.0) THEN
6955 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
6956 & VINT(308)))**MSTP(20)
6957 ENDIF
6958 DO 210 I1=1,4
6959 DO 200 I2=1,4
6960 IF(MINT(107).EQ.2) THEN
6961 CONV=(AEM/PARP(160+I1))*VINT(317)
6962 ELSEIF(VINT(154).GT.PARP(15)) THEN
6963 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
6964 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
6965 ELSE
6966 CONV=0D0
6967 ENDIF
6968 IF(MINT(108).EQ.2) THEN
6969 CONV=CONV*(AEM/PARP(160+I2))
6970 ELSEIF(VINT(154).GT.PARP(15)) THEN
6971 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
6972 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
6973 ELSE
6974 CONV=0D0
6975 ENDIF
6976 IF(I1.LE.2) THEN
6977 IV=MAX(1,I2-1)
6978 ELSEIF(I2.LE.2) THEN
6979 IV=MAX(1,I1-1)
6980 ELSEIF(I1.EQ.I2) THEN
6981 IV=2*I1-2
6982 ELSE
6983 IV=5
6984 ENDIF
6985 DO 190 J=0,5
6986 JV=J
6987 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
6988 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
6989 190 CONTINUE
6990 200 CONTINUE
6991 210 CONTINUE
6992 DO 230 J=0,5
6993 DO 220 I=1,4
6994 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
6995 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
6996 220 CONTINUE
6997 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
6998 230 CONTINUE
6999 ENDIF
7000
7001C...Scale up uniformly for Donnachie-Landshoff parametrization.
7002 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7003 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7004 DO 260 I1=0,N1
7005 DO 250 I2=0,N2
7006 DO 240 J=0,5
7007 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7008 240 CONTINUE
7009 250 CONTINUE
7010 260 CONTINUE
7011 ENDIF
7012
7013 RETURN
7014 END
7015
7016C*********************************************************************
7017
7018C...PYMAXI
7019C...Finds optimal set of coefficients for kinematical variable selection
7020C...and the maximum of the part of the differential cross-section used
7021C...in the event weighting.
7022
7023 SUBROUTINE PYMAXI
7024
7025C...Double precision and integer declarations.
7026 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7027 IMPLICIT INTEGER(I-N)
7028 INTEGER PYK,PYCHGE,PYCOMP
7029C...Parameter statement to help give large particle numbers.
7030 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7031 &KEXCIT=4000000,KDIMEN=5000000)
7032
7033C...User process initialization commonblock.
7034 INTEGER MAXPUP
7035 PARAMETER (MAXPUP=100)
7036 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7037 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7038 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7039 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7040 &LPRUP(MAXPUP)
7041 SAVE /HEPRUP/
7042
7043C...Commonblocks.
7044 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7045 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7046 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7047 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7048 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7049 COMMON/PYINT1/MINT(400),VINT(400)
7050 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7051 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7052 COMMON/PYINT4/MWID(500),WIDS(500,5)
7053 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7054 COMMON/PYINT6/PROC(0:500)
7055 CHARACTER PROC*28
7056 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7057 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7058 COMMON/PYTCCO/COEFX(194:380,2)
7059 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7060 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7061 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7062 &/PYTCSM/,/TCPARA/
7063C...Local arrays, character variables and data.
7064 LOGICAL IOK
7065 CHARACTER CVAR(4)*4
7066 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7067 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7068 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2)
7069 DATA CVAR/'tau ','tau''','y* ','cth '/
7070 DATA SIGSSM/3*0D0/
7071
7072C...Initial values and loop over subprocesses.
7073 NPOSI=0
7074 VINT(143)=1D0
7075 VINT(144)=1D0
7076 XSEC(0,1)=0D0
7077 ITECH=0
7078 DO 460 ISUB=1,500
7079 MINT(1)=ISUB
7080 MINT(51)=0
7081
7082C...Find maximum weight factors for photon flux.
7083 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7085 ENDIF
7086
7087C...Select subprocess to study: skip cases not applicable.
7088 IF(ISET(ISUB).EQ.11) THEN
7089 IF(MSUB(ISUB).NE.1) GOTO 460
7090C...User process intialization: cross section model dependent.
7091 IF(IABS(IDWTUP).EQ.1) THEN
7092 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7093 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7094 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7095 ELSE
7096 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7097 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7098 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7099 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7100 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7101 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7102 ENDIF
7103 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7104 & WTGAGA*XSEC(ISUB,1)
7105 NPOSI=NPOSI+1
7106 GOTO 450
7107 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7108 CALL PYSIGH(NCHN,SIGS)
7109 XSEC(ISUB,1)=SIGS
7110 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7111 & WTGAGA*XSEC(ISUB,1)
7112 IF(MSUB(ISUB).NE.1) GOTO 460
7113 NPOSI=NPOSI+1
7114 GOTO 450
7115 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7116 CALL PYSIGH(NCHN,SIGS)
7117 XSEC(ISUB,1)=SIGS
7118 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7119 & WTGAGA*XSEC(ISUB,1)
7120 IF(XSEC(ISUB,1).EQ.0D0) THEN
7121 MSUB(ISUB)=0
7122 ELSE
7123 NPOSI=NPOSI+1
7124 ENDIF
7125 GOTO 450
7126 ELSEIF(ISUB.EQ.96) THEN
7127 IF(MINT(50).EQ.0) GOTO 460
7128 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7129 & GOTO 460
7130 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7131 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7132 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7133 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7134 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7135 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7136 ELSE
7137 IF(MSUB(ISUB).NE.1) GOTO 460
7138 ENDIF
7139 ISTSB=ISET(ISUB)
7140 IF(ISUB.EQ.96) ISTSB=2
7141 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7142 MWTXS=0
7143 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7144 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7145
7146C...Find resonances (explicit or implicit in cross-section).
7147 MINT(72)=0
7148 KFR1=0
7149 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7150 KFR1=KFPR(ISUB,1)
7151 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7152 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7153 KFR1=23
7154 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7155 & .OR.ISUB.EQ.177) THEN
7156 KFR1=24
7157 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7158 KFR1=25
7159 IF(MSTP(46).EQ.5) THEN
7160 KFR1=89
7161 PMAS(89,1)=PARP(45)
7162 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7163 ENDIF
7164 ENDIF
7165 CKMX=CKIN(2)
7166 IF(CKMX.LE.0D0) CKMX=VINT(1)
7167 KCR1=PYCOMP(KFR1)
7168 IF(KFR1.NE.0) THEN
7169 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7170 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7171 ENDIF
7172 IF(KFR1.NE.0) THEN
7173 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7174 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7175 MINT(72)=1
7176 MINT(73)=KFR1
7177 VINT(73)=TAUR1
7178 VINT(74)=GAMR1
7179 ENDIF
7180 KFR2=0
7181 KFR3=0
7182 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7183 $ (ISUB.GE.361.AND.ISUB.LE.380))
7184 $ THEN
7185 KFR2=23
7186 IF(ISUB.EQ.141) THEN
7187 KCR2=PYCOMP(KFR2)
7188 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7189 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7190 KFR2=0
7191 ELSE
7192 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7193 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7194 MINT(72)=2
7195 MINT(74)=KFR2
7196 VINT(75)=TAUR2
7197 VINT(76)=GAMR2
7198 ENDIF
7199 ELSEIF(ITECH.EQ.0) THEN
7200 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7201 ITECH=1
7202 KFR1=KTECHN+113
7203 KCR1=PYCOMP(KFR1)
7204 KFR2=KTECHN+223
7205 KCR2=PYCOMP(KFR2)
7206 KFR3=KTECHN+115
7207 KCR3=PYCOMP(KFR3)
7208 IRES=0
7209C...Order the resonances
7210 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7211 KCT=KCR3
7212 KCR3=KCR2
7213 KCR2=KCT
7214 ENDIF
7215 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7216 KCT=KCR3
7217 KCR3=KCR1
7218 KCR1=KCT
7219 ENDIF
7220 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7221 KCT=KCR2
7222 KCR2=KCR1
7223 KCR1=KCT
7224 ENDIF
7225 DO 101 I=1,3
7226 IF(I.EQ.1) THEN
7227 SHN0=PMAS(KCR1,1)**2
7228 ELSEIF(I.EQ.2) THEN
7229 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7230 SHN0=PMAS(KCR2,1)**2
7231 ELSEIF(I.EQ.3) THEN
7232 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7233 SHN0=PMAS(KCR3,1)**2
7234 ENDIF
7235 AEM=PYALEM(SHN0)
7236 FAR=SQRT(AEM/ALPRHT)
7237 SHN=SHN0*(1D0-FAR)
7238 CALL PYTECM(SHN,S1,WIDO,1)
7239 RES=SHN-S1
7240 SHN=S1*.99D0
7241 SHSTEP=2D0
7242 102 SHN=SHN+SHSTEP
7243 CALL PYTECM(SHN,S1,WIDO,1)
7244 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7245 IOK=.FALSE.
7246 IF(IRES.GT.0) THEN
7247 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7248 ELSEIF(IRES.EQ.0) THEN
7249 IOK=.TRUE.
7250 ENDIF
7251 IF(IOK) THEN
7252 IRES=IRES+1
7253 XMAS(IRES)=SQRT(S1)
7254 XWID(IRES)=WIDO
7255 ENDIF
7256 ENDIF
7257 RES=SHN-S1
7258 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7259 101 CONTINUE
7260 JRES=0
7261 KFR1=KTECHN+213
7262 KCR1=PYCOMP(KFR1)
7263 KFR2=KTECHN+215
7264 KCR2=PYCOMP(KFR2)
7265 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7266 KCT=KCR2
7267 KCR2=KCR1
7268 KCR1=KCT
7269 ENDIF
7270 DO 103 I=1,2
7271 IF(I.EQ.1) THEN
7272 SHN0=PMAS(KCR1,1)**2
7273 ELSEIF(I.EQ.2) THEN
7274 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7275 SHN0=PMAS(KCR2,1)**2
7276 ENDIF
7277 AEM=PYALEM(SHN0)
7278 FAR=SQRT(AEM/ALPRHT)
7279 SHN=SHN0*(1D0-FAR)
7280 CALL PYTECM(SHN,S1,WIDO,2)
7281 RES=SHN-S1
7282 SHN=S1*.99D0
7283 SHSTEP=2D0
7284 104 SHN=SHN+SHSTEP
7285 CALL PYTECM(SHN,S1,WIDO,2)
7286 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7287 IOK=.FALSE.
7288 IF(JRES.GT.0) THEN
7289 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7290 ELSEIF(JRES.EQ.0) THEN
7291 IOK=.TRUE.
7292 ENDIF
7293 IF(IOK) THEN
7294 JRES=JRES+1
7295 YMAS(JRES)=SQRT(S1)
7296 YWID(JRES)=WIDO
7297 ENDIF
7298 ENDIF
7299 RES=SHN-S1
7300 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7301 103 CONTINUE
7302 ENDIF
7303 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7304 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7305 MINT(72)=IRES
7306 IF(IRES.GE.1) THEN
7307 VINT(73)=XMAS(1)**2/VINT(2)
7308 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7309 TAUR1=VINT(73)
7310 GAMR1=VINT(74)
7311 XM1=XMAS(1)
7312 XG1=XWID(1)
7313 KFR1=1
7314 ENDIF
7315 IF(IRES.GE.2) THEN
7316 VINT(75)=XMAS(2)**2/VINT(2)
7317 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7318 TAUR2=VINT(75)
7319 GAMR2=VINT(76)
7320 XM2=XMAS(2)
7321 XG2=XWID(2)
7322 KFR2=2
7323 ENDIF
7324 IF(IRES.EQ.3) THEN
7325 VINT(77)=XMAS(3)**2/VINT(2)
7326 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7327 TAUR3=VINT(77)
7328 GAMR3=VINT(78)
7329 XM3=XMAS(3)
7330 XG3=XWID(3)
7331 KFR3=3
7332 ENDIF
7333C...Charged current: rho+- and a+-
7334 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7335 MINT(72)=IRES
7336 IF(JRES.GE.1) THEN
7337 VINT(73)=YMAS(1)**2/VINT(2)
7338 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7339 KFR1=1
7340 TAUR1=VINT(73)
7341 GAMR1=VINT(74)
7342 XM1=YMAS(1)
7343 XG1=YWID(1)
7344 ENDIF
7345 IF(JRES.GE.2) THEN
7346 VINT(75)=YMAS(2)**2/VINT(2)
7347 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7348 KFR2=2
7349 TAUR2=VINT(73)
7350 GAMR2=VINT(74)
7351 XM2=YMAS(2)
7352 XG2=YWID(2)
7353 ENDIF
7354 KFR3=0
7355 ENDIF
7356 IF(ISUB.NE.141) THEN
7357 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7358 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7359 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7360 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7361 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7362 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7363 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7364
7365 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7366 MINT(72)=2
7367 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7368 MINT(72)=2
7369 MINT(74)=KFR3
7370 VINT(75)=TAUR3
7371 VINT(76)=GAMR3
7372 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7373 MINT(72)=2
7374 MINT(73)=KFR2
7375 VINT(73)=TAUR2
7376 VINT(74)=GAMR2
7377 MINT(74)=KFR3
7378 VINT(75)=TAUR3
7379 VINT(76)=GAMR3
7380 ELSEIF(KFR1.NE.0) THEN
7381 MINT(72)=1
7382 ELSEIF(KFR2.NE.0) THEN
7383 MINT(72)=1
7384 MINT(73)=KFR2
7385 VINT(73)=TAUR2
7386 VINT(74)=GAMR2
7387 ELSEIF(KFR3.NE.0) THEN
7388 MINT(72)=1
7389 MINT(73)=KFR3
7390 VINT(73)=TAUR3
7391 VINT(74)=GAMR3
7392 ELSE
7393 MINT(72)=0
7394 ENDIF
7395 ELSE
7396 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7397
7398 ELSEIF(KFR2.NE.0) THEN
7399 KFR1=KFR2
7400 TAUR1=TAUR2
7401 GAMR1=GAMR2
7402 MINT(72)=1
7403 MINT(73)=KFR1
7404 VINT(73)=TAUR1
7405 VINT(74)=GAMR1
7406 KFR2=0
7407 ELSE
7408 MINT(72)=0
7409 ENDIF
7410 ENDIF
7411 ENDIF
7412
7413C...Find product masses and minimum pT of process.
7414 SQM3=0D0
7415 SQM4=0D0
7416 MINT(71)=0
7417 VINT(71)=CKIN(3)
7418 VINT(80)=1D0
7419 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7420 NBW=0
7421 DO 110 I=1,2
7422 PMMN(I)=0D0
7423 IF(KFPR(ISUB,I).EQ.0) THEN
7424 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7425 & PARP(41)) THEN
7426 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7427 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7428 ELSE
7429 NBW=NBW+1
7430C...This prevents SUSY/t particles from becoming too light.
7431 KFLW=KFPR(ISUB,I)
7432 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7433 KCW=PYCOMP(KFLW)
7434 PMMN(I)=PMAS(KCW,1)
7435 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7436 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7437 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7438 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7439 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7440 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7441 PMMN(I)=MIN(PMMN(I),PMSUM)
7442 ENDIF
7443 100 CONTINUE
7444 ELSEIF(KFLW.EQ.6) THEN
7445 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7446 ENDIF
7447 ENDIF
7448 110 CONTINUE
7449 IF(NBW.GE.1) THEN
7450 CKIN41=CKIN(41)
7451 CKIN43=CKIN(43)
7452 CKIN(41)=MAX(PMMN(1),CKIN(41))
7453 CKIN(43)=MAX(PMMN(2),CKIN(43))
7454 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7455 CKIN(41)=CKIN41
7456 CKIN(43)=CKIN43
7457 IF(MINT(51).EQ.1) THEN
7458 WRITE(MSTU(11),5100) ISUB
7459 MSUB(ISUB)=0
7460 GOTO 460
7461 ENDIF
7462 SQM3=PQM3**2
7463 SQM4=PQM4**2
7464 ENDIF
7465 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7466 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7467 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7468 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7469 ELSEIF(ISUB.EQ.96) THEN
7470 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7471 ENDIF
7472 ENDIF
7473 VINT(63)=SQM3
7474 VINT(64)=SQM4
7475
7476C...Prepare for additional variable choices in 2 -> 3.
7477 IF(ISTSB.EQ.5) THEN
7478 VINT(201)=0D0
7479 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7480 VINT(206)=VINT(201)
7481 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7482 VINT(204)=PMAS(23,1)
7483 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7484 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7485 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7486 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7487 & VINT(204)=VINT(201)
7488 VINT(209)=VINT(204)
7489 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7490 ENDIF
7491
7492C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7493 IPEAK7=0
7494 NPTS(1)=2+2*MINT(72)
7495 IF(MINT(47).EQ.1) THEN
7496 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7497 ELSEIF(MINT(47).GE.5) THEN
7498 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7499 NPTS(1)=NPTS(1)+1
7500 IPEAK7=1
7501 ENDIF
7502 ENDIF
7503 NPTS(2)=1
7504 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7505 IF(MINT(47).GE.2) NPTS(2)=2
7506 IF(MINT(47).GE.5) NPTS(2)=3
7507 ENDIF
7508 NPTS(3)=1
7509 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7510 NPTS(3)=3
7511 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7512 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7513 ENDIF
7514 NPTS(4)=1
7515 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7516 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7517
7518C...Reset coefficients of cross-section weighting.
7519 DO 120 J=1,20
7520 COEF(ISUB,J)=0D0
7521 120 CONTINUE
7522 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7523 & .AND.ISUB.LE.380)) THEN
7524 DO 125 J=1,2
7525 COEFX(ISUB,J)=0D0
7526 125 CONTINUE
7527 ENDIF
7528 COEF(ISUB,1)=1D0
7529 COEF(ISUB,8)=0.5D0
7530 COEF(ISUB,9)=0.5D0
7531 COEF(ISUB,13)=1D0
7532 COEF(ISUB,18)=1D0
7533 MCTH=0
7534 MTAUP=0
7535 METAUP=0
7536 VINT(23)=0D0
7537 VINT(26)=0D0
7538 SIGSAM=0D0
7539
7540C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7541C...in grid of phase space points.
7542 CALL PYKLIM(1)
7543 METAU=MINT(51)
7544 NACC=0
7545 DO 150 ITRY=1,NTRY
7546 MINT(51)=0
7547 IF(METAU.EQ.1) GOTO 150
7548 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7549 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7550 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7551 MTAU=7
7552 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7553 MTAU=MTAU+1
7554 ENDIF
7555 RTAU=0.5D0
7556C...Special case when both resonances have same mass,
7557C...as is often the case in process 194.
7558c IF(MINT(72).GE.2) THEN
7559c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7560c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7561c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7562c RTAU=0.4D0
7563c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7564c RTAU=0.6D0
7565c ENDIF
7566c ENDIF
7567c ENDIF
7568 CALL PYKMAP(1,MTAU,RTAU)
7569 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7570 METAUP=MINT(51)
7571 ENDIF
7572 IF(METAUP.EQ.1) GOTO 150
7573 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7574 & .EQ.0) THEN
7575 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7576 CALL PYKMAP(4,MTAUP,0.5D0)
7577 ENDIF
7578 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7579 CALL PYKLIM(2)
7580 MEYST=MINT(51)
7581 ENDIF
7582 IF(MEYST.EQ.1) GOTO 150
7583 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7584 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7585 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7586 CALL PYKMAP(2,MYST,0.5D0)
7587 CALL PYKLIM(3)
7588 MECTH=MINT(51)
7589 ENDIF
7590 IF(MECTH.EQ.1) GOTO 150
7591 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7592 MCTH=1+MOD(ITRY-1,NPTS(4))
7593 CALL PYKMAP(3,MCTH,0.5D0)
7594 ENDIF
7595 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7596
7597C...Store position and limits.
7598 MINT(51)=0
7599 CALL PYKLIM(0)
7600 IF(MINT(51).EQ.1) GOTO 150
7601 NACC=NACC+1
7602 MVARPT(NACC,1)=MTAU
7603 MVARPT(NACC,2)=MTAUP
7604 MVARPT(NACC,3)=MYST
7605 MVARPT(NACC,4)=MCTH
7606 DO 130 J=1,30
7607 VINTPT(NACC,J)=VINT(10+J)
7608 130 CONTINUE
7609
7610C...Normal case: calculate cross-section.
7611 IF(ISTSB.NE.5) THEN
7612 CALL PYSIGH(NCHN,SIGS)
7613 IF(MWTXS.EQ.1) THEN
7614 CALL PYEVWT(WTXS)
7615 SIGS=WTXS*SIGS
7616 ENDIF
7617
7618C..2 -> 3: find highest value out of a number of tries.
7619 ELSE
7620 SIGS=0D0
7621 DO 140 IKIN3=1,MSTP(129)
7622 CALL PYKMAP(5,0,0D0)
7623 IF(MINT(51).EQ.1) GOTO 140
7624 CALL PYSIGH(NCHN,SIGTMP)
7625 IF(MWTXS.EQ.1) THEN
7626 CALL PYEVWT(WTXS)
7627 SIGTMP=WTXS*SIGTMP
7628 ENDIF
7629 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7630 140 CONTINUE
7631 ENDIF
7632
7633C...Store cross-section.
7634 SIGSPT(NACC)=SIGS
7635 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7636 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7637 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7638 150 CONTINUE
7639 IF(NACC.EQ.0) THEN
7640 WRITE(MSTU(11),5100) ISUB
7641 MSUB(ISUB)=0
7642 GOTO 460
7643 ELSEIF(SIGSAM.EQ.0D0) THEN
7644 WRITE(MSTU(11),5300) ISUB
7645 MSUB(ISUB)=0
7646 GOTO 460
7647 ENDIF
7648 IF(ISUB.NE.96) NPOSI=NPOSI+1
7649
7650C...Calculate integrals in tau over maximal phase space limits.
7651 TAUMIN=VINT(11)
7652 TAUMAX=VINT(31)
7653 ATAU1=LOG(TAUMAX/TAUMIN)
7654 IF(NPTS(1).GE.2) THEN
7655 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7656 ENDIF
7657 IF(NPTS(1).GE.4) THEN
7658 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7659 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7660 & GAMR1
7661 ENDIF
7662 IF(NPTS(1).GE.6) THEN
7663 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7664 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7665 & GAMR2
7666 ENDIF
7667 IF(NPTS(1).GE.8) THEN
7668 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7669 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7670 & GAMR3
7671 ENDIF
7672 IF(IPEAK7.EQ.1) THEN
7673 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7674 ENDIF
7675
7676C...Reset. Sum up cross-sections in points calculated.
7677 DO 320 IVAR=1,4
7678 IF(NPTS(IVAR).EQ.1) GOTO 320
7679 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7680 NBIN=NPTS(IVAR)
7681 DO 170 J1=1,NBIN
7682 NAREL(J1)=0
7683 WTREL(J1)=0D0
7684 COEFU(J1)=0D0
7685 DO 160 J2=1,NBIN
7686 WTMAT(J1,J2)=0D0
7687 160 CONTINUE
7688 170 CONTINUE
7689 DO 180 IACC=1,NACC
7690 IBIN=MVARPT(IACC,IVAR)
7691 IF(IVAR.EQ.1) THEN
7692 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7693 IBIN=IBIN-1
7694 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7695 IBIN=3+2*MINT(72)
7696 ENDIF
7697 ENDIF
7698 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7699 NAREL(IBIN)=NAREL(IBIN)+1
7700 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7701
7702C...Sum up tau cross-section pieces in points used.
7703 IF(IVAR.EQ.1) THEN
7704 TAU=VINTPT(IACC,11)
7705 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7706 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7707 IF(NBIN.GE.4) THEN
7708 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7709 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7710 & ((TAU-TAUR1)**2+GAMR1**2)
7711 ENDIF
7712 IF(NBIN.GE.6) THEN
7713 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7714 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7715 & ((TAU-TAUR2)**2+GAMR2**2)
7716 ENDIF
7717 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7718 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7719 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7720 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7721 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7722 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7723 ENDIF
7724 IF(MINT(72).EQ.3) THEN
7725 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7726 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7727 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7728 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7729 ENDIF
7730C...Sum up tau' cross-section pieces in points used.
7731 ELSEIF(IVAR.EQ.2) THEN
7732 TAU=VINTPT(IACC,11)
7733 TAUP=VINTPT(IACC,16)
7734 TAUPMN=VINTPT(IACC,6)
7735 TAUPMX=VINTPT(IACC,26)
7736 ATAUP1=LOG(TAUPMX/TAUPMN)
7737 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7738 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7739 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7740 & (1D0-TAU/TAUP)**3/TAUP
7741 IF(NBIN.GE.3) THEN
7742 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7743 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7744 & TAUP/MAX(2D-10,1D0-TAUP)
7745 ENDIF
7746
7747C...Sum up y* cross-section pieces in points used.
7748 ELSEIF(IVAR.EQ.3) THEN
7749 YST=VINTPT(IACC,12)
7750 YSTMIN=VINTPT(IACC,2)
7751 YSTMAX=VINTPT(IACC,22)
7752 AYST0=YSTMAX-YSTMIN
7753 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7754 AYST2=AYST1
7755 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7756 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7757 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7758 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7759 IF(MINT(45).EQ.3) THEN
7760 TAUE=VINTPT(IACC,11)
7761 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7762 YST0=-0.5D0*LOG(TAUE)
7763 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7764 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7765 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7766 & MAX(1D-10,1D0-EXP(YST-YST0))
7767 ENDIF
7768 IF(MINT(46).EQ.3) THEN
7769 TAUE=VINTPT(IACC,11)
7770 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7771 YST0=-0.5D0*LOG(TAUE)
7772 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7773 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7774 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7775 & MAX(1D-10,1D0-EXP(-YST-YST0))
7776 ENDIF
7777
7778C...Sum up cos(theta-hat) cross-section pieces in points used.
7779 ELSE
7780 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7781 RSQM=1D0+RM34
7782 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7783 CTHMIN=-CTHMAX
7784 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7785 & (TAUMAX*VINT(2)))
7786 ACTH1=CTHMAX-CTHMIN
7787 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7788 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7789 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7790 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7791 CTH=VINTPT(IACC,13)
7792 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7793 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7794 & MAX(RM34,RSQM-CTH)
7795 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7796 & MAX(RM34,RSQM+CTH)
7797 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7798 & MAX(RM34,RSQM-CTH)**2
7799 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7800 & MAX(RM34,RSQM+CTH)**2
7801 ENDIF
7802 180 CONTINUE
7803
7804C...Check that equation system solvable.
7805 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7806 MSOLV=1
7807 WTRELS=0D0
7808 DO 190 IBIN=1,NBIN
7809 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7810 & IRED=1,NBIN),WTREL(IBIN)
7811 IF(NAREL(IBIN).EQ.0) MSOLV=0
7812 WTRELS=WTRELS+WTREL(IBIN)
7813 190 CONTINUE
7814 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
7815
7816C...Solve to find relative importance of cross-section pieces.
7817 IF(MSOLV.EQ.1) THEN
7818 DO 200 IBIN=1,NBIN
7819 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
7820 200 CONTINUE
7821 DO 230 IRED=1,NBIN-1
7822 DO 220 IBIN=IRED+1,NBIN
7823 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
7824 MSOLV=0
7825 GOTO 260
7826 ENDIF
7827 RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
7828 WTREL(IBIN)=WTREL(IBIN)-RQT*WTREL(IRED)
7829 DO 210 ICOE=IRED,NBIN
7830 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-RQT*WTMAT(IRED,ICOE)
7831 210 CONTINUE
7832 220 CONTINUE
7833 230 CONTINUE
7834 DO 250 IRED=NBIN,1,-1
7835 DO 240 ICOE=IRED+1,NBIN
7836 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
7837 240 CONTINUE
7838 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
7839 250 CONTINUE
7840 ENDIF
7841
7842C...Share evenly if failure.
7843 260 IF(MSOLV.EQ.0) THEN
7844 DO 270 IBIN=1,NBIN
7845 COEFU(IBIN)=1D0
7846 WTRELN(IBIN)=0.1D0
7847 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
7848 & WTREL(IBIN)/WTRELS)
7849 270 CONTINUE
7850 ENDIF
7851
7852C...Normalize coefficients, with piece shared democratically.
7853 COEFSU=0D0
7854 WTRELS=0D0
7855 DO 280 IBIN=1,NBIN
7856 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
7857 COEFSU=COEFSU+COEFU(IBIN)
7858 WTRELS=WTRELS+WTRELN(IBIN)
7859 280 CONTINUE
7860 IF(COEFSU.GT.0D0) THEN
7861 DO 290 IBIN=1,NBIN
7862 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
7863 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
7864 290 CONTINUE
7865 ELSE
7866 DO 300 IBIN=1,NBIN
7867 COEFO(IBIN)=1D0/NBIN
7868 300 CONTINUE
7869 ENDIF
7870 IF(IVAR.EQ.1) IOFF=0
7871 IF(IVAR.EQ.2) IOFF=17
7872 IF(IVAR.EQ.3) IOFF=7
7873 IF(IVAR.EQ.4) IOFF=12
7874 DO 310 IBIN=1,NBIN
7875 ICOF=IOFF+IBIN
7876 IF(IVAR.EQ.1) THEN
7877 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
7878 ICOF=7
7879 ENDIF
7880 ENDIF
7881 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
7882 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
7883 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
7884 ELSE
7885 COEF(ISUB,ICOF)=COEFO(IBIN)
7886 ENDIF
7887 310 CONTINUE
7888
7889 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
7890 & (COEFO(IBIN),IBIN=1,NBIN)
7891
7892 320 CONTINUE
7893
7894C...Find two most promising maxima among points previously determined.
7895 DO 330 J=1,4
7896 IACCMX(J)=0
7897 SIGSMX(J)=0D0
7898 330 CONTINUE
7899 NMAX=0
7900 DO 390 IACC=1,NACC
7901 DO 340 J=1,30
7902 VINT(10+J)=VINTPT(IACC,J)
7903 340 CONTINUE
7904 IF(ISTSB.NE.5) THEN
7905 CALL PYSIGH(NCHN,SIGS)
7906 IF(MWTXS.EQ.1) THEN
7907 CALL PYEVWT(WTXS)
7908 SIGS=WTXS*SIGS
7909 ENDIF
7910 ELSE
7911 SIGS=0D0
7912 DO 350 IKIN3=1,MSTP(129)
7913 CALL PYKMAP(5,0,0D0)
7914 IF(MINT(51).EQ.1) GOTO 350
7915 CALL PYSIGH(NCHN,SIGTMP)
7916 IF(MWTXS.EQ.1) THEN
7917 CALL PYEVWT(WTXS)
7918 SIGTMP=WTXS*SIGTMP
7919 ENDIF
7920 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7921 350 CONTINUE
7922 ENDIF
7923 IEQ=0
7924 DO 360 IMV=1,NMAX
7925 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
7926 360 CONTINUE
7927 IF(IEQ.EQ.0) THEN
7928 DO 370 IMV=NMAX,1,-1
7929 IIN=IMV+1
7930 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
7931 IACCMX(IMV+1)=IACCMX(IMV)
7932 SIGSMX(IMV+1)=SIGSMX(IMV)
7933 370 CONTINUE
7934 IIN=1
7935 380 IACCMX(IIN)=IACC
7936 SIGSMX(IIN)=SIGS
7937 IF(NMAX.LE.1) NMAX=NMAX+1
7938 ENDIF
7939 390 CONTINUE
7940
7941C...Read out starting position for search.
7942 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
7943 SIGSAM=SIGSMX(1)
7944 DO 440 IMAX=1,NMAX
7945 IACC=IACCMX(IMAX)
7946 MTAU=MVARPT(IACC,1)
7947 MTAUP=MVARPT(IACC,2)
7948 MYST=MVARPT(IACC,3)
7949 MCTH=MVARPT(IACC,4)
7950 VTAU=0.5D0
7951 VYST=0.5D0
7952 VCTH=0.5D0
7953 VTAUP=0.5D0
7954
7955C...Starting point and step size in parameter space.
7956 DO 430 IRPT=1,2
7957 DO 420 IVAR=1,4
7958 IF(NPTS(IVAR).EQ.1) GOTO 420
7959 IF(IVAR.EQ.1) VVAR=VTAU
7960 IF(IVAR.EQ.2) VVAR=VTAUP
7961 IF(IVAR.EQ.3) VVAR=VYST
7962 IF(IVAR.EQ.4) VVAR=VCTH
7963 IF(IVAR.EQ.1) MVAR=MTAU
7964 IF(IVAR.EQ.2) MVAR=MTAUP
7965 IF(IVAR.EQ.3) MVAR=MYST
7966 IF(IVAR.EQ.4) MVAR=MCTH
7967 IF(IRPT.EQ.1) VDEL=0.1D0
7968 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
7969 & 0.98D0-VVAR))
7970 IF(IRPT.EQ.1) VMAR=0.02D0
7971 IF(IRPT.EQ.2) VMAR=0.002D0
7972 IMOV0=1
7973 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
7974 DO 410 IMOV=IMOV0,8
7975
7976C...Define new point in parameter space.
7977 IF(IMOV.EQ.0) THEN
7978 INEW=2
7979 VNEW=VVAR
7980 ELSEIF(IMOV.EQ.1) THEN
7981 INEW=3
7982 VNEW=VVAR+VDEL
7983 ELSEIF(IMOV.EQ.2) THEN
7984 INEW=1
7985 VNEW=VVAR-VDEL
7986 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
7987 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
7988 VVAR=VVAR+VDEL
7989 SIGSSM(1)=SIGSSM(2)
7990 SIGSSM(2)=SIGSSM(3)
7991 INEW=3
7992 VNEW=VVAR+VDEL
7993 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
7994 & VVAR-2D0*VDEL.GT.VMAR) THEN
7995 VVAR=VVAR-VDEL
7996 SIGSSM(3)=SIGSSM(2)
7997 SIGSSM(2)=SIGSSM(1)
7998 INEW=1
7999 VNEW=VVAR-VDEL
8000 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8001 VDEL=0.5D0*VDEL
8002 VVAR=VVAR+VDEL
8003 SIGSSM(1)=SIGSSM(2)
8004 INEW=2
8005 VNEW=VVAR
8006 ELSE
8007 VDEL=0.5D0*VDEL
8008 VVAR=VVAR-VDEL
8009 SIGSSM(3)=SIGSSM(2)
8010 INEW=2
8011 VNEW=VVAR
8012 ENDIF
8013
8014C...Convert to relevant variables and find derived new limits.
8015 ILERR=0
8016 IF(IVAR.EQ.1) THEN
8017 VTAU=VNEW
8018 CALL PYKMAP(1,MTAU,VTAU)
8019 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8020 CALL PYKLIM(4)
8021 IF(MINT(51).EQ.1) ILERR=1
8022 ENDIF
8023 ENDIF
8024 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8025 & ILERR.EQ.0) THEN
8026 IF(IVAR.EQ.2) VTAUP=VNEW
8027 CALL PYKMAP(4,MTAUP,VTAUP)
8028 ENDIF
8029 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8030 CALL PYKLIM(2)
8031 IF(MINT(51).EQ.1) ILERR=1
8032 ENDIF
8033 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8034 IF(IVAR.EQ.3) VYST=VNEW
8035 CALL PYKMAP(2,MYST,VYST)
8036 CALL PYKLIM(3)
8037 IF(MINT(51).EQ.1) ILERR=1
8038 ENDIF
8039 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8040 & ILERR.EQ.0) THEN
8041 IF(IVAR.EQ.4) VCTH=VNEW
8042 CALL PYKMAP(3,MCTH,VCTH)
8043 ENDIF
8044 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8045
8046C...Evaluate cross-section. Save new maximum. Final maximum.
8047 IF(ILERR.NE.0) THEN
8048 SIGS=0.
8049 ELSEIF(ISTSB.NE.5) THEN
8050 CALL PYSIGH(NCHN,SIGS)
8051 IF(MWTXS.EQ.1) THEN
8052 CALL PYEVWT(WTXS)
8053 SIGS=WTXS*SIGS
8054 ENDIF
8055 ELSE
8056 SIGS=0D0
8057 DO 400 IKIN3=1,MSTP(129)
8058 CALL PYKMAP(5,0,0D0)
8059 IF(MINT(51).EQ.1) GOTO 400
8060 CALL PYSIGH(NCHN,SIGTMP)
8061 IF(MWTXS.EQ.1) THEN
8062 CALL PYEVWT(WTXS)
8063 SIGTMP=WTXS*SIGTMP
8064 ENDIF
8065 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8066 400 CONTINUE
8067 ENDIF
8068 SIGSSM(INEW)=SIGS
8069 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8070 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8071 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8072 410 CONTINUE
8073 420 CONTINUE
8074 430 CONTINUE
8075 440 CONTINUE
8076 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8077 XSEC(ISUB,1)=1.05D0*SIGSAM
8078 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8079 & WTGAGA*XSEC(ISUB,1)
8080 450 CONTINUE
8081 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8082 & PARP(174)*XSEC(ISUB,1)
8083 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8084 460 CONTINUE
8085 MINT(51)=0
8086
8087C...Print summary table.
8088 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8089 IF(MSTP(127).NE.1) THEN
8090 WRITE(MSTU(11),5900)
8091 CALL PYSTOP(1)
8092 ELSE
8093 WRITE(MSTU(11),6400)
8094 MSTI(53)=1
8095 ENDIF
8096 ENDIF
8097 IF(MSTP(122).GE.1) THEN
8098 WRITE(MSTU(11),6000)
8099 WRITE(MSTU(11),6100)
8100 DO 470 ISUB=1,500
8101 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8102 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8103 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8104 & GOTO 470
8105 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8106 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8107 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8108 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8109 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8110 470 CONTINUE
8111 WRITE(MSTU(11),6300)
8112 ENDIF
8113
8114C...Format statements for maximization results.
8115 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8116 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8117 &'cth',9X,'tau''',7X,'sigma')
8118 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8119 &'phase space.'/1X,'Process switched off!')
8120 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8121 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8122 &'cross-section.'/1X,'Process switched off!')
8123 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8124 5500 FORMAT(1X,1P,10D11.3)
8125 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8126 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8127 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8128 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8129 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8130 &'cross-section.'/1X,'Execution stopped!')
8131 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8132 &'cross-section maximum search',1X,8('*'))
8133 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8134 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8135 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8136 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8137 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8138 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8139 &'cross-section.'/
8140 &1X,'Execution will stop if you try to generate events.')
8141
8142 RETURN
8143 END
8144
8145C*********************************************************************
8146
8147C...PYPILE
8148C...Initializes multiplicity distribution and selects mutliplicity
8149C...of pileup events, i.e. several events occuring at the same
8150C...beam crossing.
8151
8152 SUBROUTINE PYPILE(MPILE)
8153
8154C...Double precision and integer declarations.
8155 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8156 IMPLICIT INTEGER(I-N)
8157 INTEGER PYK,PYCHGE,PYCOMP
8158C...Commonblocks.
8159 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8160 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8161 COMMON/PYINT1/MINT(400),VINT(400)
8162 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8163 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8164C...Local arrays and saved variables.
8165 DIMENSION WTI(0:200)
8166 SAVE IMIN,IMAX,WTI,WTS
8167
8168C...Sum of allowed cross-sections for pileup events.
8169 IF(MPILE.EQ.1) THEN
8170 VINT(131)=SIGT(0,0,5)
8171 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8172 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8173 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8174 IF(MSTP(133).LE.0) RETURN
8175
8176C...Initialize multiplicity distribution at maximum.
8177 XNAVE=VINT(131)*PARP(131)
8178 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8179 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8180 WTI(INAVE)=1D0
8181 WTS=WTI(INAVE)
8182 WTN=WTI(INAVE)*INAVE
8183
8184C...Find shape of multiplicity distribution below maximum.
8185 IMIN=INAVE
8186 DO 100 I=INAVE-1,1,-1
8187 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8188 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8189 IF(WTI(I).LT.1D-6) GOTO 110
8190 WTS=WTS+WTI(I)
8191 WTN=WTN+WTI(I)*I
8192 IMIN=I
8193 100 CONTINUE
8194
8195C...Find shape of multiplicity distribution above maximum.
8196 110 IMAX=INAVE
8197 DO 120 I=INAVE+1,200
8198 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8199 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8200 IF(WTI(I).LT.1D-6) GOTO 130
8201 WTS=WTS+WTI(I)
8202 WTN=WTN+WTI(I)*I
8203 IMAX=I
8204 120 CONTINUE
8205 130 VINT(132)=XNAVE
8206 VINT(133)=WTN/WTS
8207 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8208 & WTS/(WTS+WTI(1)/XNAVE)
8209 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8210 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8211
8212C...Pick multiplicity of pileup events.
8213 ELSE
8214 IF(MSTP(133).LE.0) THEN
8215 MINT(81)=MAX(1,MSTP(134))
8216 ELSE
8217 WTR=WTS*PYR(0)
8218 DO 140 I=IMIN,IMAX
8219 MINT(81)=I
8220 WTR=WTR-WTI(I)
8221 IF(WTR.LE.0D0) GOTO 150
8222 140 CONTINUE
8223 150 CONTINUE
8224 ENDIF
8225 ENDIF
8226
8227C...Format statement for error message.
8228 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8229 &'crossing too large, ',1P,D12.4)
8230
8231 RETURN
8232 END
8233
8234C*********************************************************************
8235
8236C...PYSAVE
8237C...Saves and restores parameter and cross section values for the
8238C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8239C...Also makes random choice between alternatives.
8240
8241 SUBROUTINE PYSAVE(ISAVE,IGA)
8242
8243C...Double precision and integer declarations.
8244 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8245 IMPLICIT INTEGER(I-N)
8246 INTEGER PYK,PYCHGE,PYCOMP
8247C...Commonblocks.
8248 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8249 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8250 COMMON/PYINT1/MINT(400),VINT(400)
8251 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8252 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8253 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8254 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8255C...Local arrays and saved variables.
8256 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8257 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8258 &INTCP(15,20),RECP(15,20)
8259 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8260
8261C...Save list of subprocesses and cross-section information.
8262 IF(ISAVE.EQ.1) THEN
8263 ICP=0
8264 DO 120 I=1,500
8265 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8266 ICP=ICP+1
8267 NSUBCP(IGA,ICP)=I
8268 MSUBCP(IGA,ICP)=MSUB(I)
8269 DO 100 J=1,20
8270 COEFCP(IGA,ICP,J)=COEF(I,J)
8271 100 CONTINUE
8272 DO 110 J=1,3
8273 NGENCP(IGA,ICP,J)=NGEN(I,J)
8274 XSECCP(IGA,ICP,J)=XSEC(I,J)
8275 110 CONTINUE
8276 120 CONTINUE
8277 NCP(IGA)=ICP
8278 DO 130 J=1,3
8279 NGENCP(IGA,0,J)=NGEN(0,J)
8280 XSECCP(IGA,0,J)=XSEC(0,J)
8281 130 CONTINUE
8282 DO 160 I1=0,6
8283 DO 150 I2=0,6
8284 DO 140 J=0,5
8285 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8286 140 CONTINUE
8287 150 CONTINUE
8288 160 CONTINUE
8289
8290C...Save various common process variables.
8291 DO 170 J=1,10
8292 INTCP(IGA,J)=MINT(40+J)
8293 170 CONTINUE
8294 INTCP(IGA,11)=MINT(101)
8295 INTCP(IGA,12)=MINT(102)
8296 INTCP(IGA,13)=MINT(107)
8297 INTCP(IGA,14)=MINT(108)
8298 INTCP(IGA,15)=MINT(123)
8299 RECP(IGA,1)=CKIN(3)
8300 RECP(IGA,2)=VINT(318)
8301
8302C...Save cross-section information only.
8303 ELSEIF(ISAVE.EQ.2) THEN
8304 DO 190 ICP=1,NCP(IGA)
8305 I=NSUBCP(IGA,ICP)
8306 DO 180 J=1,3
8307 NGENCP(IGA,ICP,J)=NGEN(I,J)
8308 XSECCP(IGA,ICP,J)=XSEC(I,J)
8309 180 CONTINUE
8310 190 CONTINUE
8311 DO 200 J=1,3
8312 NGENCP(IGA,0,J)=NGEN(0,J)
8313 XSECCP(IGA,0,J)=XSEC(0,J)
8314 200 CONTINUE
8315
8316C...Choose between allowed alternatives.
8317 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8318 IF(ISAVE.EQ.4) THEN
8319 XSUMCP=0D0
8320 DO 210 IG=1,MINT(121)
8321 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8322 210 CONTINUE
8323 XSUMCP=XSUMCP*PYR(0)
8324 DO 220 IG=1,MINT(121)
8325 IGA=IG
8326 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8327 IF(XSUMCP.LE.0D0) GOTO 230
8328 220 CONTINUE
8329 230 CONTINUE
8330 ENDIF
8331
8332C...Restore cross-section information.
8333 DO 240 I=1,500
8334 MSUB(I)=0
8335 240 CONTINUE
8336 DO 270 ICP=1,NCP(IGA)
8337 I=NSUBCP(IGA,ICP)
8338 MSUB(I)=MSUBCP(IGA,ICP)
8339 DO 250 J=1,20
8340 COEF(I,J)=COEFCP(IGA,ICP,J)
8341 250 CONTINUE
8342 DO 260 J=1,3
8343 NGEN(I,J)=NGENCP(IGA,ICP,J)
8344 XSEC(I,J)=XSECCP(IGA,ICP,J)
8345 260 CONTINUE
8346 270 CONTINUE
8347 DO 280 J=1,3
8348 NGEN(0,J)=NGENCP(IGA,0,J)
8349 XSEC(0,J)=XSECCP(IGA,0,J)
8350 280 CONTINUE
8351 DO 310 I1=0,6
8352 DO 300 I2=0,6
8353 DO 290 J=0,5
8354 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8355 290 CONTINUE
8356 300 CONTINUE
8357 310 CONTINUE
8358
8359C...Restore various common process variables.
8360 DO 320 J=1,10
8361 MINT(40+J)=INTCP(IGA,J)
8362 320 CONTINUE
8363 MINT(101)=INTCP(IGA,11)
8364 MINT(102)=INTCP(IGA,12)
8365 MINT(107)=INTCP(IGA,13)
8366 MINT(108)=INTCP(IGA,14)
8367 MINT(123)=INTCP(IGA,15)
8368 CKIN(3)=RECP(IGA,1)
8369 CKIN(1)=2D0*CKIN(3)
8370 VINT(318)=RECP(IGA,2)
8371
8372C...Sum up cross-section info (for PYSTAT).
8373 ELSEIF(ISAVE.EQ.5) THEN
8374 DO 330 I=1,500
8375 MSUB(I)=0
8376 NGEN(I,1)=0
8377 NGEN(I,3)=0
8378 XSEC(I,3)=0D0
8379 330 CONTINUE
8380 NGEN(0,1)=0
8381 NGEN(0,2)=0
8382 NGEN(0,3)=0
8383 XSEC(0,3)=0
8384 DO 350 IG=1,MINT(121)
8385 DO 340 ICP=1,NCP(IG)
8386 I=NSUBCP(IG,ICP)
8387 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8388 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8389 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8390 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8391 340 CONTINUE
8392 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8393 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8394 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8395 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8396 350 CONTINUE
8397 ENDIF
8398
8399 RETURN
8400 END
8401
8402C*********************************************************************
8403
8404C...PYGAGA
8405C...For lepton beams it gives photon-hadron or photon-photon systems
8406C...to be treated with the ordinary machinery and combines this with a
8407C...description of the lepton -> lepton + photon branching.
8408
8409 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8410
8411C...Double precision and integer declarations.
8412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8413 IMPLICIT INTEGER(I-N)
8414 INTEGER PYK,PYCHGE,PYCOMP
8415C...Commonblocks.
8416 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8417 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8418 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8419 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8420 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8421 COMMON/PYINT1/MINT(400),VINT(400)
8422 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8423 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8424 &/PYINT5/
8425C...Local variables and data statement.
8426 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8427 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8428 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8429 DATA EPS/1D-4/
8430
8431C...Initialize generation of photons inside leptons.
8432 IF(IGAGA.EQ.1) THEN
8433
8434C...Save quantities on incoming lepton system.
8435 VINT(301)=VINT(1)
8436 VINT(302)=VINT(2)
8437 PMS(1)=VINT(303)**2
8438 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8439 PMS(2)=VINT(304)**2
8440 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8441 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8442 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8443
8444C...Calculate range of x and Q2 values allowed in generation.
8445 DO 100 I=1,2
8446 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8447 IF(MINT(140+I).NE.0) THEN
8448 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8449 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8450 & PMC(I),1D0-EPS)
8451 YMIN=MAX(CKIN(71+2*I),EPS)
8452 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8453 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8454 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8455 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8456 THEMIN=MAX(CKIN(67+2*I),0D0)
8457 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8458 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8459 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8460 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8461 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8462 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8463 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8464 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8465 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8466C...W limits when lepton on one side only.
8467 IF(MINT(143-I).EQ.0) THEN
8468 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8469 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8470 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8471 ENDIF
8472 ENDIF
8473 100 CONTINUE
8474
8475C...W limits when lepton on both sides.
8476 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8477 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8478 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8479 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8480 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8481 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8482 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8483 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8484 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8485 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8486 ELSE
8487 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8488 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8489 ENDIF
8490 ENDIF
8491
8492C...Q2 and W values and photon flux weight factors for initialization.
8493 ELSEIF(IGAGA.EQ.2) THEN
8494 ISUB=MINT(1)
8495 MINT(15)=0
8496 MINT(16)=0
8497
8498C...W value for photon on one or both sides, and for processes
8499C...with gamma-gamma cross section peaked at small shat.
8500 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8501 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8502 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8503 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8504 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8505 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8506 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8507 ELSE
8508 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8509 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8510 ENDIF
8511 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8512
8513C...Upper estimate of photon flux weight factor.
8514C...Initialization Q2 scale. Flag incoming unresolved photon.
8515 WTGAGA=1D0
8516 DO 110 I=1,2
8517 IF(MINT(140+I).NE.0) THEN
8518 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8519 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8520 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8521 & THEN
8522 Q2INIT=5D0+Q2MIN(3-I)
8523 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8524 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8525 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8526 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8527 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8528 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8529 Q2INIT=VINT(2)/3D0
8530 ELSEIF(ISUB.EQ.140) THEN
8531 Q2INIT=VINT(2)/2D0
8532 ELSE
8533 Q2INIT=Q2MIN(I)
8534 ENDIF
8535 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8536 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8537 & MINT(14+I)=22
8538 VINT(306+I)=VINT(2+I)**2
8539 ENDIF
8540 110 CONTINUE
8541 VINT(320)=WTGAGA
8542
8543C...Update pTmin and cross section information.
8544 IF(MSTP(82).LE.1) THEN
8545 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8546 ELSE
8547 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8548 ENDIF
8549 VINT(149)=4D0*PTMN**2/VINT(2)
8550 VINT(154)=PTMN
8551 CALL PYXTOT
8552 VINT(318)=VINT(317)
8553
8554C...Generate photons inside leptons and
8555C...calculate photon flux weight factors.
8556 ELSEIF(IGAGA.EQ.3) THEN
8557 ISUB=MINT(1)
8558 MINT(15)=0
8559 MINT(16)=0
8560
8561C...Generate phase space point and check against cuts.
8562 LOOP=0
8563 120 LOOP=LOOP+1
8564 DO 130 I=1,2
8565 IF(MINT(140+I).NE.0) THEN
8566C...Pick x and Q2
8567 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8568 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8569C...Cuts on internal consistency in x and Q2.
8570 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8571 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8572 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8573C...Cuts on y and theta.
8574 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8575 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8576 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8577 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8578 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8579 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8580 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8581 & GOTO 120
8582
8583C...Phi angle isotropic. Reconstruct pT.
8584 PHI(I)=PARU(2)*PYR(0)
8585 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8586 & PMS(I))*SIN(THETA(I))
8587
8588C...Store info on variables selected, for documentation purposes.
8589 VINT(2+I)=-SQRT(Q2(I))
8590 VINT(304+I)=X(I)
8591 VINT(306+I)=Q2(I)
8592 VINT(308+I)=Y(I)
8593 VINT(310+I)=THETA(I)
8594 VINT(312+I)=PHI(I)
8595 ELSE
8596 VINT(304+I)=1D0
8597 VINT(306+I)=0D0
8598 VINT(308+I)=1D0
8599 VINT(310+I)=0D0
8600 VINT(312+I)=0D0
8601 ENDIF
8602 130 CONTINUE
8603
8604C...Cut on W combines info from two sides.
8605 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8606 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8607 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8608 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8609 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8610 IF(W2.LT.W2MIN) GOTO 120
8611 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8612 PMS1=-Q2(1)
8613 PMS2=-Q2(2)
8614 ELSEIF(MINT(141).NE.0) THEN
8615 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8616 PMS1=-Q2(1)
8617 PMS2=PMS(2)
8618 ELSEIF(MINT(142).NE.0) THEN
8619 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8620 PMS1=PMS(1)
8621 PMS2=-Q2(2)
8622 ENDIF
8623
8624C...Store kinematics info for photon(s) in subsystem cm frame.
8625 VINT(2)=W2
8626 VINT(1)=SQRT(W2)
8627 VINT(291)=0D0
8628 VINT(292)=0D0
8629 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8630 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8631 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8632 VINT(296)=0D0
8633 VINT(297)=0D0
8634 VINT(298)=-VINT(293)
8635 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8636 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8637
8638C...Assign weight for photon flux; different for transverse and
8639C...longitudinal photons. Flag incoming unresolved photon.
8640 WTGAGA=1D0
8641 DO 140 I=1,2
8642 IF(MINT(140+I).NE.0) THEN
8643 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8644 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8645 IF(MSTP(16).EQ.0) THEN
8646 XY=X(I)
8647 ELSE
8648 WTGAGA=WTGAGA*X(I)/Y(I)
8649 XY=Y(I)
8650 ENDIF
8651 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8652 WTGAGA=WTGAGA*(1D0-XY)
8653 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8654 WTGAGA=WTGAGA*(1D0-XY)
8655 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8656 WTGAGA=WTGAGA*(1D0-XY)
8657 ELSE
8658 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8659 & PMS(I)*XY**2/Q2(I))
8660 ENDIF
8661 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8662 ENDIF
8663 140 CONTINUE
8664 VINT(319)=WTGAGA
8665 MINT(143)=LOOP
8666
8667C...Update pTmin and cross section information.
8668 IF(MSTP(82).LE.1) THEN
8669 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8670 ELSE
8671 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8672 ENDIF
8673 VINT(149)=4D0*PTMN**2/VINT(2)
8674 VINT(154)=PTMN
8675 CALL PYXTOT
8676
8677C...Reconstruct kinematics of photons inside leptons.
8678 ELSEIF(IGAGA.EQ.4) THEN
8679
8680C...Make place for incoming particles and scattered leptons.
8681 MOVE=3
8682 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8683 MINT(4)=MINT(4)+MOVE
8684 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8685 IF(K(I,1).EQ.21) THEN
8686 DO 150 J=1,5
8687 K(I+MOVE,J)=K(I,J)
8688 P(I+MOVE,J)=P(I,J)
8689 V(I+MOVE,J)=V(I,J)
8690 150 CONTINUE
8691 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8692 & K(I+MOVE,3)=K(I,3)+MOVE
8693 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8694 & K(I+MOVE,4)=K(I,4)+MOVE
8695 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8696 & K(I+MOVE,5)=K(I,5)+MOVE
8697 ENDIF
8698 160 CONTINUE
8699 DO 170 I=MINT(84)+1,N
8700 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8701 & K(I,3)=K(I,3)+MOVE
8702 170 CONTINUE
8703
8704C...Fill in incoming particles.
8705 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8706 DO 180 J=1,5
8707 K(I,J)=0
8708 P(I,J)=0D0
8709 V(I,J)=0D0
8710 180 CONTINUE
8711 190 CONTINUE
8712 DO 200 I=1,2
8713 K(MINT(83)+I,1)=21
8714 IF(MINT(140+I).NE.0) THEN
8715 K(MINT(83)+I,2)=MINT(140+I)
8716 P(MINT(83)+I,5)=VINT(302+I)
8717 ELSE
8718 K(MINT(83)+I,2)=MINT(10+I)
8719 P(MINT(83)+I,5)=VINT(2+I)
8720 ENDIF
8721 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8722 & VINT(302))*(-1D0)**(I+1)
8723 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8724 200 CONTINUE
8725
8726C...New mother-daughter relations in documentation section.
8727 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8728 K(MINT(83)+1,4)=MINT(83)+3
8729 K(MINT(83)+1,5)=MINT(83)+5
8730 K(MINT(83)+2,4)=MINT(83)+4
8731 K(MINT(83)+2,5)=MINT(83)+6
8732 K(MINT(83)+3,3)=MINT(83)+1
8733 K(MINT(83)+5,3)=MINT(83)+1
8734 K(MINT(83)+4,3)=MINT(83)+2
8735 K(MINT(83)+6,3)=MINT(83)+2
8736 ELSEIF(MINT(141).NE.0) THEN
8737 K(MINT(83)+1,4)=MINT(83)+3
8738 K(MINT(83)+1,5)=MINT(83)+4
8739 K(MINT(83)+2,4)=MINT(83)+5
8740 K(MINT(83)+3,3)=MINT(83)+1
8741 K(MINT(83)+4,3)=MINT(83)+1
8742 K(MINT(83)+5,3)=MINT(83)+2
8743 ELSEIF(MINT(142).NE.0) THEN
8744 K(MINT(83)+1,4)=MINT(83)+4
8745 K(MINT(83)+2,4)=MINT(83)+3
8746 K(MINT(83)+2,5)=MINT(83)+5
8747 K(MINT(83)+3,3)=MINT(83)+2
8748 K(MINT(83)+4,3)=MINT(83)+1
8749 K(MINT(83)+5,3)=MINT(83)+2
8750 ENDIF
8751
8752C...Fill scattered lepton(s).
8753 DO 210 I=1,2
8754 IF(MINT(140+I).NE.0) THEN
8755 LSC=MINT(83)+MIN(I+2,MOVE)
8756 K(LSC,1)=21
8757 K(LSC,2)=MINT(140+I)
8758 P(LSC,1)=PT(I)*COS(PHI(I))
8759 P(LSC,2)=PT(I)*SIN(PHI(I))
8760 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
8761 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
8762 & (-1D0)**(I-1)
8763 P(LSC,5)=VINT(302+I)
8764 ENDIF
8765 210 CONTINUE
8766
8767C...Find incoming four-vectors to subprocess.
8768 K(N+1,1)=21
8769 IF(MINT(141).NE.0) THEN
8770 DO 220 J=1,4
8771 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
8772 220 CONTINUE
8773 ELSE
8774 DO 230 J=1,4
8775 P(N+1,J)=P(MINT(83)+1,J)
8776 230 CONTINUE
8777 ENDIF
8778 K(N+2,1)=21
8779 IF(MINT(142).NE.0) THEN
8780 DO 240 J=1,4
8781 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
8782 240 CONTINUE
8783 ELSE
8784 DO 250 J=1,4
8785 P(N+2,J)=P(MINT(83)+2,J)
8786 250 CONTINUE
8787 ENDIF
8788
8789C...Define boost and rotation between hadronic subsystem and
8790C...collision rest frame; boost hadronic subsystem to this frame.
8791 DO 260 J=1,3
8792 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
8793 260 CONTINUE
8794 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
8795 BPHI=PYANGL(P(N+1,1),P(N+1,2))
8796 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
8797 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
8798 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
8799 & BETA(3))
8800
8801C...Add on scattered leptons to final state.
8802 DO 280 I=1,2
8803 IF(MINT(140+I).NE.0) THEN
8804 LSC=MINT(83)+MIN(I+2,MOVE)
8805 N=N+1
8806 DO 270 J=1,5
8807 K(N,J)=K(LSC,J)
8808 P(N,J)=P(LSC,J)
8809 V(N,J)=V(LSC,J)
8810 270 CONTINUE
8811 K(N,1)=1
8812 K(N,3)=LSC
8813 ENDIF
8814 280 CONTINUE
8815 ENDIF
8816
8817 RETURN
8818 END
8819
8820C*********************************************************************
8821
8822C...PYRAND
8823C...Generates quantities characterizing the high-pT scattering at the
8824C...parton level according to the matrix elements. Chooses incoming,
8825C...reacting partons, their momentum fractions and one of the possible
8826C...subprocesses.
8827
8828 SUBROUTINE PYRAND
8829
8830C...Double precision and integer declarations.
8831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8832 IMPLICIT INTEGER(I-N)
8833 INTEGER PYK,PYCHGE,PYCOMP
8834C...Parameter statement to help give large particle numbers.
8835 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
8836 &KEXCIT=4000000,KDIMEN=5000000)
8837
8838C...User process initialization and event commonblocks.
8839 INTEGER MAXPUP
8840 PARAMETER (MAXPUP=100)
8841 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
8842 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
8843 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
8844 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
8845 &LPRUP(MAXPUP)
8846 INTEGER MAXNUP
8847 PARAMETER (MAXNUP=500)
8848 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
8849 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
8850 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
8851 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
8852 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
8853 SAVE /HEPRUP/,/HEPEUP/
8854
8855C...Commonblocks.
8856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8858 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
8859 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8860 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8861 COMMON/PYINT1/MINT(400),VINT(400)
8862 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8863 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
8864 COMMON/PYINT4/MWID(500),WIDS(500,5)
8865 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8866 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8867 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
8868 COMMON/PYTCCO/COEFX(194:380,2)
8869 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
8870 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
8871 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
8872 &/TCPARA/
8873C...Local arrays.
8874 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
8875
8876C...Parameters and data used in elastic/diffractive treatment.
8877 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
8878 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
8879
8880C...Initial values, specifically for (first) semihard interaction.
8881 MINT(10)=0
8882 MINT(17)=0
8883 MINT(18)=0
8884 VINT(143)=1D0
8885 VINT(144)=1D0
8886 VINT(157)=0D0
8887 VINT(158)=0D0
8888 MFAIL=0
8889 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
8890 ISUB=0
8891 ISTSB=0
8892 LOOP=0
8893 100 LOOP=LOOP+1
8894 MINT(51)=0
8895 MINT(143)=1
8896 VINT(97)=1D0
8897
8898C...Start by assuming incoming photon is entering subprocess.
8899 IF(MINT(11).EQ.22) THEN
8900 MINT(15)=22
8901 VINT(307)=VINT(3)**2
8902 ENDIF
8903 IF(MINT(12).EQ.22) THEN
8904 MINT(16)=22
8905 VINT(308)=VINT(4)**2
8906 ENDIF
8907 MINT(103)=MINT(11)
8908 MINT(104)=MINT(12)
8909
8910C...Choice of process type - first event of pileup.
8911 INMULT=0
8912 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
8913 ELSEIF(MINT(82).EQ.1) THEN
8914
8915C...For gamma-p or gamma-gamma first pick between alternatives.
8916 IGA=0
8917 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
8918 MINT(122)=IGA
8919
8920C...For real gamma + gamma with different nature, flip at random.
8921 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
8922 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
8923 MINTSV=MINT(41)
8924 MINT(41)=MINT(42)
8925 MINT(42)=MINTSV
8926 MINTSV=MINT(45)
8927 MINT(45)=MINT(46)
8928 MINT(46)=MINTSV
8929 MINTSV=MINT(107)
8930 MINT(107)=MINT(108)
8931 MINT(108)=MINTSV
8932 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
8933 ENDIF
8934
8935C...Pick process type, possibly by user process machinery.
8936C...(If the latter, also event will be picked here.)
8937 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
8938 CALL UPEVNT
8939 CALL PYUPRE
8940 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
8941 CALL UPEVNT
8942 CALL PYUPRE
8943 ISUB=0
8944 110 ISUB=ISUB+1
8945 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
8946 & ISUB.LT.500) GOTO 110
8947 ELSE
8948 RSUB=XSEC(0,1)*PYR(0)
8949 DO 120 I=1,500
8950 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
8951 ISUB=I
8952 RSUB=RSUB-XSEC(I,1)
8953 IF(RSUB.LE.0D0) GOTO 130
8954 120 CONTINUE
8955 130 IF(ISUB.EQ.95) ISUB=96
8956 IF(ISUB.EQ.96) INMULT=1
8957 IF(ISET(ISUB).EQ.11) THEN
8958 IDPRUP=KFPR(ISUB,2)
8959 CALL UPEVNT
8960 CALL PYUPRE
8961 ENDIF
8962 ENDIF
8963
8964C...Choice of inclusive process type - pileup events.
8965 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
8966 RSUB=VINT(131)*PYR(0)
8967 ISUB=96
8968 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
8969 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
8970 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
8971 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
8972 & ISUB=91
8973 IF(ISUB.EQ.96) INMULT=1
8974 ENDIF
8975
8976C...Choice of photon energy and flux factor inside lepton.
8977 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
8978 CALL PYGAGA(3,WTGAGA)
8979 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
8980 CKIN(3)=MAX(VINT(285),VINT(154))
8981 CKIN(1)=2D0*CKIN(3)
8982 ENDIF
8983C...When necessary set direct/resolved photon by hand.
8984 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
8985 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
8986 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
8987 ENDIF
8988
8989C...Restrict direct*resolved processes to pTmin >= Q,
8990C...to avoid doublecounting with DIS.
8991 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
8992 IF(MINT(15).EQ.22) THEN
8993 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
8994 ELSE
8995 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
8996 ENDIF
8997 CKIN(1)=2D0*CKIN(3)
8998 ENDIF
8999
9000C...Set up for multiple interactions (may include impact parameter).
9001 IF(INMULT.EQ.1) THEN
9002 IF(MINT(35).LE.1) CALL PYMULT(2)
9003 IF(MINT(35).GE.2) CALL PYMIGN(2)
9004 ENDIF
9005
9006C...Loopback point for minimum bias in photon physics.
9007 LOOP2=0
9008 140 LOOP2=LOOP2+1
9009 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9010 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9011 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9012 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9013 MINT(1)=ISUB
9014 ISTSB=ISET(ISUB)
9015
9016C...Random choice of flavour for some SUSY processes.
9017 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9018C...~e_L ~nu_e or ~mu_L ~nu_mu.
9019 IF(ISUB.EQ.210) THEN
9020 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9021 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9022C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9023 ELSEIF(ISUB.EQ.213) THEN
9024 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9025 KFPR(ISUB,2)=KFPR(ISUB,1)
9026C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9027 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9028 & ISUB.NE.257) THEN
9029 IF(ISUB.GE.258) THEN
9030 RKF=4D0
9031 ELSE
9032 RKF=5D0
9033 ENDIF
9034 IF(MOD(ISUB,2).EQ.0) THEN
9035 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9036 ELSE
9037 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9038 ENDIF
9039C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9040 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9041 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9042 KSU1=KSUSY1
9043 KSU2=KSUSY1
9044 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9045 KSU1=KSUSY2
9046 KSU2=KSUSY2
9047 ELSEIF(PYR(0).LT.0.5D0) THEN
9048 KSU1=KSUSY1
9049 KSU2=KSUSY2
9050 ELSE
9051 KSU1=KSUSY2
9052 KSU2=KSUSY1
9053 ENDIF
9054 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9055 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9056C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9057 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9058 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9059 KFPR(ISUB,2)=KFPR(ISUB,1)
9060 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9061 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9062 KFPR(ISUB,2)=KFPR(ISUB,1)
9063C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9064 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9065 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9066 KSU1=KSUSY1
9067 KSU2=KSUSY1
9068 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9069 KSU1=KSUSY2
9070 KSU2=KSUSY2
9071 ELSEIF(PYR(0).LT.0.5D0) THEN
9072 KSU1=KSUSY1
9073 KSU2=KSUSY2
9074 ELSE
9075 KSU1=KSUSY2
9076 KSU2=KSUSY1
9077 ENDIF
9078 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9079 RKF=5D0
9080 ELSE
9081 RKF=4D0
9082 ENDIF
9083 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9084 ENDIF
9085 ENDIF
9086
9087C...Find resonances (explicit or implicit in cross-section).
9088 MINT(72)=0
9089 KFR1=0
9090 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9091 KFR1=KFPR(ISUB,1)
9092 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9093 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9094 KFR1=23
9095 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9096 & ISUB.EQ.177) THEN
9097 KFR1=24
9098 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9099 KFR1=25
9100 IF(MSTP(46).EQ.5) THEN
9101 KFR1=89
9102 PMAS(89,1)=PARP(45)
9103 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9104 ENDIF
9105 ENDIF
9106 CKMX=CKIN(2)
9107 IF(CKMX.LE.0D0) CKMX=VINT(1)
9108 KCR1=PYCOMP(KFR1)
9109 IF(KFR1.NE.0) THEN
9110 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9111 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9112 ENDIF
9113 IF(KFR1.NE.0) THEN
9114 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9115 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9116 MINT(72)=1
9117 MINT(73)=KFR1
9118 VINT(73)=TAUR1
9119 VINT(74)=GAMR1
9120 ENDIF
9121 KFR2=0
9122 KFR3=0
9123 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9124 $(ISUB.GE.361.AND.ISUB.LE.380))
9125 $THEN
9126 KFR2=23
9127 IF(ISUB.EQ.141) THEN
9128 KCR2=PYCOMP(KFR2)
9129 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9130 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9131 KFR2=0
9132 ELSE
9133 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9134 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9135 MINT(72)=2
9136 MINT(74)=KFR2
9137 VINT(75)=TAUR2
9138 VINT(76)=GAMR2
9139 ENDIF
9140C...3 resonances at work: rho, omega, a
9141 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9142 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9143 MINT(72)=IRES
9144 IF(IRES.GE.1) THEN
9145 VINT(73)=XMAS(1)**2/VINT(2)
9146 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9147 TAUR1=VINT(73)
9148 GAMR1=VINT(74)
9149 KFR1=1
9150 ENDIF
9151 IF(IRES.GE.2) THEN
9152 VINT(75)=XMAS(2)**2/VINT(2)
9153 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9154 TAUR2=VINT(75)
9155 GAMR2=VINT(76)
9156 KFR2=2
9157 ENDIF
9158 IF(IRES.EQ.3) THEN
9159 VINT(77)=XMAS(3)**2/VINT(2)
9160 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9161 TAUR3=VINT(77)
9162 GAMR3=VINT(78)
9163 KFR3=3
9164 ENDIF
9165C...Charged current: rho+- and a+-
9166 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9167 MINT(72)=IRES
9168 IF(JRES.GE.1) THEN
9169 VINT(73)=YMAS(1)**2/VINT(2)
9170 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9171 KFR1=1
9172 TAUR1=VINT(73)
9173 GAMR1=VINT(74)
9174 ENDIF
9175 IF(JRES.GE.2) THEN
9176 VINT(75)=YMAS(2)**2/VINT(2)
9177 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9178 KFR2=2
9179 TAUR2=VINT(73)
9180 GAMR2=VINT(74)
9181 ENDIF
9182 KFR3=0
9183 ENDIF
9184 IF(ISUB.NE.141) THEN
9185 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9186
9187 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9188 MINT(72)=2
9189 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9190 MINT(72)=2
9191 MINT(74)=KFR3
9192 VINT(75)=TAUR3
9193 VINT(76)=GAMR3
9194 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9195 MINT(72)=2
9196 MINT(73)=KFR2
9197 VINT(73)=TAUR2
9198 VINT(74)=GAMR2
9199 MINT(74)=KFR3
9200 VINT(75)=TAUR3
9201 VINT(76)=GAMR3
9202 ELSEIF(KFR1.NE.0) THEN
9203 MINT(72)=1
9204 ELSEIF(KFR2.NE.0) THEN
9205 MINT(72)=1
9206 MINT(73)=KFR2
9207 VINT(73)=TAUR2
9208 VINT(74)=GAMR2
9209 ELSEIF(KFR3.NE.0) THEN
9210 MINT(72)=1
9211 MINT(73)=KFR3
9212 VINT(73)=TAUR3
9213 VINT(74)=GAMR3
9214 ELSE
9215 MINT(72)=0
9216 ENDIF
9217 ELSE
9218 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9219
9220 ELSEIF(KFR2.NE.0) THEN
9221 KFR1=KFR2
9222 TAUR1=TAUR2
9223 GAMR1=GAMR2
9224 MINT(72)=1
9225 MINT(73)=KFR1
9226 VINT(73)=TAUR1
9227 VINT(74)=GAMR1
9228 KFR2=0
9229 ELSE
9230 MINT(72)=0
9231 ENDIF
9232 ENDIF
9233 ENDIF
9234
9235C...Find product masses and minimum pT of process,
9236C...optionally with broadening according to a truncated Breit-Wigner.
9237 VINT(63)=0D0
9238 VINT(64)=0D0
9239 MINT(71)=0
9240 VINT(71)=CKIN(3)
9241 IF(MINT(82).GE.2) VINT(71)=0D0
9242 VINT(80)=1D0
9243 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9244 NBW=0
9245 DO 160 I=1,2
9246 PMMN(I)=0D0
9247 IF(KFPR(ISUB,I).EQ.0) THEN
9248 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9249 & PARP(41)) THEN
9250 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9251 ELSE
9252 NBW=NBW+1
9253C...This prevents SUSY/t particles from becoming too light.
9254 KFLW=KFPR(ISUB,I)
9255 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9256 KCW=PYCOMP(KFLW)
9257 PMMN(I)=PMAS(KCW,1)
9258 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9259 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9260 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9261 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9262 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9263 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9264 PMMN(I)=MIN(PMMN(I),PMSUM)
9265 ENDIF
9266 150 CONTINUE
9267 ELSEIF(KFLW.EQ.6) THEN
9268 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9269 ENDIF
9270 ENDIF
9271 160 CONTINUE
9272 IF(NBW.GE.1) THEN
9273 CKIN41=CKIN(41)
9274 CKIN43=CKIN(43)
9275 CKIN(41)=MAX(PMMN(1),CKIN(41))
9276 CKIN(43)=MAX(PMMN(2),CKIN(43))
9277 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9278 CKIN(41)=CKIN41
9279 CKIN(43)=CKIN43
9280 IF(MINT(51).EQ.1) THEN
9281 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9282 IF(MFAIL.EQ.1) THEN
9283 MSTI(61)=1
9284 RETURN
9285 ENDIF
9286 GOTO 100
9287 ENDIF
9288 VINT(63)=PQM3**2
9289 VINT(64)=PQM4**2
9290 ENDIF
9291 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9292 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9293 ENDIF
9294
9295C...Prepare for additional variable choices in 2 -> 3.
9296 IF(ISTSB.EQ.5) THEN
9297 VINT(201)=0D0
9298 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9299 VINT(206)=VINT(201)
9300 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9301 VINT(204)=PMAS(23,1)
9302 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9303 & VINT(204)=PMAS(24,1)
9304 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9305 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9306 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9307 & VINT(204)=VINT(201)
9308 VINT(209)=VINT(204)
9309 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9310 ENDIF
9311
9312C...Select incoming VDM particle (rho/omega/phi/J/psi).
9313 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9314 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9315 VRN=PYR(0)*SIGT(0,0,5)
9316 IF(MINT(101).LE.1) THEN
9317 I1MN=0
9318 I1MX=0
9319 ELSE
9320 I1MN=1
9321 I1MX=MINT(101)
9322 ENDIF
9323 IF(MINT(102).LE.1) THEN
9324 I2MN=0
9325 I2MX=0
9326 ELSE
9327 I2MN=1
9328 I2MX=MINT(102)
9329 ENDIF
9330 DO 180 I1=I1MN,I1MX
9331 KFV1=110*I1+3
9332 DO 170 I2=I2MN,I2MX
9333 KFV2=110*I2+3
9334 VRN=VRN-SIGT(I1,I2,5)
9335 IF(VRN.LE.0D0) GOTO 190
9336 170 CONTINUE
9337 180 CONTINUE
9338 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9339 IF(MINT(102).GE.2) MINT(104)=KFV2
9340 ENDIF
9341
9342 IF(ISTSB.EQ.0) THEN
9343C...Elastic scattering or single or double diffractive scattering.
9344
9345C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9346 MINT(103)=MINT(11)
9347 MINT(104)=MINT(12)
9348 PMM(1)=VINT(3)
9349 PMM(2)=VINT(4)
9350 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9351 JJ=ISUB-90
9352 VRN=PYR(0)*SIGT(0,0,JJ)
9353 IF(MINT(101).LE.1) THEN
9354 I1MN=0
9355 I1MX=0
9356 ELSE
9357 I1MN=1
9358 I1MX=MINT(101)
9359 ENDIF
9360 IF(MINT(102).LE.1) THEN
9361 I2MN=0
9362 I2MX=0
9363 ELSE
9364 I2MN=1
9365 I2MX=MINT(102)
9366 ENDIF
9367 DO 210 I1=I1MN,I1MX
9368 KFV1=110*I1+3
9369 DO 200 I2=I2MN,I2MX
9370 KFV2=110*I2+3
9371 VRN=VRN-SIGT(I1,I2,JJ)
9372 IF(VRN.LE.0D0) GOTO 220
9373 200 CONTINUE
9374 210 CONTINUE
9375 220 IF(MINT(101).GE.2) THEN
9376 MINT(103)=KFV1
9377 PMM(1)=PYMASS(KFV1)
9378 ENDIF
9379 IF(MINT(102).GE.2) THEN
9380 MINT(104)=KFV2
9381 PMM(2)=PYMASS(KFV2)
9382 ENDIF
9383 ENDIF
9384 VINT(67)=PMM(1)
9385 VINT(68)=PMM(2)
9386
9387C...Select mass for GVMD states (rejecting previous assignment).
9388 Q0S=4D0*PARP(15)**2
9389 Q1S=4D0*VINT(154)**2
9390 LOOP3=0
9391 230 LOOP3=LOOP3+1
9392 DO 240 JT=1,2
9393 IF(MINT(106+JT).EQ.3) THEN
9394 PS=VINT(2+JT)**2
9395 PMM(JT)=(Q0S+PS)*(Q1S+PS)/
9396 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
9397 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9398 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9399 ENDIF
9400 240 CONTINUE
9401 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9402 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9403 & GOTO 230
9404 GOTO 100
9405 ENDIF
9406
9407C...Side/sides of diffractive system.
9408 MINT(17)=0
9409 MINT(18)=0
9410 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9411 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9412
9413C...Find masses of particles and minimal masses of diffractive states.
9414 DO 250 JT=1,2
9415 PDIF(JT)=PMM(JT)
9416 VINT(68+JT)=PDIF(JT)
9417 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9418 250 CONTINUE
9419 SH=VINT(2)
9420 SQM1=PMM(1)**2
9421 SQM2=PMM(2)**2
9422 SQM3=PDIF(1)**2
9423 SQM4=PDIF(2)**2
9424 SMRES1=(PMM(1)+PMRC)**2
9425 SMRES2=(PMM(2)+PMRC)**2
9426
9427C...Find elastic slope and lower limit diffractive slope.
9428 IHA=MAX(2,IABS(MINT(103))/110)
9429 IF(IHA.GE.5) IHA=1
9430 IHB=MAX(2,IABS(MINT(104))/110)
9431 IF(IHB.GE.5) IHB=1
9432 IF(ISUB.EQ.91) THEN
9433 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9434 ELSEIF(ISUB.EQ.92) THEN
9435 BMN=MAX(2D0,2D0*BHAD(IHB))
9436 ELSEIF(ISUB.EQ.93) THEN
9437 BMN=MAX(2D0,2D0*BHAD(IHA))
9438 ELSEIF(ISUB.EQ.94) THEN
9439 BMN=2D0*ALP*4D0
9440 ENDIF
9441
9442C...Determine maximum possible t range and coefficient of generation.
9443 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9444 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9445 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9446 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9447 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9448 & (SQM1*SQM4-SQM2*SQM3)/SH
9449 THL=-0.5D0*(THA+THB)
9450 THU=THC/THL
9451 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9452
9453C...Select diffractive mass/masses according to dm^2/m^2.
9454 LOOP3=0
9455 260 LOOP3=LOOP3+1
9456 DO 270 JT=1,2
9457 IF(MINT(16+JT).EQ.0) THEN
9458 PDIF(2+JT)=PDIF(JT)
9459 ELSE
9460 PMMIN=PDIF(JT)
9461 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9462 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9463 ENDIF
9464 270 CONTINUE
9465 SQM3=PDIF(3)**2
9466 SQM4=PDIF(4)**2
9467
9468C..Additional mass factors, including resonance enhancement.
9469 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9470 IF(LOOP3.LT.100) GOTO 260
9471 GOTO 100
9472 ENDIF
9473 IF(ISUB.EQ.92) THEN
9474 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9475 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9476 ELSEIF(ISUB.EQ.93) THEN
9477 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9478 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9479 ELSEIF(ISUB.EQ.94) THEN
9480 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9481 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9482 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9483 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9484 ENDIF
9485
9486C...Select t according to exp(Bmn*t) and correct to right slope.
9487 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9488 IF(ISUB.GE.92) THEN
9489 IF(ISUB.EQ.92) THEN
9490 BADD=2D0*ALP*LOG(SH/SQM3)
9491 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9492 ELSEIF(ISUB.EQ.93) THEN
9493 BADD=2D0*ALP*LOG(SH/SQM4)
9494 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9495 ELSEIF(ISUB.EQ.94) THEN
9496 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9497 ENDIF
9498 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9499 ENDIF
9500
9501C...Check whether m^2 and t choices are consistent.
9502 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9503 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9504 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9505 IF(THB.LE.1D-8) GOTO 260
9506 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9507 & (SQM1*SQM4-SQM2*SQM3)/SH
9508 THLM=-0.5D0*(THA+THB)
9509 THUM=THC/THLM
9510 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9511
9512C...Information to output.
9513 VINT(21)=1D0
9514 VINT(22)=0D0
9515 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9516 VINT(45)=TH
9517 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9518 VINT(63)=PDIF(3)**2
9519 VINT(64)=PDIF(4)**2
9520 VINT(283)=PMM(1)**2/4D0
9521 VINT(284)=PMM(2)**2/4D0
9522
9523C...Note: in the following, by In is meant the integral over the
9524C...quantity multiplying coefficient cn.
9525C...Choose tau according to h1(tau)/tau, where
9526C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9527C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9528C...I1/I5*c5*1/(tau+tau_R') +
9529C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9530C...I1/I7*c7*tau/(1.-tau), and
9531C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9532 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9533 CALL PYKLIM(1)
9534 IF(MINT(51).NE.0) THEN
9535 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9536 IF(MFAIL.EQ.1) THEN
9537 MSTI(61)=1
9538 RETURN
9539 ENDIF
9540 GOTO 100
9541 ENDIF
9542 RTAU=PYR(0)
9543 MTAU=1
9544 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9545 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9546 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9547 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9548 & MTAU=5
9549 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9550 & COEF(ISUB,5)) MTAU=6
9551 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9552 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9553C...Additional check to handle techni-processes with extra resonance
9554C....Only modify tau treatment
9555 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9556 & THEN
9557 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9558 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9559 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9560 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9561 & +COEFX(ISUB,1)) MTAU=9
9562 ENDIF
9563 CALL PYKMAP(1,MTAU,PYR(0))
9564
9565C...2 -> 3, 4 processes:
9566C...Choose tau' according to h4(tau,tau')/tau', where
9567C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9568C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9569 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9570 CALL PYKLIM(4)
9571 IF(MINT(51).NE.0) THEN
9572 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9573 IF(MFAIL.EQ.1) THEN
9574 MSTI(61)=1
9575 RETURN
9576 ENDIF
9577 GOTO 100
9578 ENDIF
9579 RTAUP=PYR(0)
9580 MTAUP=1
9581 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9582 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9583 CALL PYKMAP(4,MTAUP,PYR(0))
9584 ENDIF
9585
9586C...Choose y* according to h2(y*), where
9587C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9588C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9589C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9590C...and c1 + c2 + c3 + c4 + c5 = 1.
9591 CALL PYKLIM(2)
9592 IF(MINT(51).NE.0) THEN
9593 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9594 IF(MFAIL.EQ.1) THEN
9595 MSTI(61)=1
9596 RETURN
9597 ENDIF
9598 GOTO 100
9599 ENDIF
9600 RYST=PYR(0)
9601 MYST=1
9602 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9603 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9604 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9605 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9606 & COEF(ISUB,11)) MYST=5
9607 CALL PYKMAP(2,MYST,PYR(0))
9608
9609C...2 -> 2 processes:
9610C...Choose cos(theta-hat) (cth) according to h3(cth), where
9611C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9612C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9613C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9614C...and c0 + c1 + c2 + c3 + c4 = 1.
9615 CALL PYKLIM(3)
9616 IF(MINT(51).NE.0) THEN
9617 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9618 IF(MFAIL.EQ.1) THEN
9619 MSTI(61)=1
9620 RETURN
9621 ENDIF
9622 GOTO 100
9623 ENDIF
9624 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9625 RCTH=PYR(0)
9626 MCTH=1
9627 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9628 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9629 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9630 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9631 & COEF(ISUB,16)) MCTH=5
9632 CALL PYKMAP(3,MCTH,PYR(0))
9633 ENDIF
9634
9635C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9636 IF(ISTSB.EQ.5) THEN
9637 CALL PYKMAP(5,0,0D0)
9638 IF(MINT(51).NE.0) THEN
9639 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9640 IF(MFAIL.EQ.1) THEN
9641 MSTI(61)=1
9642 RETURN
9643 ENDIF
9644 GOTO 100
9645 ENDIF
9646 ENDIF
9647
9648C...DIS as f + gamma* -> f process: set dummy values.
9649 ELSEIF(ISTSB.EQ.8) THEN
9650 VINT(21)=0.9D0
9651 VINT(22)=0D0
9652 VINT(23)=0D0
9653 VINT(47)=0D0
9654 VINT(48)=0D0
9655
9656C...Low-pT or multiple interactions (first semihard interaction).
9657 ELSEIF(ISTSB.EQ.9) THEN
9658 IF(MINT(35).LE.1) CALL PYMULT(3)
9659 IF(MINT(35).GE.2) CALL PYMIGN(3)
9660 ISUB=MINT(1)
9661
9662C...Study user-defined process: kinematics plus weight.
9663 ELSEIF(ISTSB.EQ.11) THEN
9664 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9665 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9666 MSTI(51)=0
9667 IF(NUP.LE.0) THEN
9668 MINT(51)=2
9669 MSTI(51)=1
9670 IF(MINT(82).EQ.1) THEN
9671 NGEN(0,1)=NGEN(0,1)-1
9672 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9673 ENDIF
9674 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9675 RETURN
9676 ENDIF
9677
9678C...Extract cross section event weight.
9679 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9680 SIGS=1D-9*XWGTUP
9681 ELSE
9682 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9683 ENDIF
9684 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9685 VINT(97)=SIGN(1D0,XWGTUP)
9686 ELSE
9687 VINT(97)=1D-9*XWGTUP
9688 ENDIF
9689
9690C...Construct 'trivial' kinematical variables needed.
9691 KFL1=IDUP(1)
9692 KFL2=IDUP(2)
9693 VINT(41)=PUP(4,1)/EBMUP(1)
9694 VINT(42)=PUP(4,2)/EBMUP(2)
9695 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
9696 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
9697 & '(listing follows):')
9698 CALL PYLIST(7)
9699 ENDIF
9700 VINT(21)=VINT(41)*VINT(42)
9701 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
9702 VINT(44)=VINT(21)*VINT(2)
9703 VINT(43)=SQRT(MAX(0D0,VINT(44)))
9704 VINT(55)=SCALUP
9705 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
9706 VINT(56)=VINT(55)**2
9707 VINT(57)=AQEDUP
9708 VINT(58)=AQCDUP
9709
9710C...Construct other kinematical variables needed (approximately).
9711 VINT(23)=0D0
9712 VINT(26)=VINT(21)
9713 VINT(45)=-0.5D0*VINT(44)
9714 VINT(46)=-0.5D0*VINT(44)
9715 VINT(49)=VINT(43)
9716 VINT(50)=VINT(44)
9717 VINT(51)=VINT(55)
9718 VINT(52)=VINT(56)
9719 VINT(53)=VINT(55)
9720 VINT(54)=VINT(56)
9721 VINT(25)=0D0
9722 VINT(48)=0D0
9723 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
9724 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
9725 DO 280 IUP=3,NUP
9726 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
9727 & '(PYRAND:) unacceptable ISTUP code for particles')
9728 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
9729 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
9730 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
9731 & PUP(2,IUP)**2)
9732 280 CONTINUE
9733 VINT(47)=SQRT(VINT(48))
9734 ENDIF
9735
9736C...Choose azimuthal angle.
9737 VINT(24)=0D0
9738 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
9739
9740C...Check against user cuts on kinematics at parton level.
9741 MINT(51)=0
9742 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
9743 IF(MINT(51).NE.0) THEN
9744 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9745 IF(MFAIL.EQ.1) THEN
9746 MSTI(61)=1
9747 RETURN
9748 ENDIF
9749 GOTO 100
9750 ENDIF
9751 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
9752 MCUT=0
9753 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
9754 & CALL PYKCUT(MCUT)
9755 IF(MCUT.NE.0) THEN
9756 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9757 IF(MFAIL.EQ.1) THEN
9758 MSTI(61)=1
9759 RETURN
9760 ENDIF
9761 GOTO 100
9762 ENDIF
9763 ENDIF
9764
9765C...Calculate differential cross-section for different subprocesses.
9766 IF(ISTSB.LE.10) CALL PYSIGH(NCHN,SIGS)
9767 SIGSOR=SIGS
9768 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
9769
9770C...Multiply cross section by lepton -> photon flux factor.
9771 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9772 SIGS=WTGAGA*SIGS
9773 DO 290 ICHN=1,NCHN
9774 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
9775 290 CONTINUE
9776 SIGLPT=WTGAGA*SIGLPT
9777 ENDIF
9778
9779C...Multiply cross-section by user-defined weights.
9780 IF(MSTP(173).EQ.1) THEN
9781 SIGS=PARP(173)*SIGS
9782 DO 300 ICHN=1,NCHN
9783 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
9784 300 CONTINUE
9785 SIGLPT=PARP(173)*SIGLPT
9786 ENDIF
9787 WTXS=1D0
9788 SIGSWT=SIGS
9789 VINT(99)=1D0
9790 VINT(100)=1D0
9791 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
9792 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
9793 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
9794 SIGSWT=WTXS*SIGS
9795 VINT(99)=WTXS
9796 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
9797 ENDIF
9798
9799C...Calculations for Monte Carlo estimate of all cross-sections.
9800 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
9801 IF(MSTP(142).LE.1) THEN
9802 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9803 ELSE
9804 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
9805 ENDIF
9806 ELSEIF(MINT(82).EQ.1) THEN
9807 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
9808 ENDIF
9809 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
9810 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
9811
9812C...Multiple interactions: store results of cross-section calculation.
9813 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
9814 VINT(153)=SIGSOR
9815 IF(MINT(35).LE.1) CALL PYMULT(4)
9816 IF(MINT(35).GE.2) CALL PYMIGN(4)
9817 ENDIF
9818
9819C...Ratio of actual to maximum cross section.
9820 IF(ISTSB.NE.11) THEN
9821 VIOL=SIGSWT/XSEC(ISUB,1)
9822 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
9823 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
9824 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
9825 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
9826 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
9827 ELSE
9828 VIOL=1D0
9829 ENDIF
9830
9831C...Check that weight not negative.
9832 IF(MSTP(123).LE.0) THEN
9833 IF(VIOL.LT.-1D-3) THEN
9834 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
9835 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9836 & VINT(22),VINT(23),VINT(26)
9837 CALL PYSTOP(2)
9838 ENDIF
9839 ELSE
9840 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
9841 VINT(109)=VIOL
9842 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
9843 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
9844 & VINT(22),VINT(23),VINT(26)
9845 ENDIF
9846 ENDIF
9847
9848C...Weighting using estimate of maximum of differential cross-section.
9849 RATND=1D0
9850 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
9851 IF(VIOL.LT.PYR(0)) THEN
9852 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9853 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
9854 GOTO 100
9855 ENDIF
9856 ELSEIF(MFAIL.EQ.0) THEN
9857 RATND=SIGLPT/XSEC(95,1)
9858 VIOL=VIOL/RATND
9859 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
9860 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
9861 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
9862 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9863 ISUB=0
9864 GOTO 100
9865 ENDIF
9866 IF(VIOL.LT.PYR(0)) THEN
9867 GOTO 140
9868 ENDIF
9869 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
9870 IF(VIOL.LT.PYR(0)) THEN
9871 MSTI(61)=1
9872 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9873 RETURN
9874 ENDIF
9875 ELSE
9876 RATND=SIGLPT/XSEC(95,1)
9877 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
9878 MSTI(61)=1
9879 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9880 RETURN
9881 ENDIF
9882 VIOL=VIOL/RATND
9883 IF(VIOL.LT.PYR(0)) THEN
9884 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9885 GOTO 100
9886 ENDIF
9887 ENDIF
9888
9889C...Check for possible violation of estimated maximum of differential
9890C...cross-section used in weighting.
9891 IF(MSTP(123).LE.0) THEN
9892 IF(VIOL.GT.1D0) THEN
9893 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
9894 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9895 & VINT(22),VINT(23),VINT(26)
9896 CALL PYSTOP(2)
9897 ENDIF
9898 ELSEIF(MSTP(123).EQ.1) THEN
9899 IF(VIOL.GT.VINT(108)) THEN
9900 VINT(108)=VIOL
9901 IF(VIOL.GT.1.0001D0) THEN
9902 MINT(10)=1
9903 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9904 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9905 & VINT(22),VINT(23),VINT(26)
9906 ENDIF
9907 ENDIF
9908 ELSEIF(VIOL.GT.VINT(108)) THEN
9909 VINT(108)=VIOL
9910 IF(VIOL.GT.1D0) THEN
9911 MINT(10)=1
9912 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
9913 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
9914 & THEN
9915 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
9916 IF(KFPR(ISUB,1).LE.9) THEN
9917 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
9918 & XMAXUP(KFPR(ISUB,1))
9919 ELSEIF(KFPR(ISUB,1).LE.99) THEN
9920 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
9921 & XMAXUP(KFPR(ISUB,1))
9922 ELSE
9923 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
9924 & XMAXUP(KFPR(ISUB,1))
9925 ENDIF
9926 ENDIF
9927 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
9928 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
9929 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
9930 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
9931 & XSEC(0,1)=XSEC(0,1)+XDIF
9932 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
9933 & VINT(22),VINT(23),VINT(26)
9934 IF(ISUB.LE.9) THEN
9935 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
9936 ELSEIF(ISUB.LE.99) THEN
9937 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
9938 ELSE
9939 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
9940 ENDIF
9941 ENDIF
9942 VINT(108)=1D0
9943 ENDIF
9944 ENDIF
9945
9946C...Multiple interactions: choose impact parameter (if not already done).
9947 IF(MINT(39).EQ.0) VINT(148)=1D0
9948 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
9949 &MSTP(82).GE.3) THEN
9950 IF(MINT(35).LE.1) CALL PYMULT(5)
9951 IF(MINT(35).GE.2) CALL PYMIGN(5)
9952 IF(VINT(150).LT.PYR(0)) THEN
9953 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9954 IF(MFAIL.EQ.1) THEN
9955 MSTI(61)=1
9956 RETURN
9957 ENDIF
9958 GOTO 100
9959 ENDIF
9960 ENDIF
9961 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
9962 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
9963 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
9964 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
9965 ENDIF
9966 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
9967
9968C...Choose flavour of reacting partons (and subprocess).
9969 IF(ISTSB.GE.11) GOTO 320
9970 RSIGS=SIGS*PYR(0)
9971 QT2=VINT(48)
9972 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
9973 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
9974 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
9975 &PYR(0).GT.RQQBAR)) THEN
9976 DO 310 ICHN=1,NCHN
9977 KFL1=ISIG(ICHN,1)
9978 KFL2=ISIG(ICHN,2)
9979 MINT(2)=ISIG(ICHN,3)
9980 RSIGS=RSIGS-SIGH(ICHN)
9981 IF(RSIGS.LE.0D0) GOTO 320
9982 310 CONTINUE
9983
9984C...Multiple interactions: choose qqbar preferentially at small pT.
9985 ELSEIF(ISUB.EQ.96) THEN
9986 MINT(105)=MINT(103)
9987 MINT(109)=MINT(107)
9988 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
9989 MINT(105)=MINT(104)
9990 MINT(109)=MINT(108)
9991 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
9992 MINT(1)=11
9993 MINT(2)=1
9994 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
9995
9996C...Low-pT: choose string drawing configuration.
9997 ELSE
9998 KFL1=21
9999 KFL2=21
10000 RSIGS=6D0*PYR(0)
10001 MINT(2)=1
10002 IF(RSIGS.GT.1D0) MINT(2)=2
10003 IF(RSIGS.GT.2D0) MINT(2)=3
10004 ENDIF
10005
10006C...Reassign QCD process. Partons before initial state radiation.
10007 320 IF(MINT(2).GT.10) THEN
10008 MINT(1)=MINT(2)/10
10009 MINT(2)=MOD(MINT(2),10)
10010 ENDIF
10011 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10012 &NGEN(MINT(1),2)+1
10013 MINT(15)=KFL1
10014 MINT(16)=KFL2
10015 MINT(13)=MINT(15)
10016 MINT(14)=MINT(16)
10017 VINT(141)=VINT(41)
10018 VINT(142)=VINT(42)
10019 VINT(151)=0D0
10020 VINT(152)=0D0
10021
10022C...Calculate x value of photon for parton inside photon inside e.
10023 DO 350 JT=1,2
10024 MINT(18+JT)=0
10025 VINT(154+JT)=0D0
10026 MSPLI=0
10027 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10028 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10029 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10030 IF(MSPLI.EQ.2) THEN
10031 KFLH=MINT(14+JT)
10032 XHRD=VINT(140+JT)
10033 Q2HRD=VINT(54)
10034 MINT(105)=MINT(102+JT)
10035 MINT(109)=MINT(106+JT)
10036 VINT(120)=VINT(2+JT)
10037 IF(MSTP(57).LE.1) THEN
10038 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10039 ELSE
10040 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10041 ENDIF
10042 WTMX=4D0*XPQ(KFLH)
10043 IF(MSTP(13).EQ.2) THEN
10044 Q2PMS=Q2HRD/PMAS(11,1)**2
10045 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10046 ENDIF
10047 330 XE=XHRD**PYR(0)
10048 XG=MIN(1D0-1D-10,XHRD/XE)
10049 IF(MSTP(57).LE.1) THEN
10050 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10051 ELSE
10052 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10053 ENDIF
10054 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10055 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10056 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10057 MINT(18+JT)=1
10058 VINT(154+JT)=XE
10059 DO 340 KFLS=-25,25
10060 XSFX(JT,KFLS)=XPQ(KFLS)
10061 340 CONTINUE
10062 ENDIF
10063 350 CONTINUE
10064
10065C...Pick scale where photon is resolved.
10066 Q0S=PARP(15)**2
10067 Q1S=VINT(154)**2
10068 VINT(283)=0D0
10069 IF(MINT(107).EQ.3) THEN
10070 IF(MSTP(66).EQ.1) THEN
10071 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10072 ELSEIF(MSTP(66).EQ.2) THEN
10073 PS=VINT(3)**2
10074 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10075 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10076 Q2INT=SQRT(Q0S*Q2EFF)
10077 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10078 ELSEIF(MSTP(66).EQ.3) THEN
10079 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10080 ELSEIF(MSTP(66).GE.4) THEN
10081 PS=0.25D0*VINT(3)**2
10082 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10083 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10084 ENDIF
10085 ENDIF
10086 VINT(284)=0D0
10087 IF(MINT(108).EQ.3) THEN
10088 IF(MSTP(66).EQ.1) THEN
10089 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10090 ELSEIF(MSTP(66).EQ.2) THEN
10091 PS=VINT(4)**2
10092 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10093 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10094 Q2INT=SQRT(Q0S*Q2EFF)
10095 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10096 ELSEIF(MSTP(66).EQ.3) THEN
10097 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10098 ELSEIF(MSTP(66).GE.4) THEN
10099 PS=0.25D0*VINT(4)**2
10100 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10101 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10102 ENDIF
10103 ENDIF
10104 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10105
10106C...Format statements for differential cross-section maximum violations.
10107 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10108 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10109 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10110 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10111 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10112 &'in event',1X,I7)
10113 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10114 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10115 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10116 &'in event',1X,I7)
10117 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10118 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10119 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10120 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10121 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10122 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10123
10124 RETURN
10125 END
10126
10127C*********************************************************************
10128
10129C...PYSCAT
10130C...Finds outgoing flavours and event type; sets up the kinematics
10131C...and colour flow of the hard scattering
10132
10133 SUBROUTINE PYSCAT
10134
10135C...Double precision and integer declarations
10136 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10137 IMPLICIT INTEGER(I-N)
10138 INTEGER PYK,PYCHGE,PYCOMP
10139C...Parameter statement to help give large particle numbers.
10140 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10141 &KEXCIT=4000000,KDIMEN=5000000)
10142C...Parameter statement for maximum size of showers.
10143 PARAMETER (MAXNUR=1000)
10144
10145C...User process event common block.
10146 INTEGER MAXNUP
10147 PARAMETER (MAXNUP=500)
10148 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10149 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10150 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10151 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10152 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10153 SAVE /HEPEUP/
10154
10155C...Commonblocks.
10156 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10157 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10158 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10159 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10160 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10161 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10162 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10163 COMMON/PYINT1/MINT(400),VINT(400)
10164 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10165 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10166 COMMON/PYINT4/MWID(500),WIDS(500,5)
10167 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10168 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10169 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10170 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10171 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10172 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10173 &/PYTCSM/
10174C...Local arrays and saved variables
10175 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10176 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10177 SAVE VINTSV
10178
10179C...Read out process
10180 ISUB=MINT(1)
10181 ISUBSV=ISUB
10182
10183C...Restore information for low-pT processes
10184 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10185 DO 100 J=41,66
10186 100 VINT(J)=VINTSV(J)
10187 ENDIF
10188
10189C...Convert H' or A process into equivalent H one
10190 IHIGG=1
10191 KFHIGG=25
10192 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10193 &ISUB.LE.190)) THEN
10194 IHIGG=2
10195 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10196 KFHIGG=33+IHIGG
10197 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10198 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10199 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10200 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10201 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10202 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10203 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10204 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10205 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10206 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10207 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10208 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10209 ENDIF
10210
10211 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10212
10213C...Convert bottomonium process into equivalent charmonium ones.
10214 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10215
10216C...Choice of subprocess, number of documentation lines
10217 IDOC=6+ISET(ISUB)
10218 IF(ISUB.EQ.95) IDOC=8
10219 IF(ISET(ISUB).EQ.5) IDOC=9
10220 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10221 MINT(3)=IDOC-6
10222 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10223 MINT(4)=IDOC
10224 IPU1=MINT(84)+1
10225 IPU2=MINT(84)+2
10226 IPU3=MINT(84)+3
10227 IPU4=MINT(84)+4
10228 IPU5=MINT(84)+5
10229 IPU6=MINT(84)+6
10230
10231C...Reset K, P and V vectors. Store incoming particles
10232 DO 120 JT=1,MSTP(126)+100
10233 I=MINT(83)+JT
10234 IF(I.GT.MSTU(4)) GOTO 120
10235 DO 110 J=1,5
10236 K(I,J)=0
10237 P(I,J)=0D0
10238 V(I,J)=0D0
10239 110 CONTINUE
10240 120 CONTINUE
10241 DO 140 JT=1,2
10242 I=MINT(83)+JT
10243 K(I,1)=21
10244 K(I,2)=MINT(10+JT)
10245 DO 130 J=1,5
10246 P(I,J)=VINT(285+5*JT+J)
10247 130 CONTINUE
10248 140 CONTINUE
10249 MINT(6)=2
10250 KFRES=0
10251
10252C...Store incoming partons in their CM-frame. Save pdf value.
10253 SH=VINT(44)
10254 SHR=SQRT(SH)
10255 SHP=VINT(26)*VINT(2)
10256 SHPR=SQRT(SHP)
10257 SHUSER=SHR
10258 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10259 DO 150 JT=1,2
10260 I=MINT(84)+JT
10261 K(I,1)=14
10262 K(I,2)=MINT(14+JT)
10263 K(I,3)=MINT(83)+2+JT
10264 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10265 P(I,4)=0.5D0*SHUSER
10266 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10267 150 CONTINUE
10268
10269C...Copy incoming partons to documentation lines
10270 DO 170 JT=1,2
10271 I1=MINT(83)+4+JT
10272 I2=MINT(84)+JT
10273 K(I1,1)=21
10274 K(I1,2)=K(I2,2)
10275 K(I1,3)=I1-2
10276 DO 160 J=1,5
10277 P(I1,J)=P(I2,J)
10278 160 CONTINUE
10279 170 CONTINUE
10280
10281C...Choose new quark/lepton flavour for relevant annihilation graphs
10282 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10283 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10284 IGLGA=21
10285 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10286 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10287 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10288 DO 190 I=1,MDCY(IGLGA,3)
10289 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10290 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10291 IF(RKFL.LE.0D0) GOTO 200
10292 190 CONTINUE
10293 200 CONTINUE
10294 IF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.2) THEN
10295 IF(KFLF.GE.4) GOTO 180
10296 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385).AND.MINT(2).LE.4) THEN
10297 KFLF=4
10298 MINT(2)=MINT(2)-2
10299 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385) THEN
10300 KFLF=5
10301 MINT(2)=MINT(2)-4
10302 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10303 & .AND.IABS(KFLF).GE.3) THEN
10304 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10305 & VINT(44)**2
10306 FACCIB=VINT(46)**2/RTCM(41)**4
10307 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10308 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10309 KFLF=5
10310 MINT(2)=1
10311 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10312 IF(KFLF.EQ.5) GOTO 180
10313 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10314 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10315 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10316 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10317 ENDIF
10318 ENDIF
10319
10320C...Final state flavours and colour flow: default values
10321 JS=1
10322 MINT(21)=MINT(15)
10323 MINT(22)=MINT(16)
10324 MINT(23)=0
10325 MINT(24)=0
10326 KCC=20
10327 KCS=ISIGN(1,MINT(15))
10328
10329 IF(ISET(ISUB).EQ.11) THEN
10330C...User-defined processes: find products
10331 MINT(3)=0
10332 DO 210 IUP=3,NUP
10333 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10334 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10335 MINT(21+IUP)=IDUP(IUP)
10336 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10337 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10338 ELSEIF(IDUP(IUP).EQ.0) THEN
10339 ELSE
10340 MINT(3)=MINT(3)+1
10341 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10342 ENDIF
10343 210 CONTINUE
10344
10345 ELSEIF(ISUB.LE.10) THEN
10346 IF(ISUB.EQ.1) THEN
10347C...f + fbar -> gamma*/Z0
10348 KFRES=23
10349
10350 ELSEIF(ISUB.EQ.2) THEN
10351C...f + fbar' -> W+/-
10352 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10353 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10354 KFRES=ISIGN(24,KCH1+KCH2)
10355
10356 ELSEIF(ISUB.EQ.3) THEN
10357C...f + fbar -> h0 (or H0, or A0)
10358 KFRES=KFHIGG
10359
10360 ELSEIF(ISUB.EQ.4) THEN
10361C...gamma + W+/- -> W+/-
10362
10363 ELSEIF(ISUB.EQ.5) THEN
10364C...Z0 + Z0 -> h0
10365 XH=SH/SHP
10366 MINT(21)=MINT(15)
10367 MINT(22)=MINT(16)
10368 PMQ(1)=PYMASS(MINT(21))
10369 PMQ(2)=PYMASS(MINT(22))
10370 220 JT=INT(1.5D0+PYR(0))
10371 ZMIN=2D0*PMQ(JT)/SHPR
10372 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10373 & (SHPR*(SHPR-PMQ(3-JT)))
10374 ZMAX=MIN(1D0-XH,ZMAX)
10375 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10376 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10377 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10378 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10379 IF(SQC1.LT.1D-8) GOTO 220
10380 C1=SQRT(SQC1)
10381 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10382 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10383 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10384 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10385 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10386 IF(SQC1.LT.1D-8) GOTO 220
10387 C1=SQRT(SQC1)
10388 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10389 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10390 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10391 PHIR=PARU(2)*PYR(0)
10392 CPHI=COS(PHIR)
10393 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10394 & SQRT(1D0-CTHE(2)**2)*CPHI
10395 Z1=2D0-Z(JT)
10396 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10397 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10398 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10399 & PMQ(3-JT)**2/SHP))
10400 ZMIN=2D0*PMQ(3-JT)/SHPR
10401 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10402 ZMAX=MIN(1D0-XH,ZMAX)
10403 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10404 KCC=22
10405 KFRES=25
10406
10407 ELSEIF(ISUB.EQ.6) THEN
10408C...Z0 + W+/- -> W+/-
10409
10410 ELSEIF(ISUB.EQ.7) THEN
10411C...W+ + W- -> Z0
10412
10413 ELSEIF(ISUB.EQ.8) THEN
10414C...W+ + W- -> h0
10415 XH=SH/SHP
10416 230 DO 260 JT=1,2
10417 I=MINT(14+JT)
10418 IA=IABS(I)
10419 IF(IA.LE.10) THEN
10420 RVCKM=VINT(180+I)*PYR(0)
10421 DO 240 J=1,MSTP(1)
10422 IB=2*J-1+MOD(IA,2)
10423 IPM=(5-ISIGN(1,I))/2
10424 IDC=J+MDCY(IA,2)+2
10425 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10426 MINT(20+JT)=ISIGN(IB,I)
10427 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10428 IF(RVCKM.LE.0D0) GOTO 250
10429 240 CONTINUE
10430 ELSE
10431 IB=2*((IA+1)/2)-1+MOD(IA,2)
10432 MINT(20+JT)=ISIGN(IB,I)
10433 ENDIF
10434 250 PMQ(JT)=PYMASS(MINT(20+JT))
10435 260 CONTINUE
10436 JT=INT(1.5D0+PYR(0))
10437 ZMIN=2D0*PMQ(JT)/SHPR
10438 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10439 & (SHPR*(SHPR-PMQ(3-JT)))
10440 ZMAX=MIN(1D0-XH,ZMAX)
10441 IF(ZMIN.GE.ZMAX) GOTO 230
10442 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10443 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10444 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10445 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10446 IF(SQC1.LT.1D-8) GOTO 230
10447 C1=SQRT(SQC1)
10448 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10449 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10450 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10451 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10452 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10453 IF(SQC1.LT.1D-8) GOTO 230
10454 C1=SQRT(SQC1)
10455 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10456 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10457 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10458 PHIR=PARU(2)*PYR(0)
10459 CPHI=COS(PHIR)
10460 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10461 & SQRT(1D0-CTHE(2)**2)*CPHI
10462 Z1=2D0-Z(JT)
10463 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10464 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10465 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10466 & PMQ(3-JT)**2/SHP))
10467 ZMIN=2D0*PMQ(3-JT)/SHPR
10468 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10469 ZMAX=MIN(1D0-XH,ZMAX)
10470 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10471 KCC=22
10472 KFRES=25
10473
10474 ELSEIF(ISUB.EQ.10) THEN
10475C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10476 IF(MINT(2).EQ.1) THEN
10477 KCC=22
10478 ELSE
10479C...W exchange: need to mix flavours according to CKM matrix
10480 DO 280 JT=1,2
10481 I=MINT(14+JT)
10482 IA=IABS(I)
10483 IF(IA.LE.10) THEN
10484 RVCKM=VINT(180+I)*PYR(0)
10485 DO 270 J=1,MSTP(1)
10486 IB=2*J-1+MOD(IA,2)
10487 IPM=(5-ISIGN(1,I))/2
10488 IDC=J+MDCY(IA,2)+2
10489 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10490 MINT(20+JT)=ISIGN(IB,I)
10491 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10492 IF(RVCKM.LE.0D0) GOTO 280
10493 270 CONTINUE
10494 ELSE
10495 IB=2*((IA+1)/2)-1+MOD(IA,2)
10496 MINT(20+JT)=ISIGN(IB,I)
10497 ENDIF
10498 280 CONTINUE
10499 KCC=22
10500 ENDIF
10501 ENDIF
10502
10503 ELSEIF(ISUB.LE.20) THEN
10504 IF(ISUB.EQ.11) THEN
10505C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10506 KCC=MINT(2)
10507 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10508
10509 ELSEIF(ISUB.EQ.12) THEN
10510C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10511 MINT(21)=ISIGN(KFLF,MINT(15))
10512 MINT(22)=-MINT(21)
10513 KCC=4
10514
10515 ELSEIF(ISUB.EQ.13) THEN
10516C...f + fbar -> g + g; th arbitrary
10517 MINT(21)=21
10518 MINT(22)=21
10519 KCC=MINT(2)+4
10520
10521 ELSEIF(ISUB.EQ.14) THEN
10522C...f + fbar -> g + gamma; th arbitrary
10523 IF(PYR(0).GT.0.5D0) JS=2
10524 MINT(20+JS)=21
10525 MINT(23-JS)=22
10526 KCC=17+JS
10527
10528 ELSEIF(ISUB.EQ.15) THEN
10529C...f + fbar -> g + Z0; th arbitrary
10530 IF(PYR(0).GT.0.5D0) JS=2
10531 MINT(20+JS)=21
10532 MINT(23-JS)=23
10533 KCC=17+JS
10534
10535 ELSEIF(ISUB.EQ.16) THEN
10536C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10537 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10538 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10539 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10540 MINT(20+JS)=21
10541 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10542 KCC=17+JS
10543
10544 ELSEIF(ISUB.EQ.17) THEN
10545C...f + fbar -> g + h0; th arbitrary
10546 IF(PYR(0).GT.0.5D0) JS=2
10547 MINT(20+JS)=21
10548 MINT(23-JS)=25
10549 KCC=17+JS
10550
10551 ELSEIF(ISUB.EQ.18) THEN
10552C...f + fbar -> gamma + gamma; th arbitrary
10553 MINT(21)=22
10554 MINT(22)=22
10555
10556 ELSEIF(ISUB.EQ.19) THEN
10557C...f + fbar -> gamma + Z0; th arbitrary
10558 IF(PYR(0).GT.0.5D0) JS=2
10559 MINT(20+JS)=22
10560 MINT(23-JS)=23
10561
10562 ELSEIF(ISUB.EQ.20) THEN
10563C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10564C...(p(fbar')-p(W+))**2
10565 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10566 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10567 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10568 MINT(20+JS)=22
10569 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10570 ENDIF
10571
10572 ELSEIF(ISUB.LE.30) THEN
10573 IF(ISUB.EQ.21) THEN
10574C...f + fbar -> gamma + h0; th arbitrary
10575 IF(PYR(0).GT.0.5D0) JS=2
10576 MINT(20+JS)=22
10577 MINT(23-JS)=25
10578
10579 ELSEIF(ISUB.EQ.22) THEN
10580C...f + fbar -> Z0 + Z0; th arbitrary
10581 MINT(21)=23
10582 MINT(22)=23
10583
10584 ELSEIF(ISUB.EQ.23) THEN
10585C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10586 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10587 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10588 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10589 MINT(20+JS)=23
10590 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10591
10592 ELSEIF(ISUB.EQ.24) THEN
10593C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10594 IF(PYR(0).GT.0.5D0) JS=2
10595 MINT(20+JS)=23
10596 MINT(23-JS)=KFHIGG
10597
10598 ELSEIF(ISUB.EQ.25) THEN
10599C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10600 MINT(21)=-ISIGN(24,MINT(15))
10601 MINT(22)=-MINT(21)
10602
10603 ELSEIF(ISUB.EQ.26) THEN
10604C...f + fbar' -> W+/- + h0 (or H0, or A0);
10605C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10606 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10607 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10608 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10609 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10610 MINT(23-JS)=KFHIGG
10611
10612 ELSEIF(ISUB.EQ.27) THEN
10613C...f + fbar -> h0 + h0
10614
10615 ELSEIF(ISUB.EQ.28) THEN
10616C...f + g -> f + g; th = (p(f)-p(f))**2
10617 IF(MINT(15).EQ.21) JS=2
10618 KCC=MINT(2)+6
10619 IF(MINT(15).EQ.21) KCC=KCC+2
10620 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10621 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10622
10623 ELSEIF(ISUB.EQ.29) THEN
10624C...f + g -> f + gamma; th = (p(f)-p(f))**2
10625 IF(MINT(15).EQ.21) JS=2
10626 MINT(23-JS)=22
10627 KCC=15+JS
10628 KCS=ISIGN(1,MINT(14+JS))
10629
10630 ELSEIF(ISUB.EQ.30) THEN
10631C...f + g -> f + Z0; th = (p(f)-p(f))**2
10632 IF(MINT(15).EQ.21) JS=2
10633 MINT(23-JS)=23
10634 KCC=15+JS
10635 KCS=ISIGN(1,MINT(14+JS))
10636 ENDIF
10637
10638 ELSEIF(ISUB.LE.40) THEN
10639 IF(ISUB.EQ.31) THEN
10640C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10641 IF(MINT(15).EQ.21) JS=2
10642 I=MINT(14+JS)
10643 IA=IABS(I)
10644 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10645 RVCKM=VINT(180+I)*PYR(0)
10646 DO 290 J=1,MSTP(1)
10647 IB=2*J-1+MOD(IA,2)
10648 IPM=(5-ISIGN(1,I))/2
10649 IDC=J+MDCY(IA,2)+2
10650 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
10651 MINT(20+JS)=ISIGN(IB,I)
10652 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10653 IF(RVCKM.LE.0D0) GOTO 300
10654 290 CONTINUE
10655 300 KCC=15+JS
10656 KCS=ISIGN(1,MINT(14+JS))
10657
10658 ELSEIF(ISUB.EQ.32) THEN
10659C...f + g -> f + h0; th = (p(f)-p(f))**2
10660 IF(MINT(15).EQ.21) JS=2
10661 MINT(23-JS)=25
10662 KCC=15+JS
10663 KCS=ISIGN(1,MINT(14+JS))
10664
10665 ELSEIF(ISUB.EQ.33) THEN
10666C...f + gamma -> f + g; th=(p(f)-p(f))**2
10667 IF(MINT(15).EQ.22) JS=2
10668 MINT(23-JS)=21
10669 KCC=24+JS
10670 KCS=ISIGN(1,MINT(14+JS))
10671
10672 ELSEIF(ISUB.EQ.34) THEN
10673C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
10674 IF(MINT(15).EQ.22) JS=2
10675 KCC=22
10676 KCS=ISIGN(1,MINT(14+JS))
10677
10678 ELSEIF(ISUB.EQ.35) THEN
10679C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
10680 IF(MINT(15).EQ.22) JS=2
10681 MINT(23-JS)=23
10682 KCC=22
10683
10684 ELSEIF(ISUB.EQ.36) THEN
10685C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
10686 IF(MINT(15).EQ.22) JS=2
10687 I=MINT(14+JS)
10688 IA=IABS(I)
10689 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10690 IF(IA.LE.10) THEN
10691 RVCKM=VINT(180+I)*PYR(0)
10692 DO 310 J=1,MSTP(1)
10693 IB=2*J-1+MOD(IA,2)
10694 IPM=(5-ISIGN(1,I))/2
10695 IDC=J+MDCY(IA,2)+2
10696 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
10697 MINT(20+JS)=ISIGN(IB,I)
10698 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10699 IF(RVCKM.LE.0D0) GOTO 320
10700 310 CONTINUE
10701 ELSE
10702 IB=2*((IA+1)/2)-1+MOD(IA,2)
10703 MINT(20+JS)=ISIGN(IB,I)
10704 ENDIF
10705 320 KCC=22
10706
10707 ELSEIF(ISUB.EQ.37) THEN
10708C...f + gamma -> f + h0
10709
10710 ELSEIF(ISUB.EQ.38) THEN
10711C...f + Z0 -> f + g
10712
10713 ELSEIF(ISUB.EQ.39) THEN
10714C...f + Z0 -> f + gamma
10715
10716 ELSEIF(ISUB.EQ.40) THEN
10717C...f + Z0 -> f + Z0
10718 ENDIF
10719
10720 ELSEIF(ISUB.LE.50) THEN
10721 IF(ISUB.EQ.41) THEN
10722C...f + Z0 -> f' + W+/-
10723
10724 ELSEIF(ISUB.EQ.42) THEN
10725C...f + Z0 -> f + h0
10726
10727 ELSEIF(ISUB.EQ.43) THEN
10728C...f + W+/- -> f' + g
10729
10730 ELSEIF(ISUB.EQ.44) THEN
10731C...f + W+/- -> f' + gamma
10732
10733 ELSEIF(ISUB.EQ.45) THEN
10734C...f + W+/- -> f' + Z0
10735
10736 ELSEIF(ISUB.EQ.46) THEN
10737C...f + W+/- -> f' + W+/-
10738
10739 ELSEIF(ISUB.EQ.47) THEN
10740C...f + W+/- -> f' + h0
10741
10742 ELSEIF(ISUB.EQ.48) THEN
10743C...f + h0 -> f + g
10744
10745 ELSEIF(ISUB.EQ.49) THEN
10746C...f + h0 -> f + gamma
10747
10748 ELSEIF(ISUB.EQ.50) THEN
10749C...f + h0 -> f + Z0
10750 ENDIF
10751
10752 ELSEIF(ISUB.LE.60) THEN
10753 IF(ISUB.EQ.51) THEN
10754C...f + h0 -> f' + W+/-
10755
10756 ELSEIF(ISUB.EQ.52) THEN
10757C...f + h0 -> f + h0
10758
10759 ELSEIF(ISUB.EQ.53) THEN
10760C...g + g -> f + fbar; th arbitrary
10761 KCS=(-1)**INT(1.5D0+PYR(0))
10762 MINT(21)=ISIGN(KFLF,KCS)
10763 MINT(22)=-MINT(21)
10764 KCC=MINT(2)+10
10765
10766 ELSEIF(ISUB.EQ.54) THEN
10767C...g + gamma -> f + fbar; th arbitrary
10768 KCS=(-1)**INT(1.5D0+PYR(0))
10769 MINT(21)=ISIGN(KFLF,KCS)
10770 MINT(22)=-MINT(21)
10771 KCC=27
10772 IF(MINT(16).EQ.21) KCC=28
10773
10774 ELSEIF(ISUB.EQ.55) THEN
10775C...g + Z0 -> f + fbar
10776
10777 ELSEIF(ISUB.EQ.56) THEN
10778C...g + W+/- -> f + fbar'
10779
10780 ELSEIF(ISUB.EQ.57) THEN
10781C...g + h0 -> f + fbar
10782
10783 ELSEIF(ISUB.EQ.58) THEN
10784C...gamma + gamma -> f + fbar; th arbitrary
10785 KCS=(-1)**INT(1.5D0+PYR(0))
10786 MINT(21)=ISIGN(KFLF,KCS)
10787 MINT(22)=-MINT(21)
10788 KCC=21
10789
10790 ELSEIF(ISUB.EQ.59) THEN
10791C...gamma + Z0 -> f + fbar
10792
10793 ELSEIF(ISUB.EQ.60) THEN
10794C...gamma + W+/- -> f + fbar'
10795 ENDIF
10796
10797 ELSEIF(ISUB.LE.70) THEN
10798 IF(ISUB.EQ.61) THEN
10799C...gamma + h0 -> f + fbar
10800
10801 ELSEIF(ISUB.EQ.62) THEN
10802C...Z0 + Z0 -> f + fbar
10803
10804 ELSEIF(ISUB.EQ.63) THEN
10805C...Z0 + W+/- -> f + fbar'
10806
10807 ELSEIF(ISUB.EQ.64) THEN
10808C...Z0 + h0 -> f + fbar
10809
10810 ELSEIF(ISUB.EQ.65) THEN
10811C...W+ + W- -> f + fbar
10812
10813 ELSEIF(ISUB.EQ.66) THEN
10814C...W+/- + h0 -> f + fbar'
10815
10816 ELSEIF(ISUB.EQ.67) THEN
10817C...h0 + h0 -> f + fbar
10818
10819 ELSEIF(ISUB.EQ.68) THEN
10820C...g + g -> g + g; th arbitrary
10821 KCC=MINT(2)+12
10822 KCS=(-1)**INT(1.5D0+PYR(0))
10823
10824 ELSEIF(ISUB.EQ.69) THEN
10825C...gamma + gamma -> W+ + W-; th arbitrary
10826 MINT(21)=24
10827 MINT(22)=-24
10828 KCC=21
10829
10830 ELSEIF(ISUB.EQ.70) THEN
10831C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
10832 IF(MINT(15).EQ.22) MINT(21)=23
10833 IF(MINT(16).EQ.22) MINT(22)=23
10834 KCC=21
10835 ENDIF
10836
10837 ELSEIF(ISUB.LE.80) THEN
10838 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
10839C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
10840 XH=SH/SHP
10841 MINT(21)=MINT(15)
10842 MINT(22)=MINT(16)
10843 PMQ(1)=PYMASS(MINT(21))
10844 PMQ(2)=PYMASS(MINT(22))
10845 330 JT=INT(1.5D0+PYR(0))
10846 ZMIN=2D0*PMQ(JT)/SHPR
10847 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10848 & (SHPR*(SHPR-PMQ(3-JT)))
10849 ZMAX=MIN(1D0-XH,ZMAX)
10850 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10851 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10852 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
10853 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10854 IF(SQC1.LT.1D-8) GOTO 330
10855 C1=SQRT(SQC1)
10856 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10857 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10858 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10859 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10860 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10861 IF(SQC1.LT.1D-8) GOTO 330
10862 C1=SQRT(SQC1)
10863 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10864 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10865 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10866 PHIR=PARU(2)*PYR(0)
10867 CPHI=COS(PHIR)
10868 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10869 & SQRT(1D0-CTHE(2)**2)*CPHI
10870 Z1=2D0-Z(JT)
10871 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10872 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10873 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10874 & PMQ(3-JT)**2/SHP))
10875 ZMIN=2D0*PMQ(3-JT)/SHPR
10876 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10877 ZMAX=MIN(1D0-XH,ZMAX)
10878 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
10879 KCC=22
10880
10881 ELSEIF(ISUB.EQ.73) THEN
10882C...Z0 + W+/- -> Z0 + W+/-
10883 JS=MINT(2)
10884 XH=SH/SHP
10885 340 JT=3-MINT(2)
10886 I=MINT(14+JT)
10887 IA=IABS(I)
10888 IF(IA.LE.10) THEN
10889 RVCKM=VINT(180+I)*PYR(0)
10890 DO 350 J=1,MSTP(1)
10891 IB=2*J-1+MOD(IA,2)
10892 IPM=(5-ISIGN(1,I))/2
10893 IDC=J+MDCY(IA,2)+2
10894 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
10895 MINT(20+JT)=ISIGN(IB,I)
10896 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10897 IF(RVCKM.LE.0D0) GOTO 360
10898 350 CONTINUE
10899 ELSE
10900 IB=2*((IA+1)/2)-1+MOD(IA,2)
10901 MINT(20+JT)=ISIGN(IB,I)
10902 ENDIF
10903 360 PMQ(JT)=PYMASS(MINT(20+JT))
10904 MINT(23-JT)=MINT(17-JT)
10905 PMQ(3-JT)=PYMASS(MINT(23-JT))
10906 JT=INT(1.5D0+PYR(0))
10907 ZMIN=2D0*PMQ(JT)/SHPR
10908 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10909 & (SHPR*(SHPR-PMQ(3-JT)))
10910 ZMAX=MIN(1D0-XH,ZMAX)
10911 IF(ZMIN.GE.ZMAX) GOTO 340
10912 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10913 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10914 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
10915 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10916 IF(SQC1.LT.1D-8) GOTO 340
10917 C1=SQRT(SQC1)
10918 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10919 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10920 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10921 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10922 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10923 IF(SQC1.LT.1D-8) GOTO 340
10924 C1=SQRT(SQC1)
10925 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10926 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10927 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10928 PHIR=PARU(2)*PYR(0)
10929 CPHI=COS(PHIR)
10930 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10931 & SQRT(1D0-CTHE(2)**2)*CPHI
10932 Z1=2D0-Z(JT)
10933 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10934 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10935 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10936 & PMQ(3-JT)**2/SHP))
10937 ZMIN=2D0*PMQ(3-JT)/SHPR
10938 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10939 ZMAX=MIN(1D0-XH,ZMAX)
10940 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
10941 KCC=22
10942
10943 ELSEIF(ISUB.EQ.74) THEN
10944C...Z0 + h0 -> Z0 + h0
10945
10946 ELSEIF(ISUB.EQ.75) THEN
10947C...W+ + W- -> gamma + gamma
10948
10949 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
10950C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
10951 XH=SH/SHP
10952 370 DO 400 JT=1,2
10953 I=MINT(14+JT)
10954 IA=IABS(I)
10955 IF(IA.LE.10) THEN
10956 RVCKM=VINT(180+I)*PYR(0)
10957 DO 380 J=1,MSTP(1)
10958 IB=2*J-1+MOD(IA,2)
10959 IPM=(5-ISIGN(1,I))/2
10960 IDC=J+MDCY(IA,2)+2
10961 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
10962 MINT(20+JT)=ISIGN(IB,I)
10963 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10964 IF(RVCKM.LE.0D0) GOTO 390
10965 380 CONTINUE
10966 ELSE
10967 IB=2*((IA+1)/2)-1+MOD(IA,2)
10968 MINT(20+JT)=ISIGN(IB,I)
10969 ENDIF
10970 390 PMQ(JT)=PYMASS(MINT(20+JT))
10971 400 CONTINUE
10972 JT=INT(1.5D0+PYR(0))
10973 ZMIN=2D0*PMQ(JT)/SHPR
10974 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10975 & (SHPR*(SHPR-PMQ(3-JT)))
10976 ZMAX=MIN(1D0-XH,ZMAX)
10977 IF(ZMIN.GE.ZMAX) GOTO 370
10978 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10979 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10980 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
10981 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10982 IF(SQC1.LT.1D-8) GOTO 370
10983 C1=SQRT(SQC1)
10984 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10985 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10986 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10987 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10988 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10989 IF(SQC1.LT.1D-8) GOTO 370
10990 C1=SQRT(SQC1)
10991 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10992 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10993 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10994 PHIR=PARU(2)*PYR(0)
10995 CPHI=COS(PHIR)
10996 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10997 & SQRT(1D0-CTHE(2)**2)*CPHI
10998 Z1=2D0-Z(JT)
10999 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11000 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11001 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11002 & PMQ(3-JT)**2/SHP))
11003 ZMIN=2D0*PMQ(3-JT)/SHPR
11004 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11005 ZMAX=MIN(1D0-XH,ZMAX)
11006 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11007 KCC=22
11008
11009 ELSEIF(ISUB.EQ.78) THEN
11010C...W+/- + h0 -> W+/- + h0
11011
11012 ELSEIF(ISUB.EQ.79) THEN
11013C...h0 + h0 -> h0 + h0
11014
11015 ELSEIF(ISUB.EQ.80) THEN
11016C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11017 IF(MINT(15).EQ.22) JS=2
11018 I=MINT(14+JS)
11019 IA=IABS(I)
11020 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11021 IB=3-IA
11022 MINT(20+JS)=ISIGN(IB,I)
11023 KCC=22
11024 ENDIF
11025
11026 ELSEIF(ISUB.LE.90) THEN
11027 IF(ISUB.EQ.81) THEN
11028C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11029 MINT(21)=ISIGN(MINT(55),MINT(15))
11030 MINT(22)=-MINT(21)
11031 KCC=4
11032
11033 ELSEIF(ISUB.EQ.82) THEN
11034C...g + g -> Q + Qbar; th arbitrary
11035 KCS=(-1)**INT(1.5D0+PYR(0))
11036 MINT(21)=ISIGN(MINT(55),KCS)
11037 MINT(22)=-MINT(21)
11038 KCC=MINT(2)+10
11039
11040 ELSEIF(ISUB.EQ.83) THEN
11041C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11042 KFOLD=MINT(16)
11043 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11044 KFAOLD=IABS(KFOLD)
11045 IF(KFAOLD.GT.10) THEN
11046 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11047 ELSE
11048 RCKM=VINT(180+KFOLD)*PYR(0)
11049 IPM=(5-ISIGN(1,KFOLD))/2
11050 KFANEW=-MOD(KFAOLD+1,2)
11051 410 KFANEW=KFANEW+2
11052 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11053 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11054 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11055 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11056 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11057 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11058 ENDIF
11059 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11060 ENDIF
11061 IF(MINT(2).EQ.1) THEN
11062 MINT(21)=ISIGN(MINT(55),MINT(15))
11063 MINT(22)=ISIGN(KFANEW,MINT(16))
11064 ELSE
11065 MINT(21)=ISIGN(KFANEW,MINT(15))
11066 MINT(22)=ISIGN(MINT(55),MINT(16))
11067 JS=2
11068 ENDIF
11069 KCC=22
11070
11071 ELSEIF(ISUB.EQ.84) THEN
11072C...g + gamma -> Q + Qbar; th arbitary
11073 KCS=(-1)**INT(1.5D0+PYR(0))
11074 MINT(21)=ISIGN(MINT(55),KCS)
11075 MINT(22)=-MINT(21)
11076 KCC=27
11077 IF(MINT(16).EQ.21) KCC=28
11078
11079 ELSEIF(ISUB.EQ.85) THEN
11080C...gamma + gamma -> F + Fbar; th arbitary
11081 KCS=(-1)**INT(1.5D0+PYR(0))
11082 MINT(21)=ISIGN(MINT(56),KCS)
11083 MINT(22)=-MINT(21)
11084 KCC=21
11085
11086 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11087C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11088 MINT(21)=KFPR(ISUB,1)
11089 MINT(22)=KFPR(ISUB,2)
11090 KCC=24
11091 KCS=(-1)**INT(1.5D0+PYR(0))
11092 ENDIF
11093
11094 ELSEIF(ISUB.LE.100) THEN
11095 IF(ISUB.EQ.95) THEN
11096C...Low-pT ( = energyless g + g -> g + g)
11097 KCC=MINT(2)+12
11098 KCS=(-1)**INT(1.5D0+PYR(0))
11099
11100 ELSEIF(ISUB.EQ.96) THEN
11101C...Multiple interactions (should be reassigned to QCD process)
11102 ENDIF
11103
11104 ELSEIF(ISUB.LE.110) THEN
11105 IF(ISUB.EQ.101) THEN
11106C...g + g -> gamma*/Z0
11107 KCC=21
11108 KFRES=22
11109
11110 ELSEIF(ISUB.EQ.102) THEN
11111C...g + g -> h0 (or H0, or A0)
11112 KCC=21
11113 KFRES=KFHIGG
11114
11115 ELSEIF(ISUB.EQ.103) THEN
11116C...gamma + gamma -> h0 (or H0, or A0)
11117 KCC=21
11118 KFRES=KFHIGG
11119
11120 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11121C...g + g -> chi_0c or chi_2c.
11122 KCC=21
11123 KFRES=KFPR(ISUB,1)
11124
11125 ELSEIF(ISUB.EQ.106) THEN
11126C...g + g -> J/Psi + gamma
11127 MINT(21)=KFPR(ISUB,1)
11128 MINT(22)=KFPR(ISUB,2)
11129 KCC=21
11130
11131 ELSEIF(ISUB.EQ.107) THEN
11132C...g + gamma -> J/Psi + g
11133 MINT(21)=KFPR(ISUB,1)
11134 MINT(22)=KFPR(ISUB,2)
11135 KCC=22
11136 IF(MINT(16).EQ.22) KCC=33
11137
11138 ELSEIF(ISUB.EQ.108) THEN
11139C...gamma + gamma -> J/Psi + gamma
11140 MINT(21)=KFPR(ISUB,1)
11141 MINT(22)=KFPR(ISUB,2)
11142
11143 ELSEIF(ISUB.EQ.110) THEN
11144C...f + fbar -> gamma + h0; th arbitrary
11145 IF(PYR(0).GT.0.5D0) JS=2
11146 MINT(20+JS)=22
11147 MINT(23-JS)=KFHIGG
11148 ENDIF
11149
11150 ELSEIF(ISUB.LE.120) THEN
11151 IF(ISUB.EQ.111) THEN
11152C...f + fbar -> g + h0; th arbitrary
11153 IF(PYR(0).GT.0.5D0) JS=2
11154 MINT(20+JS)=21
11155 MINT(23-JS)=KFHIGG
11156 KCC=17+JS
11157
11158 ELSEIF(ISUB.EQ.112) THEN
11159C...f + g -> f + h0; th = (p(f) - p(f))**2
11160 IF(MINT(15).EQ.21) JS=2
11161 MINT(23-JS)=KFHIGG
11162 KCC=15+JS
11163 KCS=ISIGN(1,MINT(14+JS))
11164
11165 ELSEIF(ISUB.EQ.113) THEN
11166C...g + g -> g + h0; th arbitrary
11167 IF(PYR(0).GT.0.5D0) JS=2
11168 MINT(23-JS)=KFHIGG
11169 KCC=22+JS
11170 KCS=(-1)**INT(1.5D0+PYR(0))
11171
11172 ELSEIF(ISUB.EQ.114) THEN
11173C...g + g -> gamma + gamma; th arbitrary
11174 IF(PYR(0).GT.0.5D0) JS=2
11175 MINT(21)=22
11176 MINT(22)=22
11177 KCC=21
11178
11179 ELSEIF(ISUB.EQ.115) THEN
11180C...g + g -> g + gamma; th arbitrary
11181 IF(PYR(0).GT.0.5D0) JS=2
11182 MINT(23-JS)=22
11183 KCC=22+JS
11184 KCS=(-1)**INT(1.5D0+PYR(0))
11185
11186 ELSEIF(ISUB.EQ.116) THEN
11187C...g + g -> gamma + Z0
11188
11189 ELSEIF(ISUB.EQ.117) THEN
11190C...g + g -> Z0 + Z0
11191
11192 ELSEIF(ISUB.EQ.118) THEN
11193C...g + g -> W+ + W-
11194 ENDIF
11195
11196 ELSEIF(ISUB.LE.140) THEN
11197 IF(ISUB.EQ.121) THEN
11198C...g + g -> Q + Qbar + h0
11199 KCS=(-1)**INT(1.5D0+PYR(0))
11200 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11201 MINT(22)=-MINT(21)
11202 KCC=11+INT(0.5D0+PYR(0))
11203 KFRES=KFHIGG
11204
11205 ELSEIF(ISUB.EQ.122) THEN
11206C...q + qbar -> Q + Qbar + h0
11207 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11208 MINT(22)=-MINT(21)
11209 KCC=4
11210 KFRES=KFHIGG
11211
11212 ELSEIF(ISUB.EQ.123) THEN
11213C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11214C...inner process)
11215 KCC=22
11216 KFRES=KFHIGG
11217
11218 ELSEIF(ISUB.EQ.124) THEN
11219C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11220C...inner process)
11221 DO 430 JT=1,2
11222 I=MINT(14+JT)
11223 IA=IABS(I)
11224 IF(IA.LE.10) THEN
11225 RVCKM=VINT(180+I)*PYR(0)
11226 DO 420 J=1,MSTP(1)
11227 IB=2*J-1+MOD(IA,2)
11228 IPM=(5-ISIGN(1,I))/2
11229 IDC=J+MDCY(IA,2)+2
11230 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11231 MINT(20+JT)=ISIGN(IB,I)
11232 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11233 IF(RVCKM.LE.0D0) GOTO 430
11234 420 CONTINUE
11235 ELSE
11236 IB=2*((IA+1)/2)-1+MOD(IA,2)
11237 MINT(20+JT)=ISIGN(IB,I)
11238 ENDIF
11239 430 CONTINUE
11240 KCC=22
11241 KFRES=KFHIGG
11242
11243 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11244C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11245 IF(MINT(15).EQ.22) JS=2
11246 MINT(23-JS)=21
11247 KCC=24+JS
11248 KCS=ISIGN(1,MINT(14+JS))
11249
11250 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11251C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11252 IF(MINT(15).EQ.22) JS=2
11253 KCC=22
11254 KCS=ISIGN(1,MINT(14+JS))
11255
11256 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11257C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11258 KCS=(-1)**INT(1.5D0+PYR(0))
11259 MINT(21)=ISIGN(KFLF,KCS)
11260 MINT(22)=-MINT(21)
11261 KCC=27
11262 IF(MINT(16).EQ.21) KCC=28
11263
11264 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11265C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11266 KCS=(-1)**INT(1.5D0+PYR(0))
11267 MINT(21)=ISIGN(KFLF,KCS)
11268 MINT(22)=-MINT(21)
11269 KCC=21
11270
11271 ENDIF
11272
11273 ELSEIF(ISUB.LE.160) THEN
11274 IF(ISUB.EQ.141) THEN
11275C...f + fbar -> gamma*/Z0/Z'0
11276 KFRES=32
11277
11278 ELSEIF(ISUB.EQ.142) THEN
11279C...f + fbar' -> W'+/-
11280 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11281 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11282 KFRES=ISIGN(34,KCH1+KCH2)
11283
11284 ELSEIF(ISUB.EQ.143) THEN
11285C...f + fbar' -> H+/-
11286 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11287 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11288 KFRES=ISIGN(37,KCH1+KCH2)
11289
11290 ELSEIF(ISUB.EQ.144) THEN
11291C...f + fbar' -> R
11292 KFRES=ISIGN(41,MINT(15)+MINT(16))
11293
11294 ELSEIF(ISUB.EQ.145) THEN
11295C...q + l -> LQ (leptoquark)
11296 IF(IABS(MINT(16)).LE.8) JS=2
11297 KFRES=ISIGN(42,MINT(14+JS))
11298 KCC=28+JS
11299 KCS=ISIGN(1,MINT(14+JS))
11300
11301 ELSEIF(ISUB.EQ.146) THEN
11302C...e + gamma -> e* (excited lepton)
11303 IF(MINT(15).EQ.22) JS=2
11304 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11305 KCC=22
11306
11307 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11308C...q + g -> q* (excited quark)
11309 IF(MINT(15).EQ.21) JS=2
11310 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11311 KCC=30+JS
11312 KCS=ISIGN(1,MINT(14+JS))
11313
11314 ELSEIF(ISUB.EQ.149) THEN
11315C...g + g -> eta_tc
11316 KFRES=KTECHN+331
11317 KCC=23
11318 KCS=(-1)**INT(1.5D0+PYR(0))
11319 ENDIF
11320
11321 ELSEIF(ISUB.LE.200) THEN
11322 IF(ISUB.EQ.161) THEN
11323C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11324 IF(MINT(15).EQ.21) JS=2
11325 I=MINT(14+JS)
11326 IA=IABS(I)
11327 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11328 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11329 MINT(20+JS)=ISIGN(IB,I)
11330 KCC=15+JS
11331 KCS=ISIGN(1,MINT(14+JS))
11332
11333 ELSEIF(ISUB.EQ.162) THEN
11334C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11335 IF(MINT(15).EQ.21) JS=2
11336 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11337 KFLQL=KFDP(MDCY(42,2),2)
11338 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11339 KCC=15+JS
11340 KCS=ISIGN(1,MINT(14+JS))
11341
11342 ELSEIF(ISUB.EQ.163) THEN
11343C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11344 KCS=(-1)**INT(1.5D0+PYR(0))
11345 MINT(21)=ISIGN(42,KCS)
11346 MINT(22)=-MINT(21)
11347 KCC=MINT(2)+10
11348
11349 ELSEIF(ISUB.EQ.164) THEN
11350C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11351 MINT(21)=ISIGN(42,MINT(15))
11352 MINT(22)=-MINT(21)
11353 KCC=4
11354
11355 ELSEIF(ISUB.EQ.165) THEN
11356C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11357 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11358 MINT(22)=-MINT(21)
11359
11360 ELSEIF(ISUB.EQ.166) THEN
11361C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11362 IF(MOD(MINT(15),2).EQ.0) THEN
11363 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11364 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11365 ELSE
11366 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11367 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11368 ENDIF
11369
11370 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11371C...q + q' -> q" + q* (excited quark)
11372 KFQSTR=KFPR(ISUB,2)
11373 KFQEXC=MOD(KFQSTR,KEXCIT)
11374 JS=MINT(2)
11375 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11376 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11377 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11378 KCC=22
11379 JS=3-JS
11380
11381 ELSEIF(ISUB.EQ.169) THEN
11382C...q + qbar -> e + e* (excited lepton)
11383 KFQSTR=KFPR(ISUB,2)
11384 KFQEXC=MOD(KFQSTR,KEXCIT)
11385 JS=MINT(2)
11386 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11387 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11388 JS=3-JS
11389
11390 ELSEIF(ISUB.EQ.191) THEN
11391C...f + fbar -> rho_tc0.
11392 KFRES=KTECHN+113
11393
11394 ELSEIF(ISUB.EQ.192) THEN
11395C...f + fbar' -> rho_tc+/-
11396 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11397 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11398 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11399
11400 ELSEIF(ISUB.EQ.193) THEN
11401C...f + fbar -> omega_tc0.
11402 KFRES=KTECHN+223
11403
11404 ELSEIF(ISUB.EQ.194) THEN
11405C...f + fbar -> f' + fbar' via mixture of s-channel
11406C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11407 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11408 MINT(22)=-MINT(21)
11409
11410 ELSEIF(ISUB.EQ.195) THEN
11411C...f + fbar' -> f'' + fbar''' via s-channel
11412C...rho_tc+ th=(p(f)-p(f'))**2
11413C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11414 IF(MOD(MINT(15),2).EQ.0) THEN
11415 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11416 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11417 ELSE
11418 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11419 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11420 ENDIF
11421 ENDIF
11422
11423CMRENNA++
11424 ELSEIF(ISUB.LE.215) THEN
11425 IF(ISUB.EQ.201) THEN
11426C...f + fbar -> ~e_L + ~e_Lbar
11427 MINT(21)=ISIGN(KSUSY1+11,KCS)
11428 MINT(22)=-MINT(21)
11429
11430 ELSEIF(ISUB.EQ.202) THEN
11431C...f + fbar -> ~e_R + ~e_Rbar
11432 MINT(21)=ISIGN(KSUSY2+11,KCS)
11433 MINT(22)=-MINT(21)
11434
11435 ELSEIF(ISUB.EQ.203) THEN
11436C...f + fbar -> ~e_L + ~e_Rbar
11437 IF(MINT(15).LT.0) JS=2
11438 IF(MINT(2).EQ.1) THEN
11439 MINT(20+JS)=KFPR(ISUB,1)
11440 MINT(23-JS)=-KFPR(ISUB,2)
11441 ELSE
11442 MINT(20+JS)=-KFPR(ISUB,1)
11443 MINT(23-JS)=KFPR(ISUB,2)
11444 ENDIF
11445
11446 ELSEIF(ISUB.EQ.204) THEN
11447C...f + fbar -> ~mu_L + ~mu_Lbar
11448 MINT(21)=ISIGN(KSUSY1+13,KCS)
11449 MINT(22)=-MINT(21)
11450
11451 ELSEIF(ISUB.EQ.205) THEN
11452C...f + fbar -> ~mu_R + ~mu_Rbar
11453 MINT(21)=ISIGN(KSUSY2+13,KCS)
11454 MINT(22)=-MINT(21)
11455
11456 ELSEIF(ISUB.EQ.206) THEN
11457C...f + fbar -> ~mu_L + ~mu_Rbar
11458 IF(MINT(15).LT.0) JS=2
11459 IF(MINT(2).EQ.1) THEN
11460 MINT(20+JS)=KFPR(ISUB,1)
11461 MINT(23-JS)=-KFPR(ISUB,2)
11462 ELSE
11463 MINT(20+JS)=-KFPR(ISUB,1)
11464 MINT(23-JS)=KFPR(ISUB,2)
11465 ENDIF
11466
11467 ELSEIF(ISUB.EQ.207) THEN
11468C...f + fbar -> ~tau_1 + ~tau_1bar
11469 MINT(21)=ISIGN(KSUSY1+15,KCS)
11470 MINT(22)=-MINT(21)
11471
11472 ELSEIF(ISUB.EQ.208) THEN
11473C...f + fbar -> ~tau_2 + ~tau_2bar
11474 MINT(21)=ISIGN(KSUSY2+15,KCS)
11475 MINT(22)=-MINT(21)
11476
11477 ELSEIF(ISUB.EQ.209) THEN
11478C...f + fbar -> ~tau_1 + ~tau_2bar
11479 IF(MINT(15).LT.0) JS=2
11480 IF(MINT(2).EQ.1) THEN
11481 MINT(20+JS)=KFPR(ISUB,1)
11482 MINT(23-JS)=-KFPR(ISUB,2)
11483 ELSE
11484 MINT(20+JS)=-KFPR(ISUB,1)
11485 MINT(23-JS)=KFPR(ISUB,2)
11486 ENDIF
11487
11488 ELSEIF(ISUB.EQ.210) THEN
11489C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11490 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11491 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11492 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11493 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11494
11495 ELSEIF(ISUB.EQ.211) THEN
11496C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11497 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11498 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11499 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11500 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11501
11502 ELSEIF(ISUB.EQ.212) THEN
11503C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11504 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11505 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11506 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11507 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11508
11509 ELSEIF(ISUB.EQ.213) THEN
11510C...f + fbar -> ~nul + ~nulbar
11511 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11512 MINT(22)=-MINT(21)
11513
11514 ELSEIF(ISUB.EQ.214) THEN
11515C...f + fbar -> ~nutau + ~nutaubar
11516 MINT(21)=ISIGN(KSUSY1+16,KCS)
11517 MINT(22)=-MINT(21)
11518 ENDIF
11519
11520 ELSEIF(ISUB.LE.225) THEN
11521 IF(ISUB.EQ.216) THEN
11522C...f + fbar -> ~chi01 + ~chi01
11523 MINT(21)=KSUSY1+22
11524 MINT(22)=KSUSY1+22
11525
11526 ELSEIF(ISUB.EQ.217) THEN
11527C...f + fbar -> ~chi02 + ~chi02
11528 MINT(21)=KSUSY1+23
11529 MINT(22)=KSUSY1+23
11530
11531 ELSEIF(ISUB.EQ.218 ) THEN
11532C...f + fbar -> ~chi03 + ~chi03
11533 MINT(21)=KSUSY1+25
11534 MINT(22)=KSUSY1+25
11535
11536 ELSEIF(ISUB.EQ.219 ) THEN
11537C...f + fbar -> ~chi04 + ~chi04
11538 MINT(21)=KSUSY1+35
11539 MINT(22)=KSUSY1+35
11540
11541 ELSEIF(ISUB.EQ.220 ) THEN
11542C...f + fbar -> ~chi01 + ~chi02
11543 IF(MINT(15).LT.0) JS=2
11544C IF(PYR(0).GT.0.5D0) JS=2
11545 MINT(20+JS)=KSUSY1+22
11546 MINT(23-JS)=KSUSY1+23
11547
11548 ELSEIF(ISUB.EQ.221 ) THEN
11549C...f + fbar -> ~chi01 + ~chi03
11550 IF(MINT(15).LT.0) JS=2
11551C IF(PYR(0).GT.0.5D0) JS=2
11552 MINT(20+JS)=KSUSY1+22
11553 MINT(23-JS)=KSUSY1+25
11554
11555 ELSEIF(ISUB.EQ.222) THEN
11556C...f + fbar -> ~chi01 + ~chi04
11557 IF(MINT(15).LT.0) JS=2
11558C IF(PYR(0).GT.0.5D0) JS=2
11559 MINT(20+JS)=KSUSY1+22
11560 MINT(23-JS)=KSUSY1+35
11561
11562 ELSEIF(ISUB.EQ.223) THEN
11563C...f + fbar -> ~chi02 + ~chi03
11564 IF(MINT(15).LT.0) JS=2
11565C IF(PYR(0).GT.0.5D0) JS=2
11566 MINT(20+JS)=KSUSY1+23
11567 MINT(23-JS)=KSUSY1+25
11568
11569 ELSEIF(ISUB.EQ.224) THEN
11570C...f + fbar -> ~chi02 + ~chi04
11571 IF(MINT(15).LT.0) JS=2
11572C IF(PYR(0).GT.0.5D0) JS=2
11573 MINT(20+JS)=KSUSY1+23
11574 MINT(23-JS)=KSUSY1+35
11575
11576 ELSEIF(ISUB.EQ.225) THEN
11577C...f + fbar -> ~chi03 + ~chi04
11578 IF(MINT(15).LT.0) JS=2
11579C IF(PYR(0).GT.0.5D0) JS=2
11580 MINT(20+JS)=KSUSY1+25
11581 MINT(23-JS)=KSUSY1+35
11582 ENDIF
11583
11584 ELSEIF(ISUB.LE.236) THEN
11585 IF(ISUB.EQ.226) THEN
11586C...f + fbar -> ~chi+-1 + ~chi-+1
11587C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11588 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11589 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11590 MINT(22)=-MINT(21)
11591
11592 ELSEIF(ISUB.EQ.227) THEN
11593C...f + fbar -> ~chi+-2 + ~chi-+2
11594 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11595 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11596 MINT(22)=-MINT(21)
11597
11598 ELSEIF(ISUB.EQ.228) THEN
11599C...f + fbar -> ~chi+-1 + ~chi-+2
11600C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11601C...js=1 if pyr<.5, js=2 if pyr>.5
11602C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11603C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11604C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11605C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11606 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11607 KCH2=INT(1-KCH1)/2
11608 IF(MINT(2).EQ.1) THEN
11609 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11610 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11611c IF(KCH2.EQ.0) JS=2
11612 ELSE
11613 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11614 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11615 JS=2
11616c IF(KCH2.EQ.1) JS=2
11617 ENDIF
11618
11619 ELSEIF(ISUB.EQ.229) THEN
11620C...q + qbar' -> ~chi01 + ~chi+-1
11621C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11622 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11623 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11624C...CHECK THIS
11625 IF(MOD(MINT(15),2).EQ.0) JS=2
11626 MINT(20+JS)=KSUSY1+22
11627 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11628
11629 ELSEIF(ISUB.EQ.230) THEN
11630C...q + qbar' -> ~chi02 + ~chi+-1
11631 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11632 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11633 IF(MOD(MINT(15),2).EQ.0) JS=2
11634 MINT(20+JS)=KSUSY1+23
11635 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11636
11637 ELSEIF(ISUB.EQ.231) THEN
11638C...q + qbar' -> ~chi03 + ~chi+-1
11639 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11640 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11641 IF(MOD(MINT(15),2).EQ.0) JS=2
11642 MINT(20+JS)=KSUSY1+25
11643 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11644
11645 ELSEIF(ISUB.EQ.232) THEN
11646C...q + qbar' -> ~chi04 + ~chi+-1
11647 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11648 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11649 IF(MOD(MINT(15),2).EQ.0) JS=2
11650 MINT(20+JS)=KSUSY1+35
11651 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11652
11653 ELSEIF(ISUB.EQ.233) THEN
11654C...q + qbar' -> ~chi01 + ~chi+-2
11655 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11656 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11657 IF(MOD(MINT(15),2).EQ.0) JS=2
11658 MINT(20+JS)=KSUSY1+22
11659 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11660
11661 ELSEIF(ISUB.EQ.234) THEN
11662C...q + qbar' -> ~chi02 + ~chi+-2
11663 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11664 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11665 IF(MOD(MINT(15),2).EQ.0) JS=2
11666 MINT(20+JS)=KSUSY1+23
11667 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11668
11669 ELSEIF(ISUB.EQ.235) THEN
11670C...q + qbar' -> ~chi03 + ~chi+-2
11671 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11672 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11673 IF(MOD(MINT(15),2).EQ.0) JS=2
11674 MINT(20+JS)=KSUSY1+25
11675 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11676
11677 ELSEIF(ISUB.EQ.236) THEN
11678C...q + qbar' -> ~chi04 + ~chi+-2
11679 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11680 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11681 IF(MOD(MINT(15),2).EQ.0) JS=2
11682 MINT(20+JS)=KSUSY1+35
11683 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11684 ENDIF
11685
11686 ELSEIF(ISUB.LE.245) THEN
11687 IF(ISUB.EQ.237) THEN
11688C...q + qbar -> ~chi01 + ~g
11689C...th arbitrary
11690 IF(PYR(0).GT.0.5D0) JS=2
11691 MINT(20+JS)=KSUSY1+21
11692 MINT(23-JS)=KSUSY1+22
11693 KCC=17+JS
11694
11695 ELSEIF(ISUB.EQ.238) THEN
11696C...q + qbar -> ~chi02 + ~g
11697C...th arbitrary
11698 IF(PYR(0).GT.0.5D0) JS=2
11699 MINT(20+JS)=KSUSY1+21
11700 MINT(23-JS)=KSUSY1+23
11701 KCC=17+JS
11702
11703 ELSEIF(ISUB.EQ.239) THEN
11704C...q + qbar -> ~chi03 + ~g
11705C...th arbitrary
11706 IF(PYR(0).GT.0.5D0) JS=2
11707 MINT(20+JS)=KSUSY1+21
11708 MINT(23-JS)=KSUSY1+25
11709 KCC=17+JS
11710
11711 ELSEIF(ISUB.EQ.240) THEN
11712C...q + qbar -> ~chi04 + ~g
11713C...th arbitrary
11714 IF(PYR(0).GT.0.5D0) JS=2
11715 MINT(20+JS)=KSUSY1+21
11716 MINT(23-JS)=KSUSY1+35
11717 KCC=17+JS
11718
11719 ELSEIF(ISUB.EQ.241) THEN
11720C...q + qbar' -> ~chi+-1 + ~g
11721C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11722C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11723C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11724C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11725C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11726 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11727 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11728 JS=1
11729 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11730 MINT(20+JS)=KSUSY1+21
11731 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11732 KCC=17+JS
11733
11734 ELSEIF(ISUB.EQ.242) THEN
11735C...q + qbar' -> ~chi+-2 + ~g
11736C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
11737C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
11738C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
11739C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
11740C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
11741 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11742 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11743 JS=1
11744 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11745 MINT(20+JS)=KSUSY1+21
11746 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
11747 KCC=17+JS
11748
11749 ELSEIF(ISUB.EQ.243) THEN
11750C...q + qbar -> ~g + ~g ; th arbitrary
11751 MINT(21)=KSUSY1+21
11752 MINT(22)=KSUSY1+21
11753 KCC=MINT(2)+4
11754
11755 ELSEIF(ISUB.EQ.244) THEN
11756C...g + g -> ~g + ~g ; th arbitrary
11757 KCC=MINT(2)+12
11758 KCS=(-1)**INT(1.5D0+PYR(0))
11759 MINT(21)=KSUSY1+21
11760 MINT(22)=KSUSY1+21
11761 ENDIF
11762
11763 ELSEIF(ISUB.LE.260) THEN
11764 IF(ISUB.EQ.246) THEN
11765C...qj + g -> ~qj_L + ~chi01
11766 IF(MINT(15).EQ.21) JS=2
11767 I=MINT(14+JS)
11768 IA=IABS(I)
11769 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11770 MINT(23-JS)=KSUSY1+22
11771 KCC=15+JS
11772 KCS=ISIGN(1,MINT(14+JS))
11773
11774 ELSEIF(ISUB.EQ.247) THEN
11775C...qj + g -> ~qj_R + ~chi01
11776 IF(MINT(15).EQ.21) JS=2
11777 I=MINT(14+JS)
11778 IA=IABS(I)
11779 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11780 MINT(23-JS)=KSUSY1+22
11781 KCC=15+JS
11782 KCS=ISIGN(1,MINT(14+JS))
11783
11784 ELSEIF(ISUB.EQ.248) THEN
11785C...qj + g -> ~qj_L + ~chi02
11786 IF(MINT(15).EQ.21) JS=2
11787 I=MINT(14+JS)
11788 IA=IABS(I)
11789 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11790 MINT(23-JS)=KSUSY1+23
11791 KCC=15+JS
11792 KCS=ISIGN(1,MINT(14+JS))
11793
11794 ELSEIF(ISUB.EQ.249) THEN
11795C...qj + g -> ~qj_R + ~chi02
11796 IF(MINT(15).EQ.21) JS=2
11797 I=MINT(14+JS)
11798 IA=IABS(I)
11799 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11800 MINT(23-JS)=KSUSY1+23
11801 KCC=15+JS
11802 KCS=ISIGN(1,MINT(14+JS))
11803
11804 ELSEIF(ISUB.EQ.250) THEN
11805C...qj + g -> ~qj_L + ~chi03
11806 IF(MINT(15).EQ.21) JS=2
11807 I=MINT(14+JS)
11808 IA=IABS(I)
11809 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11810 MINT(23-JS)=KSUSY1+25
11811 KCC=15+JS
11812 KCS=ISIGN(1,MINT(14+JS))
11813
11814 ELSEIF(ISUB.EQ.251) THEN
11815C...qj + g -> ~qj_R + ~chi03
11816 IF(MINT(15).EQ.21) JS=2
11817 I=MINT(14+JS)
11818 IA=IABS(I)
11819 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11820 MINT(23-JS)=KSUSY1+25
11821 KCC=15+JS
11822 KCS=ISIGN(1,MINT(14+JS))
11823
11824 ELSEIF(ISUB.EQ.252) THEN
11825C...qj + g -> ~qj_L + ~chi04
11826 IF(MINT(15).EQ.21) JS=2
11827 I=MINT(14+JS)
11828 IA=IABS(I)
11829 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11830 MINT(23-JS)=KSUSY1+35
11831 KCC=15+JS
11832 KCS=ISIGN(1,MINT(14+JS))
11833
11834 ELSEIF(ISUB.EQ.253) THEN
11835C...qj + g -> ~qj_R + ~chi04
11836 IF(MINT(15).EQ.21) JS=2
11837 I=MINT(14+JS)
11838 IA=IABS(I)
11839 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11840 MINT(23-JS)=KSUSY1+35
11841 KCC=15+JS
11842 KCS=ISIGN(1,MINT(14+JS))
11843
11844 ELSEIF(ISUB.EQ.254) THEN
11845C...qj + g -> ~qk_L + ~chi+-1
11846 IF(MINT(15).EQ.21) JS=2
11847 I=MINT(14+JS)
11848 IA=IABS(I)
11849 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11850 IB=-IA+INT((IA+1)/2)*4-1
11851 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11852 KCC=15+JS
11853 KCS=ISIGN(1,MINT(14+JS))
11854
11855 ELSEIF(ISUB.EQ.255) THEN
11856C...qj + g -> ~qk_L + ~chi+-1
11857 IF(MINT(15).EQ.21) JS=2
11858 I=MINT(14+JS)
11859 IA=IABS(I)
11860 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
11861 IB=-IA+INT((IA+1)/2)*4-1
11862 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11863 KCC=15+JS
11864 KCS=ISIGN(1,MINT(14+JS))
11865
11866 ELSEIF(ISUB.EQ.256) THEN
11867C...qj + g -> ~qk_L + ~chi+-2
11868 IF(MINT(15).EQ.21) JS=2
11869 I=MINT(14+JS)
11870 IA=IABS(I)
11871 IB=-IA+INT((IA+1)/2)*4-1
11872 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
11873 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11874 KCC=15+JS
11875 KCS=ISIGN(1,MINT(14+JS))
11876
11877 ELSEIF(ISUB.EQ.257) THEN
11878C...qj + g -> ~qk_R + ~chi+-2
11879 IF(MINT(15).EQ.21) JS=2
11880 I=MINT(14+JS)
11881 IA=IABS(I)
11882 IB=-IA+INT((IA+1)/2)*4-1
11883 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
11884 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
11885 KCC=15+JS
11886 KCS=ISIGN(1,MINT(14+JS))
11887
11888 ELSEIF(ISUB.EQ.258) THEN
11889C...qj + g -> ~qj_L + ~g
11890 IF(MINT(15).EQ.21) JS=2
11891 I=MINT(14+JS)
11892 IA=IABS(I)
11893 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
11894 MINT(23-JS)=KSUSY1+21
11895 KCC=MINT(2)+6
11896 IF(JS.EQ.2) KCC=KCC+2
11897 KCS=ISIGN(1,I)
11898
11899 ELSEIF(ISUB.EQ.259) THEN
11900C...qj + g -> ~qj_R + ~g
11901 IF(MINT(15).EQ.21) JS=2
11902 I=MINT(14+JS)
11903 IA=IABS(I)
11904 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
11905 MINT(23-JS)=KSUSY1+21
11906 KCC=MINT(2)+6
11907 IF(JS.EQ.2) KCC=KCC+2
11908 KCS=ISIGN(1,I)
11909 ENDIF
11910
11911 ELSEIF(ISUB.LE.270) THEN
11912 IF(ISUB.EQ.261) THEN
11913C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
11914 ISGN=1
11915 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11916 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11917 MINT(22)=-MINT(21)
11918C...Correct color combination
11919 IF(MINT(43).EQ.4) KCC=4
11920
11921 ELSEIF(ISUB.EQ.262) THEN
11922C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
11923 ISGN=1
11924 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
11925 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
11926 MINT(22)=-MINT(21)
11927C...Correct color combination
11928 IF(MINT(43).EQ.4) KCC=4
11929
11930 ELSEIF(ISUB.EQ.263) THEN
11931C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
11932 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
11933 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
11934 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11935 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
11936 ELSE
11937 JS=2
11938 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
11939 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
11940 ENDIF
11941C...Correct color combination
11942 IF(MINT(43).EQ.4) KCC=4
11943
11944 ELSEIF(ISUB.EQ.264) THEN
11945C...g + g -> ~t_1 + ~t_1bar; th arbitrary
11946 KCS=(-1)**INT(1.5D0+PYR(0))
11947 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11948 MINT(22)=-MINT(21)
11949 KCC=MINT(2)+10
11950
11951 ELSEIF(ISUB.EQ.265) THEN
11952C...g + g -> ~t_2 + ~t_2bar; th arbitrary
11953 KCS=(-1)**INT(1.5D0+PYR(0))
11954 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11955 MINT(22)=-MINT(21)
11956 KCC=MINT(2)+10
11957 ENDIF
11958
11959 ELSEIF(ISUB.LE.296) THEN
11960 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
11961C...qi + qj -> ~qi_L + ~qj_L
11962 KCC=MINT(2)
11963 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11964 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11965 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11966
11967 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
11968C...qi + qj -> ~qi_R + ~qj_R
11969 KCC=MINT(2)
11970 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11971 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11972 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11973
11974 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
11975C...qi + qj -> ~qi_L + ~qj_R
11976 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11977 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11978 KCC=MINT(2)
11979 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11980
11981 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
11982C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
11983 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
11984 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
11985 KCC=MINT(2)
11986 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11987
11988 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
11989C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11990 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
11991 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
11992 KCC=MINT(2)
11993 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
11994
11995 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
11996C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
11997 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11998 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
11999 KCC=MINT(2)
12000 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12001
12002 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12003C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12004 ISGN=1
12005 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12006 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12007 MINT(22)=-MINT(21)
12008 IF(MINT(43).EQ.4) KCC=4
12009
12010 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12011C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12012 ISGN=1
12013 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12014 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12015 MINT(22)=-MINT(21)
12016 IF(MINT(43).EQ.4) KCC=4
12017
12018 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12019C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12020C...pure LL + RR
12021 KCS=(-1)**INT(1.5D0+PYR(0))
12022 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12023 MINT(22)=-MINT(21)
12024 KCC=MINT(2)+10
12025
12026 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12027C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12028 KCS=(-1)**INT(1.5D0+PYR(0))
12029 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12030 MINT(22)=-MINT(21)
12031 KCC=MINT(2)+10
12032
12033 ELSEIF(ISUB.EQ.294) THEN
12034C...qj + g -> ~qj_L + ~g
12035 IF(MINT(15).EQ.21) JS=2
12036 I=MINT(14+JS)
12037 IA=IABS(I)
12038 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12039 MINT(23-JS)=KSUSY1+21
12040 KCC=MINT(2)+6
12041 IF(JS.EQ.2) KCC=KCC+2
12042 KCS=ISIGN(1,I)
12043
12044 ELSEIF(ISUB.EQ.295) THEN
12045C...qj + g -> ~qj_R + ~g
12046 IF(MINT(15).EQ.21) JS=2
12047 I=MINT(14+JS)
12048 IA=IABS(I)
12049 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12050 MINT(23-JS)=KSUSY1+21
12051 KCC=MINT(2)+6
12052 IF(JS.EQ.2) KCC=KCC+2
12053 KCS=ISIGN(1,I)
12054 ENDIF
12055
12056 ELSEIF(ISUB.LE.340) THEN
12057
12058 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12059C...q + qbar' -> H+ + H0
12060 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12061 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12062 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12063 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12064 MINT(23-JS)=KFPR(ISUB,2)
12065 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12066C...f + fbar -> A0 + H0; th arbitrary
12067 IF(PYR(0).GT.0.5D0) JS=2
12068 MINT(20+JS)=KFPR(ISUB,1)
12069 MINT(23-JS)=KFPR(ISUB,2)
12070 ELSEIF(ISUB.EQ.301) THEN
12071C...f + fbar -> H+ H-
12072 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12073 MINT(22)=-MINT(21)
12074 ENDIF
12075CMRENNA--
12076
12077 ELSEIF(ISUB.LE.360) THEN
12078
12079 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12080C...l + l -> H_L++/--, H_R++/--
12081 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12082 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12083 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12084
12085 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12086C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12087 IF(MINT(15).EQ.22) JS=2
12088 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12089 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12090 KCC=22
12091
12092 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12093C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12094 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12095 MINT(22)=-MINT(21)
12096
12097 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12098C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12099C...as inner process).
12100 DO 450 JT=1,2
12101 I=MINT(14+JT)
12102 IA=IABS(I)
12103 IF(IA.LE.10) THEN
12104 RVCKM=VINT(180+I)*PYR(0)
12105 DO 440 J=1,MSTP(1)
12106 IB=2*J-1+MOD(IA,2)
12107 IPM=(5-ISIGN(1,I))/2
12108 IDC=J+MDCY(IA,2)+2
12109 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12110 MINT(20+JT)=ISIGN(IB,I)
12111 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12112 IF(RVCKM.LE.0D0) GOTO 450
12113 440 CONTINUE
12114 ELSE
12115 IB=2*((IA+1)/2)-1+MOD(IA,2)
12116 MINT(20+JT)=ISIGN(IB,I)
12117 ENDIF
12118 450 CONTINUE
12119 KCC=22
12120 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12121 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12122
12123 ELSEIF(ISUB.EQ.353) THEN
12124C...f + fbar -> Z_R0
12125 KFRES=KFPR(ISUB,1)
12126
12127 ELSEIF(ISUB.EQ.354) THEN
12128C...f + fbar' -> W+/-
12129 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12130 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12131 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12132
12133 ENDIF
12134
12135 ELSEIF(ISUB.LE.380) THEN
12136
12137 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12138C...f + fbar -> charged+ charged- technicolor
12139 KSW=(-1)**INT(1.5D0+PYR(0))
12140 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12141 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12142
12143 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12144C...f + fbar -> neutral neutral technicolor
12145 MINT(21)=KFPR(ISUB,1)
12146 MINT(22)=KFPR(ISUB,2)
12147
12148 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12149C...f + fbar' -> neutral charged technicolor
12150 IN=1
12151 IC=2
12152 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12153 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12154 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12155 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12156 MINT(20+JS)=KFPR(ISUB,IN)
12157
12158 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12159C...f + fbar' -> charged neutral technicolor
12160 IN=2
12161 IC=1
12162 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12163 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12164 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12165 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12166 MINT(23-JS)=KFPR(ISUB,IN)
12167 ENDIF
12168
12169 ELSEIF(ISUB.LE.400) THEN
12170 IF(ISUB.EQ.381) THEN
12171C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12172 KCC=MINT(2)
12173 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12174
12175 ELSEIF(ISUB.EQ.382) THEN
12176C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12177 MINT(21)=ISIGN(KFLF,MINT(15))
12178 MINT(22)=-MINT(21)
12179 KCC=4
12180
12181 ELSEIF(ISUB.EQ.383) THEN
12182C...f + fbar -> g + g; th arbitrary, TC extensions
12183 MINT(21)=21
12184 MINT(22)=21
12185 KCC=MINT(2)+4
12186
12187 ELSEIF(ISUB.EQ.384) THEN
12188C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12189 IF(MINT(15).EQ.21) JS=2
12190 KCC=MINT(2)+6
12191 IF(MINT(15).EQ.21) KCC=KCC+2
12192 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12193 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12194
12195 ELSEIF(ISUB.EQ.385) THEN
12196C...g + g -> f + fbar; th arbitrary, TC extensions
12197 KCS=(-1)**INT(1.5D0+PYR(0))
12198 MINT(21)=ISIGN(KFLF,KCS)
12199 MINT(22)=-MINT(21)
12200 KCC=MINT(2)+10
12201
12202 ELSEIF(ISUB.EQ.386) THEN
12203C...g + g -> g + g; th arbitrary, TC extensions
12204 KCC=MINT(2)+12
12205 KCS=(-1)**INT(1.5D0+PYR(0))
12206
12207 ELSEIF(ISUB.EQ.387) THEN
12208C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12209 MINT(21)=ISIGN(MINT(55),MINT(15))
12210 MINT(22)=-MINT(21)
12211 KCC=4
12212
12213 ELSEIF(ISUB.EQ.388) THEN
12214C...g + g -> Q + Qbar; th arbitrary, TC extensions
12215 KCS=(-1)**INT(1.5D0+PYR(0))
12216 MINT(21)=ISIGN(MINT(55),KCS)
12217 MINT(22)=-MINT(21)
12218 KCC=MINT(2)+10
12219
12220 ELSEIF(ISUB.EQ.391) THEN
12221C...f + fbar -> G*.
12222 KFRES=KFPR(ISUB,1)
12223
12224 ELSEIF(ISUB.EQ.392) THEN
12225C...g + g -> G*.
12226 KCC=21
12227 KFRES=KFPR(ISUB,1)
12228
12229 ELSEIF(ISUB.EQ.393) THEN
12230C...q + qbar -> g + G*; th arbitrary.
12231 IF(PYR(0).GT.0.5D0) JS=2
12232 MINT(20+JS)=KFPR(ISUB,1)
12233 MINT(23-JS)=KFPR(ISUB,2)
12234 KCC=17+JS
12235
12236 ELSEIF(ISUB.EQ.394) THEN
12237C...q + g -> q + G*; th = (p(f) - p(f))**2
12238 IF(MINT(15).EQ.21) JS=2
12239 MINT(23-JS)=KFPR(ISUB,2)
12240 KCC=15+JS
12241 KCS=ISIGN(1,MINT(14+JS))
12242
12243 ELSEIF(ISUB.EQ.395) THEN
12244C...g + g -> G* + g; th arbitrary.
12245 IF(PYR(0).GT.0.5D0) JS=2
12246 MINT(23-JS)=KFPR(ISUB,2)
12247 KCC=22+JS
12248 ENDIF
12249
12250 ELSEIF(ISUB.LE.420) THEN
12251 IF(ISUB.EQ.401) THEN
12252C...g + g -> t + b + H+/-
12253 KCS=(-1)**INT(1.5D0+PYR(0))
12254 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12255 MINT(22)=ISIGN(5,-KCS)
12256 KCC=11+INT(0.5D0+PYR(0))
12257 KFRES=ISIGN(KFHIGG,-KCS)
12258
12259 ELSEIF(ISUB.EQ.402) THEN
12260C...q + qbar -> t + b + H+/-
12261 KFL=(-1)**INT(1.5D0+PYR(0))
12262 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12263 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12264 KCC=4
12265 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12266 ENDIF
12267
12268C...QUARKONIA+++
12269C...Additional code by Stefan Wolf
12270 ELSEIF(ISUB.LE.430) THEN
12271 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12272C...g + g -> QQ~[n] + g
12273C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12274C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12275C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12276C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12277C...or from ISUB.EQ.68 (for ISUB.NE.421)
12278C...[g + g -> g + g; th arbitrary]
12279 MINT(21)=KFPR(ISUBSV,1)
12280 MINT(22)=KFPR(ISUBSV,2)
12281 IF(ISUB.EQ.421) THEN
12282 KCC=24
12283 KCS=(-1)**INT(1.5D0+PYR(0))
12284 ELSE
12285 KCC=MINT(2)+12
12286 KCS=(-1)**INT(1.5D0+PYR(0))
12287 ENDIF
12288
12289 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12290C...q + g -> q + QQ~[n]
12291C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12292C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12293C...KCC copied from ISUB.EQ.28
12294C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12295 IF(MINT(15).EQ.21) JS=2
12296 MINT(23-JS)=KFPR(ISUBSV,2)
12297 KCC=MINT(2)+6
12298 IF(MINT(15).EQ.21) KCC=KCC+2
12299 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12300 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12301
12302 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12303C...q + q~ -> g + QQ~[n]
12304C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12305C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12306C...KCC copied from ISUB.EQ.13
12307C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12308 IF(PYR(0).GT.0.5) JS=2
12309 MINT(20+JS)=21
12310 MINT(23-JS)=KFPR(ISUBSV,2)
12311 KCC=MINT(2)+4
12312 ENDIF
12313
12314 ELSEIF(ISUB.LE.440) THEN
12315 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12316C...g + g -> QQ~[n] + g
12317C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12318C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12319C...KCC and KCS copied from ISUB.EQ.86-89
12320C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12321 MINT(21)=KFPR(ISUBSV,1)
12322 MINT(22)=KFPR(ISUBSV,2)
12323 KCC=24
12324 KCS=(-1)**INT(1.5D0+PYR(0))
12325
12326 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12327C...q + g -> q + QQ~[n]
12328C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12329C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12330C...KCC and KCS copied from ISUB.EQ.112
12331C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12332 IF(MINT(15).EQ.21) JS=2
12333 MINT(23-JS)=KFPR(ISUBSV,2)
12334 KCC=15+JS
12335 KCS=ISIGN(1,MINT(14+JS))
12336
12337 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12338C...q + q~ -> g + QQ~[n]
12339C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12340C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12341C...KCC copied from ISUB.EQ.111
12342C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12343 IF(PYR(0).GT.0.5) JS=2
12344 MINT(20+JS)=21
12345 MINT(23-JS)=KFPR(ISUBSV,2)
12346 KCC=17+JS
12347 ENDIF
12348C...QUARKONIA---
12349
12350 ENDIF
12351
12352 IF(ISET(ISUB).EQ.11) THEN
12353C...Store documentation for user-defined processes
12354 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12355 KUPPO(1)=MINT(83)+5
12356 KUPPO(2)=MINT(83)+6
12357 I=MINT(83)+6
12358 DO 470 IUP=3,NUP
12359 KUPPO(IUP)=0
12360 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12361 IDOC=IDOC-1
12362 MINT(4)=MINT(4)-1
12363 GOTO 470
12364 ENDIF
12365 I=I+1
12366 KUPPO(IUP)=I
12367 K(I,1)=21
12368 K(I,2)=IDUP(IUP)
12369 IF(IDUP(IUP).EQ.0) K(I,2)=90
12370 K(I,3)=0
12371 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12372 K(I,4)=0
12373 K(I,5)=0
12374 DO 460 J=1,5
12375 P(I,J)=PUP(J,IUP)
12376 460 CONTINUE
12377 V(I,5)=VTIMUP(IUP)
12378 470 CONTINUE
12379 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12380 & -BEZUP)
12381
12382C...Store final state partons for user-defined processes
12383 N=IPU2
12384 DO 490 IUP=3,NUP
12385 N=N+1
12386 K(N,1)=1
12387 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12388 K(N,2)=IDUP(IUP)
12389 IF(IDUP(IUP).EQ.0) K(N,2)=90
12390 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12391 K(N,3)=KUPPO(IUP)
12392 ELSE
12393 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12394 ENDIF
12395 K(N,4)=0
12396 K(N,5)=0
12397C...Search for daughters of intermediate colourless particles.
12398 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12399 DO 475 IUPDAU=IUP+1,NUP
12400 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12401 & N+IUPDAU-IUP
12402 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12403 475 CONTINUE
12404 ENDIF
12405 DO 480 J=1,5
12406 P(N,J)=PUP(J,IUP)
12407 480 CONTINUE
12408 V(N,5)=VTIMUP(IUP)
12409 490 CONTINUE
12410 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12411
12412C...Arrange colour flow for user-defined processes
12413 NLBL=0
12414 DO 540 IUP1=1,NUP
12415 I1=MINT(84)+IUP1
12416 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12417 IF(K(I1,1).EQ.1) K(I1,1)=3
12418 IF(K(I1,1).EQ.11) K(I1,1)=14
12419C...Find a not yet considered colour/anticolour line.
12420 DO 530 ISDE1=1,2
12421 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12422 NMAT=0
12423 DO 500 ILBL=1,NLBL
12424 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12425 500 CONTINUE
12426 IF(NMAT.EQ.0) THEN
12427 NLBL=NLBL+1
12428 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12429C...Find all others belonging to same line.
12430 I3=I1
12431 I4=0
12432 DO 520 IUP2=IUP1+1,NUP
12433 I2=MINT(84)+IUP2
12434 DO 510 ISDE2=1,2
12435 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12436 IF(ISDE2.EQ.ISDE1) THEN
12437 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12438 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12439 I3=I2
12440 ELSEIF(I4.NE.0) THEN
12441 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12442 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12443 I4=I2
12444 ELSEIF(IUP2.LE.2) THEN
12445 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12446 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12447 I4=I2
12448 ELSE
12449 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12450 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12451 I4=I2
12452 ENDIF
12453 ENDIF
12454 510 CONTINUE
12455 520 CONTINUE
12456 ENDIF
12457 530 CONTINUE
12458 540 CONTINUE
12459
12460 ELSEIF(IDOC.EQ.7) THEN
12461C...Resonance not decaying; store kinematics
12462 I=MINT(83)+7
12463 K(IPU3,1)=1
12464 K(IPU3,2)=KFRES
12465 K(IPU3,3)=I
12466 P(IPU3,4)=SHUSER
12467 P(IPU3,5)=SHUSER
12468 K(I,1)=21
12469 K(I,2)=KFRES
12470 P(I,4)=SHUSER
12471 P(I,5)=SHUSER
12472 N=IPU3
12473 MINT(21)=KFRES
12474 MINT(22)=0
12475
12476C...Special cases: colour flow in coloured resonances
12477 KCRES=PYCOMP(KFRES)
12478 IF(KCHG(KCRES,2).NE.0) THEN
12479 K(IPU3,1)=3
12480 DO 550 J=1,2
12481 JC=J
12482 IF(KCS.EQ.-1) JC=3-J
12483 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12484 & MINT(84)+ICOL(KCC,1,JC)
12485 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12486 & MINT(84)+ICOL(KCC,2,JC)
12487 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12488 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12489 550 CONTINUE
12490 ELSE
12491 K(IPU1,4)=IPU2
12492 K(IPU1,5)=IPU2
12493 K(IPU2,4)=IPU1
12494 K(IPU2,5)=IPU1
12495 ENDIF
12496
12497 ELSEIF(IDOC.EQ.8) THEN
12498C...2 -> 2 processes: store outgoing partons in their CM-frame
12499 DO 560 JT=1,2
12500 I=MINT(84)+2+JT
12501 KCA=PYCOMP(MINT(20+JT))
12502 K(I,1)=1
12503 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12504 K(I,2)=MINT(20+JT)
12505 K(I,3)=MINT(83)+IDOC+JT-2
12506 KFAA=IABS(K(I,2))
12507 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
12508 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12509 ELSE
12510 P(I,5)=PYMASS(K(I,2))
12511 ENDIF
12512 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
12513 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
12514 560 CONTINUE
12515 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
12516 KFA1=IABS(MINT(21))
12517 KFA2=IABS(MINT(22))
12518 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
12519 & THEN
12520 MINT(51)=1
12521 RETURN
12522 ENDIF
12523 P(IPU3,5)=0D0
12524 P(IPU4,5)=0D0
12525 ENDIF
12526 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
12527 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
12528 P(IPU4,4)=SHR-P(IPU3,4)
12529 P(IPU4,3)=-P(IPU3,3)
12530 N=IPU4
12531 MINT(7)=MINT(83)+7
12532 MINT(8)=MINT(83)+8
12533
12534C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
12535 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
12536
12537 ELSEIF(IDOC.EQ.9) THEN
12538C...2 -> 3 processes: store outgoing partons in their CM frame
12539 DO 570 JT=1,2
12540 I=MINT(84)+2+JT
12541 KCA=PYCOMP(MINT(20+JT))
12542 K(I,1)=1
12543 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12544 K(I,2)=MINT(20+JT)
12545 K(I,3)=MINT(83)+IDOC+JT-3
12546 JTA=JT
12547C...t and b in opposide order in event list as compared to
12548C...matrix element?
12549 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
12550 IF(IABS(K(I,2)).LE.22) THEN
12551 P(I,5)=PYMASS(K(I,2))
12552 ELSE
12553 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
12554 ENDIF
12555 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
12556 P(I,1)=PT*COS(VINT(198+5*JTA))
12557 P(I,2)=PT*SIN(VINT(198+5*JTA))
12558 570 CONTINUE
12559 K(IPU5,1)=1
12560 K(IPU5,2)=KFRES
12561 K(IPU5,3)=MINT(83)+IDOC
12562 P(IPU5,5)=SHR
12563 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12564 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12565 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
12566 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
12567 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
12568 PMT3=SQRT(PMS3)
12569 P(IPU5,3)=PMT3*SINH(VINT(211))
12570 P(IPU5,4)=PMT3*COSH(VINT(211))
12571 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
12572 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
12573 IF(SQL12.LE.0D0) THEN
12574 MINT(51)=1
12575 RETURN
12576 ENDIF
12577 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
12578 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12579 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
12580 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
12581C...t and b in opposide order in event list as compared to
12582C...matrix element
12583 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
12584 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
12585 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
12586 END IF
12587 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
12588 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
12589 MINT(23)=KFRES
12590 N=IPU5
12591 MINT(7)=MINT(83)+7
12592 MINT(8)=MINT(83)+8
12593
12594 ELSEIF(IDOC.EQ.11) THEN
12595C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
12596 PHI(1)=PARU(2)*PYR(0)
12597 PHI(2)=PHI(1)-PHIR
12598 DO 580 JT=1,2
12599 I=MINT(84)+2+JT
12600 K(I,1)=1
12601 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12602 K(I,2)=MINT(20+JT)
12603 K(I,3)=MINT(83)+IDOC+JT-2
12604 P(I,5)=PYMASS(K(I,2))
12605 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
12606 MINT(51)=1
12607 RETURN
12608 ENDIF
12609 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12610 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12611 P(I,1)=PTABS*COS(PHI(JT))
12612 P(I,2)=PTABS*SIN(PHI(JT))
12613 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12614 P(I,4)=0.5D0*SHPR*Z(JT)
12615 IZW=MINT(83)+6+JT
12616 K(IZW,1)=21
12617 K(IZW,2)=23
12618 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
12619 K(IZW,3)=IZW-2
12620 P(IZW,1)=-P(I,1)
12621 P(IZW,2)=-P(I,2)
12622 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12623 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12624 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12625 580 CONTINUE
12626 I=MINT(83)+9
12627 K(IPU5,1)=1
12628 K(IPU5,2)=KFRES
12629 K(IPU5,3)=I
12630 P(IPU5,5)=SHR
12631 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
12632 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
12633 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
12634 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
12635 K(I,1)=21
12636 K(I,2)=KFRES
12637 DO 590 J=1,5
12638 P(I,J)=P(IPU5,J)
12639 590 CONTINUE
12640 N=IPU5
12641 MINT(23)=KFRES
12642
12643 ELSEIF(IDOC.EQ.12) THEN
12644C...Z0 and W+/- scattering: store bosons and outgoing partons
12645 PHI(1)=PARU(2)*PYR(0)
12646 PHI(2)=PHI(1)-PHIR
12647 JTRAN=INT(1.5D0+PYR(0))
12648 DO 600 JT=1,2
12649 I=MINT(84)+2+JT
12650 K(I,1)=1
12651 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
12652 K(I,2)=MINT(20+JT)
12653 K(I,3)=MINT(83)+IDOC+JT-2
12654 P(I,5)=PYMASS(K(I,2))
12655 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
12656 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
12657 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
12658 P(I,1)=PTABS*COS(PHI(JT))
12659 P(I,2)=PTABS*SIN(PHI(JT))
12660 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
12661 P(I,4)=0.5D0*SHPR*Z(JT)
12662 IZW=MINT(83)+6+JT
12663 K(IZW,1)=21
12664 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
12665 K(IZW,2)=23
12666 ELSE
12667 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
12668 ENDIF
12669 K(IZW,3)=IZW-2
12670 P(IZW,1)=-P(I,1)
12671 P(IZW,2)=-P(I,2)
12672 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
12673 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
12674 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
12675 IPU=MINT(84)+4+JT
12676 K(IPU,1)=3
12677 K(IPU,2)=KFPR(ISUB,JT)
12678 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
12679 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
12680 K(IPU,3)=MINT(83)+8+JT
12681 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
12682 P(IPU,5)=PYMASS(K(IPU,2))
12683 ELSE
12684 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
12685 ENDIF
12686 MINT(22+JT)=K(IPU,2)
12687 600 CONTINUE
12688C...Find rotation and boost for hard scattering subsystem
12689 I1=MINT(83)+7
12690 I2=MINT(83)+8
12691 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
12692 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
12693 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
12694 GAMCM=(P(I1,4)+P(I2,4))/SHR
12695 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
12696 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
12697 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
12698 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
12699 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
12700 PHICM=PYANGL(PX,PY)
12701C...Store hard scattering subsystem. Rotate and boost it
12702 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
12703 & P(IPU6,5)**2
12704 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
12705 CTHWZ=VINT(23)
12706 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
12707 PHIWZ=VINT(24)-PHICM
12708 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
12709 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
12710 P(IPU5,3)=PABS*CTHWZ
12711 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
12712 P(IPU6,1)=-P(IPU5,1)
12713 P(IPU6,2)=-P(IPU5,2)
12714 P(IPU6,3)=-P(IPU5,3)
12715 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
12716 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
12717 DO 620 JT=1,2
12718 I1=MINT(83)+8+JT
12719 I2=MINT(84)+4+JT
12720 K(I1,1)=21
12721 K(I1,2)=K(I2,2)
12722 DO 610 J=1,5
12723 P(I1,J)=P(I2,J)
12724 610 CONTINUE
12725 620 CONTINUE
12726 N=IPU6
12727 MINT(7)=MINT(83)+9
12728 MINT(8)=MINT(83)+10
12729 ENDIF
12730
12731 IF(ISET(ISUB).EQ.11) THEN
12732 ELSEIF(IDOC.GE.8) THEN
12733C...Store colour connection indices
12734 DO 630 J=1,2
12735 JC=J
12736 IF(KCS.EQ.-1) JC=3-J
12737 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12738 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
12739 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12740 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
12741 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12742 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12743 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12744 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12745 630 CONTINUE
12746
12747C...Copy outgoing partons to documentation lines
12748 IMAX=2
12749 IF(IDOC.EQ.9) IMAX=3
12750 DO 650 I=1,IMAX
12751 I1=MINT(83)+IDOC-IMAX+I
12752 I2=MINT(84)+2+I
12753 K(I1,1)=21
12754 K(I1,2)=K(I2,2)
12755 IF(IDOC.LE.9) K(I1,3)=0
12756 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
12757 DO 640 J=1,5
12758 P(I1,J)=P(I2,J)
12759 640 CONTINUE
12760 650 CONTINUE
12761
12762 ELSEIF(IDOC.EQ.9) THEN
12763C...Store colour connection indices
12764 DO 660 J=1,2
12765 JC=J
12766 IF(KCS.EQ.-1) JC=3-J
12767 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12768 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
12769 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
12770 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12771 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
12772 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
12773 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
12774 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12775 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
12776 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
12777 660 CONTINUE
12778
12779C...Copy outgoing partons to documentation lines
12780 DO 680 I=1,3
12781 I1=MINT(83)+IDOC-3+I
12782 I2=MINT(84)+2+I
12783 K(I1,1)=21
12784 K(I1,2)=K(I2,2)
12785 K(I1,3)=0
12786 DO 670 J=1,5
12787 P(I1,J)=P(I2,J)
12788 670 CONTINUE
12789 680 CONTINUE
12790 ENDIF
12791
12792C...Copy outgoing partons to list of allowed radiators.
12793 NPART=0
12794 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
12795 DO 690 I=MINT(84)+3,N
12796 NPART=NPART+1
12797 IPART(NPART)=I
12798 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
12799 690 CONTINUE
12800 ENDIF
12801
12802C...Low-pT events: remove gluons used for string drawing purposes
12803 IF(ISUB.EQ.95) THEN
12804 IF(MINT(35).LE.1) THEN
12805 K(IPU3,1)=K(IPU3,1)+10
12806 K(IPU4,1)=K(IPU4,1)+10
12807 ENDIF
12808 DO 700 J=41,66
12809 VINTSV(J)=VINT(J)
12810 VINT(J)=0D0
12811 700 CONTINUE
12812 DO 720 I=MINT(83)+5,MINT(83)+8
12813 DO 710 J=1,5
12814 P(I,J)=0D0
12815 710 CONTINUE
12816 720 CONTINUE
12817 ENDIF
12818
12819 RETURN
12820 END
12821
12822C***********************************************************************
12823
12824C...PYEVOL
12825C...Handles intertwined pT-ordered spacelike initial-state parton
12826C...and multiple interactions.
12827
12828 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
12829C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
12830C...MODE = 0 : (Re-)initialize ISR/MI evolution.
12831C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
12832
12833C...Double precision and integer declarations.
12834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
12835 IMPLICIT INTEGER(I-N)
12836 INTEGER PYK,PYCHGE,PYCOMP
12837C...External
12838 EXTERNAL PYALPS
12839 DOUBLE PRECISION PYALPS
12840C...Parameter statement for maximum size of showers.
12841 PARAMETER (MAXNUR=1000)
12842C...Commonblocks.
12843 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
12844 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
12845 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
12846 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
12847 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
12848 COMMON/PYINT1/MINT(400),VINT(400)
12849 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
12850 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
12851 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
12852 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
12853 & XMI(2,240),PT2MI(240),IMISEP(0:240)
12854 COMMON/PYCTAG/NCT,MCT(4000,2)
12855 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
12856 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
12857 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
12858C...Local arrays and saved variables.
12859 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
12860 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
12861 & ,PSAV,KSAV,VSAV
12862
12863 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
12864 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
12865
12866C----------------------------------------------------------------------
12867C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
12868C...done only once per event, while MODE=0 is repeated each time the
12869C...evolution needs to be restarted.
12870 IF (MODE.EQ.-1) THEN
12871 ISUBHD=MINT(1)
12872 NSAV=N
12873 NPARTS=NPART
12874C...Store hard scattering variables
12875 M15SV=MINT(15)
12876 M16SV=MINT(16)
12877 M21SV=MINT(21)
12878 M22SV=MINT(22)
12879 DO 100 J=11,80
12880 VINTSV(J)=VINT(J)
12881 100 CONTINUE
12882 DO 120 J=1,5
12883 DO 110 IS=1,4
12884 I=IS+MINT(84)
12885 PSAV(IS,J)=P(I,J)
12886 KSAV(IS,J)=K(I,J)
12887 VSAV(IS,J)=V(I,J)
12888 110 CONTINUE
12889 120 CONTINUE
12890
12891C...Set shat for hardest scattering
12892 SHAT(1)=VINT(44)
12893 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
12894 & *VINT(2)
12895
12896C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
12897 RMC=PMAS(4,1)
12898 RMB=PMAS(5,1)
12899 ALAM4=PARP(61)
12900 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
12901 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
12902 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
12903
12904C----------------------------------------------------------------------
12905C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
12906C...interaction initiators, with no previous evolution. Check the input
12907C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
12908C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
12909C...smaller than the CM energy / 2.)
12910 ELSEIF (MODE.EQ.0) THEN
12911C...Reset counters and switches
12912 N=NSAV
12913 NPART=NPARTS
12914 MINT(30)=0
12915 MINT(31)=1
12916 MINT(36)=1
12917C...Reset hard scattering variables
12918 MINT(1)=ISUBHD
12919 DO 130 J=11,80
12920 VINT(J)=VINTSV(J)
12921 130 CONTINUE
12922 DO 150 J=1,5
12923 DO 140 IS=1,4
12924 I=IS+MINT(84)
12925 P(I,J)=PSAV(IS,J)
12926 K(I,J)=KSAV(IS,J)
12927 V(I,J)=VSAV(IS,J)
12928 P(MINT(83)+4+IS,J)=PSAV(IS,J)
12929 V(MINT(83)+4+IS,J)=VSAV(IS,J)
12930 140 CONTINUE
12931 150 CONTINUE
12932C...Reset statistics on activity in event.
12933 DO 160 J=351,359
12934 MINT(J)=0
12935 VINT(J)=0D0
12936 160 CONTINUE
12937C...Reset extra companion reweighting factor
12938 VINT(140)=1D0
12939
12940C...We do not generate MI for soft process (ISUB=95), but the
12941C...initialization must be done regardless, for later purposes.
12942 MINT(36)=1
12943
12944C...Initialize multiple interactions.
12945 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
12946 IF(MINT(51).NE.0) RETURN
12947
12948C...Decide whether quarks in hard scattering were valence or sea
12949 PT2HD=VINT(54)
12950 DO 170 JS=1,2
12951 MINT(30)=JS
12952 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
12953 IF(MINT(51).NE.0) RETURN
12954 170 CONTINUE
12955
12956C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
12957 VINT(18)=0D0
12958 IF(MSTP(70).EQ.0) THEN
12959 PT20=PARP(62)**2
12960 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12961 ELSEIF(MSTP(70).EQ.1) THEN
12962 PT20=(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2
12963 PT2MIN=MAX(PT2MIN,PT20,(1.1D0*ALAM3)**2)
12964 ELSE
12965 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
12966 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
12967 ENDIF
12968C...Also store PT2MIN in VINT(17).
12969 180 VINT(17)=PT2MIN
12970
12971C...Set FS masses zero now.
12972 VINT(63)=0D0
12973 VINT(64)=0D0
12974
12975C...Initialize IS showers with VINT(56) as max scale.
12976 PT2ISR=VINT(56)
12977 CALL PYPTIS(-1,PT2ISR,PT2MIN,PT2DUM,IFAIL)
12978 IF(MINT(51).NE.0) RETURN
12979
12980 RETURN
12981
12982C----------------------------------------------------------------------
12983C...MODE= 1: Evolve event from PTMAX to PTMIN.
12984 ELSEIF (MODE.EQ.1) THEN
12985
12986C...Skip if no phase space.
12987 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
12988
12989C...Starting pT2 max scale (to be udpated successively).
12990 PT2CMX=PT2MAX
12991
12992C...Evolve two sides of the event to find which branches at highest pT.
12993 200 JSMX=-1
12994 MIMX=0
12995 PT2MX=0D0
12996
12997C...Loop over current shower initiators.
12998 IF (MSTP(61).GE.1) THEN
12999 DO 230 MI=1,MINT(31)
13000 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13001 ISUB=96
13002 IF (MI.EQ.1) ISUB=ISUBHD
13003 MINT(1)=ISUB
13004 MINT(36)=MI
13005C...Set up shat, initiator x values, and x remaining in BR.
13006 VINT(44)=SHAT(MI)
13007 VINT(141)=XMI(1,MI)
13008 VINT(142)=XMI(2,MI)
13009 VINT(143)=1D0
13010 VINT(144)=1D0
13011 DO 210 JI=1,MINT(31)
13012 IF (JI.EQ.MINT(36)) GOTO 210
13013 VINT(143)=VINT(143)-XMI(1,JI)
13014 VINT(144)=VINT(144)-XMI(2,JI)
13015 210 CONTINUE
13016C...Loop over sides.
13017C...Generate trial branchings for this interaction. The hardest
13018C...branching so far is automatically updated if necessary in /PYISMX/.
13019 DO 220 JS=1,2
13020 MINT(30)=JS
13021 CALL PYPTIS(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13022 IF (MINT(51).NE.0) RETURN
13023 220 CONTINUE
13024 230 CONTINUE
13025 ENDIF
13026
13027C...Generate trial additional interaction.
13028 MINT(36)=MINT(31)+1
13029 240 IF (MOD(MSTP(81),10).GE.1) THEN
13030 MINT(1)=96
13031C...Set up X remaining in BR.
13032 VINT(143)=1D0
13033 VINT(144)=1D0
13034 DO 250 JI=1,MINT(31)
13035 VINT(143)=VINT(143)-XMI(1,JI)
13036 VINT(144)=VINT(144)-XMI(2,JI)
13037 250 CONTINUE
13038C...Generate trial interaction
13039 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13040 IF (MINT(51).EQ.1) RETURN
13041 ENDIF
13042
13043C...And the winner is:
13044 IF (PT2MX.LT.PT2MIN) THEN
13045 GOTO 330
13046 ELSEIF (JSMX.EQ.0) THEN
13047C...Accept additional interaction (may still fail).
13048 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13049 IF(MINT(51).NE.0) RETURN
13050 IF (IFAIL.EQ.0) THEN
13051 SHAT(MINT(36))=VINT(44)
13052C...Decide on flavours (valence/sea/companion).
13053 DO 270 JS=1,2
13054 MINT(30)=JS
13055 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13056 IF(MINT(51).NE.0) RETURN
13057 270 CONTINUE
13058 ENDIF
13059 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13060C...Reconstruct kinematics of acceptable ISR branching.
13061C...Set up shat, initiator x values, and x remaining in BR.
13062 MINT(30)=JSMX
13063 MINT(36)=MIMX
13064 VINT(44)=SHAT(MINT(36))
13065 VINT(141)=XMI(1,MINT(36))
13066 VINT(142)=XMI(2,MINT(36))
13067 VINT(143)=1D0
13068 VINT(144)=1D0
13069 DO 280 JI=1,MINT(31)
13070 IF (JI.EQ.MINT(36)) GOTO 280
13071 VINT(143)=VINT(143)-XMI(1,JI)
13072 VINT(144)=VINT(144)-XMI(2,JI)
13073 280 CONTINUE
13074 PT2NEW=PT2MX
13075 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13076 IF (MINT(51).EQ.1) RETURN
13077 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13078C...Bookeep joining. Cannot (yet) be constructed kinematically.
13079 MINT(354)=MINT(354)+1
13080 VINT(354)=VINT(354)+SQRT(PT2MX)
13081 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13082 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13083 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13084 ENDIF
13085
13086C...Update PT2 iteration scale.
13087 PT2CMX=PT2MX
13088
13089C...Loop back to continue evolution.
13090 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13091 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13092 ELSE
13093 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13094 ENDIF
13095
13096C----------------------------------------------------------------------
13097C...MODE= 2: (Re-)store user information on hardest interaction etc.
13098 ELSEIF (MODE.EQ.2) THEN
13099
13100C...Revert to "ordinary" meanings of some parameters.
13101 290 DO 310 JS=1,2
13102 MINT(12+JS)=K(IMI(JS,1,1),2)
13103 VINT(140+JS)=XMI(JS,1)
13104 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13105 VINT(142+JS)=1D0
13106 DO 300 MI=1,MINT(31)
13107 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13108 300 CONTINUE
13109 310 CONTINUE
13110
13111C...Restore saved quantities for hardest interaction.
13112 MINT(1)=ISUBHD
13113 MINT(15)=M15SV
13114 MINT(16)=M16SV
13115 MINT(21)=M21SV
13116 MINT(22)=M22SV
13117 DO 320 J=11,80
13118 VINT(J)=VINTSV(J)
13119 320 CONTINUE
13120
13121 ENDIF
13122
13123 330 RETURN
13124 END
13125
13126C*********************************************************************
13127
13128C...PYSSPA
13129C...Generates spacelike parton showers.
13130
13131 SUBROUTINE PYSSPA(IPU1,IPU2)
13132
13133C...Double precision and integer declarations.
13134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13135 IMPLICIT INTEGER(I-N)
13136 INTEGER PYK,PYCHGE,PYCOMP
13137C...Commonblocks.
13138 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13140 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13141 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13142 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13143 COMMON/PYINT1/MINT(400),VINT(400)
13144 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13145 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13146 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
13147 &/PYINT2/,/PYINT3/
13148C...Local arrays and data.
13149 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13150 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13151 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13152 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13153 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13154 DATA IS/2*0/
13155
13156C...Read out basic information; set global Q^2 scale.
13157 IPUS1=IPU1
13158 IPUS2=IPU2
13159 ISUB=MINT(1)
13160 Q2MX=VINT(56)
13161 VINT2R=VINT(2)*VINT(143)*VINT(144)
13162 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13163 &MIN(VINT2R,PARP(67)*VINT(56))
13164 FCQ2MX=1D0
13165
13166C...Define which processes ME corrections have been implemented for.
13167 MECOR=0
13168 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13169 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13170 & ISUB.EQ.144) MECOR=1
13171 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13172 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13173 ENDIF
13174
13175C...Initialize QCD evolution and check phase space.
13176 Q2MNC=PARP(62)**2
13177 Q2MNCS(1)=Q2MNC
13178 Q2MNCS(2)=Q2MNC
13179 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13180 Q0S=PARP(15)**2
13181 PS=VINT(3)**2
13182 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13183 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13184 Q2INT=SQRT(Q0S*Q2EFF)
13185 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13186 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13187 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13188 ENDIF
13189 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13190 Q0S=PARP(15)**2
13191 PS=VINT(4)**2
13192 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13193 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13194 Q2INT=SQRT(Q0S*Q2EFF)
13195 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13196 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13197 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13198 ENDIF
13199 MCEV=0
13200 ALAMS=PARU(112)
13201 PARU(112)=PARP(61)
13202 FQ2C=1D0
13203 TCMX=0D0
13204 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13205 MCEV=1
13206 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13207 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13208 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13209 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13210 & MCEV=0
13211 ENDIF
13212
13213C...Initialize QED evolution and check phase space.
13214 MEEV=0
13215 XEE=1D-10
13216 SPME=PMAS(11,1)**2
13217 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13218 &SPME=PMAS(13,1)**2
13219 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13220 &SPME=PMAS(15,1)**2
13221 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13222 TEMX=0D0
13223 FWTE=10D0
13224 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13225 MEEV=1
13226 TEMX=LOG(Q2MX/SPME)
13227 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13228 ENDIF
13229 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13230 MEEV=2
13231 TEMX=TCMX
13232 FWTE=1D0
13233 ENDIF
13234 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13235
13236C...Loopback point in case of failure to reconstruct kinematics.
13237 NS=N
13238 LOOP=0
13239 MNT352=MINT(352)
13240 MNT353=MINT(353)
13241 VNT352=VINT(352)
13242 VNT353=VINT(353)
13243 100 LOOP=LOOP+1
13244 IF(LOOP.GT.100) THEN
13245 MINT(51)=1
13246 RETURN
13247 ENDIF
13248 N=NS
13249 MINT(352)=MNT352
13250 MINT(353)=MNT353
13251 VINT(352)=VNT352
13252 VINT(353)=VNT353
13253
13254C...Initial values: flavours, momenta, virtualities.
13255 DO 120 JT=1,2
13256 MORE(JT)=1
13257 KFBEAM(JT)=MINT(10+JT)
13258 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13259 KFLS(JT)=MINT(14+JT)
13260 KFLS(JT+2)=KFLS(JT)
13261 XS(JT)=VINT(40+JT)
13262 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13263 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13264 ZS(JT)=1D0
13265 Q2S(JT)=FCQ2MX*Q2MX
13266 DQ2(JT)=0D0
13267 TEVCSV(JT)=TCMX
13268 ALAM(JT)=PARP(61)
13269 THE2(JT)=1D0
13270 TEVESV(JT)=TEMX
13271 MCESV(JT)=0
13272C...Calculate initial parton distribution weights.
13273 MINT(105)=MINT(102+JT)
13274 MINT(109)=MINT(106+JT)
13275 VINT(120)=VINT(2+JT)
13276C.... ALICE
13277C.... Store side in MINT(124)
13278 MINT(124) = JT
13279C....
13280 IF(XS(JT).LT.1D0-XEE) THEN
13281 IF(MINT(31).GE.2) MINT(30)=JT
13282 IF(MSTP(57).LE.1) THEN
13283 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13284 ELSE
13285 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13286 ENDIF
13287 ENDIF
13288 DO 110 KFL=-25,25
13289 XFS(JT,KFL)=XFB(KFL)
13290 110 CONTINUE
13291C...Special kinematics check for c/b quarks (that g -> c cbar or
13292C...b bbar kinematically possible).
13293 KFLCB=IABS(KFLS(JT))
13294 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13295 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13296 MINT(51)=1
13297 RETURN
13298 ENDIF
13299 ENDIF
13300 120 CONTINUE
13301 DSH=VINT(44)
13302 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13303
13304C...Find if interference with final state partons.
13305 MFIS=0
13306 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13307 IF(MFIS.NE.0) THEN
13308 DO 140 I=1,2
13309 KCFI(I)=0
13310 KCA=PYCOMP(IABS(KFLS(I)))
13311 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13312 NFIS(I)=0
13313 IF(KCFI(I).NE.0) THEN
13314 IF(I.EQ.1) IPFS=IPUS1
13315 IF(I.EQ.2) IPFS=IPUS2
13316 DO 130 J=1,2
13317 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13318 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13319 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13320 NFIS(I)=NFIS(I)+1
13321 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13322 & P(ICSI,2)**2))
13323 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13324 ENDIF
13325 130 CONTINUE
13326 ENDIF
13327 140 CONTINUE
13328 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13329 ENDIF
13330
13331C...Pick up leg with highest virtuality.
13332 JTOLD=1
13333 150 N=N+1
13334 JT=1
13335 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13336 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13337 IF(MORE(JT).EQ.0) JT=3-JT
13338 JTOLD=JT
13339 KFLB=KFLS(JT)
13340 XB=XS(JT)
13341 DO 160 KFL=-25,25
13342 XFB(KFL)=XFS(JT,KFL)
13343 160 CONTINUE
13344 DSHR=2D0*SQRT(DSH)
13345 DSHZ=DSH/ZS(JT)
13346
13347C...Check if allowed to branch.
13348 MCEV=0
13349 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13350 MCEV=1
13351 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13352 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13353 ENDIF
13354 MEEV=0
13355 IF(MINT(44+JT).EQ.3) THEN
13356 MEEV=1
13357 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13358 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13359 & MEEV=0
13360C***Currently kill QED shower for resolved photoproduction.
13361 IF(MINT(18+JT).EQ.1) MEEV=0
13362C***Currently kill shower for W inside electron.
13363 IF(IABS(KFLB).EQ.24) THEN
13364 MCEV=0
13365 MEEV=0
13366 ENDIF
13367 ENDIF
13368 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13369 &MEEV=2
13370 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13371 Q2B=0D0
13372 GOTO 260
13373 ENDIF
13374
13375C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13376 Q2B=Q2S(JT)
13377 TEVCB=TEVCSV(JT)
13378 TEVEB=TEVESV(JT)
13379 IF(MSTP(62).LE.1) THEN
13380 IF(ZS(JT).GT.0.99999D0) THEN
13381 Q2B=Q2S(JT)
13382 ELSE
13383 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13384 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13385 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13386 ENDIF
13387 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13388 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13389 ENDIF
13390 IF(MCEV.EQ.1) THEN
13391 ALSDUM=PYALPS(FQ2C*Q2B)
13392 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13393 ALAM(JT)=PARU(117)
13394 B0=(33D0-2D0*MSTU(118))/6D0
13395 ENDIF
13396 IF(MEEV.EQ.2) TEVEB=TEVCB
13397 TEVCBS=TEVCB
13398 TEVEBS=TEVEB
13399
13400C...Select side for interference with final state partons.
13401 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13402 IFI=N-NS
13403 ISFI(IFI)=0
13404 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13405 ISFI(IFI)=1
13406 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13407 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13408 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13409 ISFI(IFI)=1
13410 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13411 ENDIF
13412 ENDIF
13413
13414C...Calculate preweighting factor for ME-corrected processes.
13415 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13416
13417C...Calculate Altarelli-Parisi weights.
13418 DO 170 KFL=-25,25
13419 WTAPC(KFL)=0D0
13420 WTAPE(KFL)=0D0
13421 WTSF(KFL)=0D0
13422 170 CONTINUE
13423C...q -> q (g or gamma emission), g -> q.
13424 IF(IABS(KFLB).LE.10) THEN
13425 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13426 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13427 EQ2=1D0/9D0
13428 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13429 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13430 & (XEC*(1D0-XEC)))
13431 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13432 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13433 WTAPC(21)=WTGF*WTAPC(21)
13434 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13435 ENDIF
13436C...f -> f, gamma -> f.
13437 ELSEIF(IABS(KFLB).LE.20) THEN
13438 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13439 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13440 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13441 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13442 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13443 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13444 WTAPE(22)=WTGF*WTAPE(22)
13445 ENDIF
13446C...f -> g, g -> g.
13447 ELSEIF(KFLB.EQ.21) THEN
13448 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13449 DO 180 KFL=1,MSTP(58)
13450 WTAPC(KFL)=WTAPQ
13451 WTAPC(-KFL)=WTAPQ
13452 180 CONTINUE
13453 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13454 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13455 DO 190 KFL=1,MSTP(58)
13456 WTAPC(KFL)=WTFG*WTAPC(KFL)
13457 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13458 190 CONTINUE
13459 WTAPC(21)=WTGG*WTAPC(21)
13460 ENDIF
13461C...f -> gamma, W+, W-.
13462 ELSEIF(KFLB.EQ.22) THEN
13463 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13464 WTAPE(11)=WTAPF
13465 WTAPE(-11)=WTAPF
13466 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13467 WTAPE(11)=WTFG*WTAPE(11)
13468 WTAPE(-11)=WTFG*WTAPE(-11)
13469 ENDIF
13470 ELSEIF(KFLB.EQ.24) THEN
13471 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13472 & (XEE*(XB+XEE)))/XB
13473 ELSEIF(KFLB.EQ.-24) THEN
13474 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13475 & (XEE*(XB+XEE)))/XB
13476 ENDIF
13477
13478C...Calculate parton distribution weights and sum.
13479 NTRY=0
13480 200 NTRY=NTRY+1
13481 IF(NTRY.GT.500) THEN
13482 MINT(51)=1
13483 RETURN
13484 ENDIF
13485 WTSUMC=0D0
13486 WTSUME=0D0
13487 XFBO=MAX(1D-10,XFB(KFLB))
13488 DO 210 KFL=-25,25
13489 WTSF(KFL)=XFB(KFL)/XFBO
13490 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
13491 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
13492 210 CONTINUE
13493 WTSUMC=MAX(0.0001D0,WTSUMC)
13494 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
13495
13496C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
13497 NTRY2=0
13498 220 NTRY2=NTRY2+1
13499 IF(NTRY2.GT.500) THEN
13500 MINT(51)=1
13501 RETURN
13502 ENDIF
13503 IF(MCEV.EQ.1) THEN
13504 IF(MSTP(64).LE.0) THEN
13505 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
13506 ELSEIF(MSTP(64).EQ.1) THEN
13507 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
13508 ELSE
13509 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
13510 ENDIF
13511 ENDIF
13512 IF(MEEV.EQ.1) THEN
13513 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
13514 & (PARU(101)*FWTE*WTSUME*TEMX)))
13515 ELSEIF(MEEV.EQ.2) THEN
13516 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
13517 ENDIF
13518
13519C...Translate t into Q2 scale; choose between QCD and QED evolution.
13520 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
13521 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
13522 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
13523C...Ensure that Q2 is above threshold for charm/bottom.
13524 KFLCB=IABS(KFLB)
13525 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13526 &MCEV.EQ.1) THEN
13527 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
13528 Q2CB=1.1D0*PMAS(KFLCB,1)**2
13529 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13530 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
13531 ENDIF
13532 ENDIF
13533 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
13534 &MEEV.EQ.2) THEN
13535 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
13536 ENDIF
13537 MCE=0
13538 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13539 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13540 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
13541 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
13542 IF(Q2EB.GT.Q2MNE) MCE=2
13543 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
13544 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
13545 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
13546 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
13547 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
13548 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
13549 MCE=1
13550 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
13551 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
13552 ELSE
13553 MCE=2
13554 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
13555 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
13556 ENDIF
13557
13558C...Evolution possibly ended. Update t values.
13559 IF(MCE.EQ.0) THEN
13560 Q2B=0D0
13561 GOTO 260
13562 ELSEIF(MCE.EQ.1) THEN
13563 Q2B=Q2CB
13564 Q2REF=FQ2C*Q2B
13565 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13566 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13567 ELSE
13568 Q2B=Q2EB
13569 Q2REF=Q2B
13570 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13571 ENDIF
13572
13573C...Select flavour for branching parton.
13574 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
13575 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
13576 KFLA=-25
13577 240 KFLA=KFLA+1
13578 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
13579 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
13580 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
13581 IF(KFLA.EQ.25) THEN
13582 Q2B=0D0
13583 GOTO 260
13584 ENDIF
13585
13586C...Choose z value and corrective weight.
13587 WTZ=0D0
13588C...q -> q + g or q -> q + gamma.
13589 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
13590 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
13591 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
13592 WTZ=0.5D0*(1D0+Z**2)
13593C...q -> g + q.
13594 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
13595 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
13596 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
13597C...f -> f + gamma.
13598 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13599 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
13600 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
13601 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
13602 ELSE
13603 Z=XB+XB*(XEE/(1D0-XEE))*
13604 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13605 ENDIF
13606 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
13607C...f -> gamma + f.
13608 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
13609 Z=XB+XB*(XEE/(1D0-XEE))*
13610 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13611 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
13612C...f -> W+- + f.
13613 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
13614 Z=XB+XB*(XEE/(1D0-XEE))*
13615 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
13616 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
13617 & (Q2B/(Q2B+PMAS(24,1)**2))
13618C...g -> q + qbar.
13619 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
13620 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
13621 WTZ=1D0-2D0*Z*(1D0-Z)
13622C...g -> g + g.
13623 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13624 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
13625 WTZ=(1D0-Z*(1D0-Z))**2
13626C...gamma -> f + fbar.
13627 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
13628 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
13629 WTZ=1D0-2D0*Z*(1D0-Z)
13630 ENDIF
13631 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
13632
13633C...Option with resummation of soft gluon emission as effective z shift.
13634 IF(MCE.EQ.1) THEN
13635 IF(MSTP(65).GE.1) THEN
13636 RSOFT=6D0
13637 IF(KFLB.NE.21) RSOFT=8D0/3D0
13638 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
13639 IF(Z.LE.XB) GOTO 220
13640 ENDIF
13641
13642C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
13643 IF(MSTP(64).GE.2) THEN
13644 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
13645 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
13646 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
13647 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
13648 ENDIF
13649 ENDIF
13650
13651C...Remove kinematically impossible branchings.
13652 UHAT=Q2B-DSH*(1D0-Z)/Z
13653 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
13654
13655C...Select phi angle of branching at random.
13656 PHIBR=PARU(2)*PYR(0)
13657
13658C...Matrix-element corrections for some processes.
13659 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13660 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
13661 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
13662 WTZ=WTZ*WTME/WTFF
13663 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
13664 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
13665 WTZ=WTZ*WTME/WTGF
13666 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
13667 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
13668 WTZ=WTZ*WTME/WTFG
13669 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
13670 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
13671 WTZ=WTZ*WTME/WTGG
13672 ENDIF
13673 ENDIF
13674
13675C...Impose angular constraint in first branching from interference
13676C...with final state partons.
13677 IF(MCE.EQ.1) THEN
13678 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
13679 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
13680 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
13681 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
13682 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
13683 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
13684 ENDIF
13685 ENDIF
13686
13687C...Option with angular ordering requirement.
13688 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
13689 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
13690 IF(THE2T.GT.THE2(JT)) GOTO 220
13691 ENDIF
13692 ENDIF
13693
13694C...Weighting with new parton distributions.
13695 MINT(105)=MINT(102+JT)
13696 MINT(109)=MINT(106+JT)
13697 VINT(120)=VINT(2+JT)
13698C.... ALICE
13699C.... Store side in MINT(124)
13700 MINT(124)=JT
13701C....
13702 IF(MINT(31).GE.2) MINT(30)=JT
13703 IF(MSTP(57).LE.1) THEN
13704 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
13705 ELSE
13706 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
13707 ENDIF
13708 XFBN=XFN(KFLB)
13709 IF(XFBN.LT.1D-20) THEN
13710 IF(KFLA.EQ.KFLB) THEN
13711 TEVCB=TEVCBS
13712 TEVEB=TEVEBS
13713 WTAPC(KFLB)=0D0
13714 WTAPE(KFLB)=0D0
13715 GOTO 200
13716 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
13717 TEVCB=0.5D0*(TEVCBS+TEVCB)
13718 GOTO 230
13719 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
13720 TEVEB=0.5D0*(TEVEBS+TEVEB)
13721 GOTO 230
13722 ELSE
13723 XFBN=1D-10
13724 XFN(KFLB)=XFBN
13725 ENDIF
13726 ENDIF
13727 DO 250 KFL=-25,25
13728 XFB(KFL)=XFN(KFL)
13729 250 CONTINUE
13730 XA=XB/Z
13731C.... ALICE
13732C.... Store side in MINT(124)
13733 MINT(124) = JT
13734C....
13735 IF(MINT(31).GE.2) MINT(30)=JT
13736 IF(MSTP(57).LE.1) THEN
13737 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
13738 ELSE
13739 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
13740 ENDIF
13741 XFAN=XFA(KFLA)
13742 IF(XFAN.LT.1D-20) GOTO 200
13743 WTSFA=WTSF(KFLA)
13744 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
13745
13746C...Define two hard scatterers in their CM-frame.
13747 260 IF(N.EQ.NS+2) THEN
13748 DQ2(JT)=Q2B
13749 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
13750 DO 280 JR=1,2
13751 I=NS+JR
13752 IF(JR.EQ.1) IPO=IPUS1
13753 IF(JR.EQ.2) IPO=IPUS2
13754 DO 270 J=1,5
13755 K(I,J)=0
13756 P(I,J)=0D0
13757 V(I,J)=0D0
13758 270 CONTINUE
13759 K(I,1)=14
13760 K(I,2)=KFLS(JR+2)
13761 K(I,4)=IPO
13762 K(I,5)=IPO
13763 P(I,3)=DPLCM*(-1)**(JR+1)
13764 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
13765 P(I,5)=-SQRT(DQ2(JR))
13766 K(IPO,1)=14
13767 K(IPO,3)=I
13768 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
13769 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
13770 280 CONTINUE
13771
13772C...Find maximum allowed mass of timelike parton.
13773 ELSEIF(N.GT.NS+2) THEN
13774 JR=3-JT
13775 DQ2(3)=Q2B
13776 DPC(1)=P(IS(1),4)
13777 DPC(2)=P(IS(2),4)
13778 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
13779 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
13780 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
13781 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
13782 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
13783 IKIN=0
13784 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
13785 & 1D-10*DPD(1)) IKIN=1
13786 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
13787 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
13788 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
13789 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
13790
13791C...Generate timelike parton shower (if required).
13792 IT=N
13793 DO 290 J=1,5
13794 K(IT,J)=0
13795 P(IT,J)=0D0
13796 V(IT,J)=0D0
13797 290 CONTINUE
13798C...f -> f + g (gamma).
13799 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
13800 K(IT,2)=21
13801 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
13802C...f -> g (gamma, W+-) + f.
13803 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
13804 K(IT,2)=KFLB
13805 IF(KFLS(JT+2).EQ.24) THEN
13806 K(IT,2)=-12
13807 ELSEIF(KFLS(JT+2).EQ.-24) THEN
13808 K(IT,2)=12
13809 ENDIF
13810C...g (gamma) -> f + fbar, g + g.
13811 ELSE
13812 K(IT,2)=-KFLS(JT+2)
13813 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
13814 ENDIF
13815 K(IT,1)=3
13816 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
13817 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
13818 P(IT,5)=PYMASS(K(IT,2))
13819 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
13820 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
13821 MSTJ48=MSTJ(48)
13822 PARJ85=PARJ(85)
13823 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
13824 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
13825 IF(MSTP(63).EQ.1) THEN
13826 Q2TIM=DMSMA
13827 ELSEIF(MSTP(63).EQ.2) THEN
13828 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
13829 ELSE
13830 Q2TIM=DMSMA
13831 MSTJ(48)=1
13832 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13833 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
13834 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
13835 PARJ(85)=SQRT(MAX(0D0,DPT2))*
13836 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
13837 ENDIF
13838 CALL PYSHOW(IT,0,SQRT(Q2TIM))
13839 MSTJ(48)=MSTJ48
13840 PARJ(85)=PARJ85
13841 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
13842 ENDIF
13843
13844C...Reconstruct kinematics of branching: timelike parton shower.
13845 DMS=P(IT,5)**2
13846 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
13847 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
13848 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
13849 & (4D0*DSH*DPC(3)**2)
13850 IF(DPT2.LT.0D0) GOTO 100
13851 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
13852 & DSHR)/DPC(3)-DPC(3)
13853 P(IT,1)=SQRT(DPT2)
13854 P(IT,3)=DPB(1)*(-1)**(JT+1)
13855 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
13856 IF(N.GE.IT+1) THEN
13857 DPB(1)=SQRT(DPB(1)**2+DPT2)
13858 DPB(2)=SQRT(DPB(1)**2+DMS)
13859 DPB(3)=P(IT+1,3)
13860 DPB(4)=SQRT(DPB(3)**2+DMS)
13861 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
13862 & DPB(1))
13863 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
13864 THE=PYANGL(P(IT,3),P(IT,1))
13865 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
13866 ENDIF
13867
13868C...Reconstruct kinematics of branching: spacelike parton.
13869 DO 300 J=1,5
13870 K(N+1,J)=0
13871 P(N+1,J)=0D0
13872 V(N+1,J)=0D0
13873 300 CONTINUE
13874 K(N+1,1)=14
13875 K(N+1,2)=KFLB
13876 P(N+1,1)=P(IT,1)
13877 P(N+1,3)=P(IT,3)+P(IS(JT),3)
13878 P(N+1,4)=P(IT,4)+P(IS(JT),4)
13879 P(N+1,5)=-SQRT(DQ2(3))
13880
13881C...Define colour flow of branching.
13882 K(IS(JT),3)=N+1
13883 K(IT,3)=N+1
13884 IM1=N+1
13885 IM2=N+1
13886C...f -> f + gamma (Z, W).
13887 IF(IABS(K(IT,2)).GE.22) THEN
13888 K(IT,1)=1
13889 ID1=IS(JT)
13890 ID2=IS(JT)
13891C...f -> gamma (Z, W) + f.
13892 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
13893 ID1=IT
13894 ID2=IT
13895C...gamma -> q + qbar, g + g.
13896 ELSEIF(K(N+1,2).EQ.22) THEN
13897 ID1=IS(JT)
13898 ID2=IT
13899 IM1=ID2
13900 IM2=ID1
13901C...q -> q + g.
13902 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
13903 ID1=IT
13904 ID2=IS(JT)
13905C...q -> g + q.
13906 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
13907 ID1=IS(JT)
13908 ID2=IT
13909C...qbar -> qbar + g.
13910 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
13911 ID1=IS(JT)
13912 ID2=IT
13913C...qbar -> g + qbar.
13914 ELSEIF(K(N+1,2).LT.0) THEN
13915 ID1=IT
13916 ID2=IS(JT)
13917C...g -> g + g; g -> q + qbar.
13918 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
13919 ID1=IS(JT)
13920 ID2=IT
13921 ELSE
13922 ID1=IT
13923 ID2=IS(JT)
13924 ENDIF
13925 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
13926 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
13927 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
13928 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
13929 IF(ID1.NE.ID2) THEN
13930 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
13931 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
13932 ENDIF
13933 N=N+1
13934 IF(K(IT,1).EQ.1) THEN
13935 K(IT,4)=0
13936 K(IT,5)=0
13937 ENDIF
13938
13939C...Boost to new CM-frame.
13940 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
13941 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
13942 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
13943 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
13944 IR=N+(JT-1)*(IS(1)-N)
13945 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
13946 & 0D0,0D0,0D0)
13947
13948C...Global statistics.
13949 MINT(352)=MINT(352)+1
13950 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
13951 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
13952 ENDIF
13953
13954C...Update kinematics variables.
13955 IS(JT)=N
13956 DQ2(JT)=Q2B
13957 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
13958 DSH=DSHZ
13959
13960C...Save quantities; loop back.
13961 Q2S(JT)=Q2B
13962 DPHI(JT)=PHIBR
13963 MCESV(JT)=MCE
13964 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
13965 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
13966 KFLS(JT+2)=KFLS(JT)
13967 KFLS(JT)=KFLA
13968 XS(JT)=XA
13969 ZS(JT)=Z
13970 DO 310 KFL=-25,25
13971 XFS(JT,KFL)=XFA(KFL)
13972 310 CONTINUE
13973 TEVCSV(JT)=TEVCB
13974 TEVESV(JT)=TEVEB
13975 ELSE
13976 MORE(JT)=0
13977 IF(JT.EQ.1) IPU1=N
13978 IF(JT.EQ.2) IPU2=N
13979 ENDIF
13980 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13981 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
13982 IF(MSTU(21).GE.1) N=NS
13983 IF(MSTU(21).GE.1) RETURN
13984 ENDIF
13985 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
13986
13987C...Boost hard scattering partons to frame of shower initiators.
13988 DO 320 J=1,3
13989 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
13990 320 CONTINUE
13991 K(N+2,1)=1
13992 DO 330 J=1,5
13993 P(N+2,J)=P(NS+1,J)
13994 330 CONTINUE
13995 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
13996 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
13997 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
13998 IMIN=MINT(83)+5
13999 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14000 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14001 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14002
14003C...Store user information. Reset Lambda value.
14004 IF(MINT(31).LE.1) THEN
14005 K(IPU1,3)=MINT(83)+3
14006 K(IPU2,3)=MINT(83)+4
14007 ELSE
14008 K(IPU1,3)=MINT(83)+1
14009 K(IPU2,3)=MINT(83)+2
14010 ENDIF
14011 DO 340 JT=1,2
14012 MINT(12+JT)=KFLS(JT)
14013 VINT(140+JT)=XS(JT)
14014 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14015 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14016 340 CONTINUE
14017 PARU(112)=ALAMS
14018
14019 RETURN
14020 END
14021C*********************************************************************
14022
14023C...PYPTIS
14024C...Generates pT-ordered spacelike initial-state parton showers and
14025C...trial joinings.
14026C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14027C... interaction initiators at PT2NOW.
14028C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14029C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14030C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14031C... is below PT2CUT.
14032C... (Also generate test joinings if MSTP(96)=1.)
14033C...MODE= 1: Accept stored shower branching. Update event record etc.
14034C...PT2NOW : Starting (max) PT2 scale for evolution.
14035C...PT2CUT : Lower limit for evolution.
14036C...PT2 : Result of evolution. Generated PT2 for trial emission.
14037C...IFAIL : Status return code. IFAIL=0 when all is well.
14038
14039 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14040
14041C...Double precision and integer declarations.
14042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14043 IMPLICIT INTEGER(I-N)
14044 INTEGER PYK,PYCHGE,PYCOMP
14045C...Parameter statement for maximum size of showers.
14046 PARAMETER (MAXNUR=1000)
14047C...Commonblocks.
14048 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14049 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14050 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14051 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14052 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14053 COMMON/PYINT1/MINT(400),VINT(400)
14054 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14055 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14056 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14057 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14058 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14059 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14060 COMMON/PYCTAG/NCT,MCT(4000,2)
14061 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14062 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14063 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14064C...Local variables
14065 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14066 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14067 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14068 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14069 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14070 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14071C...For check on excessive weights.
14072 CHARACTER CHWT*12
14073
14074C...Only give errors for very large weights, otherwise just warnings
14075 DATA WTEMAX /1.5D0/
14076C...Only give errors for large pT, otherwise just warnings
14077 DATA PTEMAX /5D0/
14078
14079 IFAIL=-1
14080
14081C----------------------------------------------------------------------
14082C...MODE=-1: Initialize initial state showers from scratch, i.e.
14083C...starting from the hardest interaction initiators.
14084 IF (MODE.EQ.-1) THEN
14085C...Set hard scattering SHAT.
14086 SHTNOW(1)=VINT(44)
14087C...Mass thresholds and Lambda for QCD evolution.
14088 AEM2PI=PARU(101)/PARU(2)
14089 RMB=PMAS(5,1)
14090 RMC=PMAS(4,1)
14091 ALAM4=PARP(61)
14092 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14093 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14094 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14095 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14096 RMB2=RMB**2
14097 RMC2=RMC**2
14098C...Massive quark forced creation threshold (in M**2).
14099 TMIN=1.01D0
14100C...Set upper limit for X (ensures some X left for beam remnant).
14101 XMXC=1D0-2D0*PARP(111)/VINT(1)
14102
14103 IF (MSTP(61).GE.1) THEN
14104C...Initial values: flavours, momenta, virtualities.
14105 DO 100 JS=1,2
14106 NISGEN(JS,1)=0
14107
14108C...Special kinematics check for c/b quarks (that g -> c cbar or
14109C...b bbar kinematically possible).
14110 KFLB=K(IMI(JS,1,1),2)
14111 KFLCB=IABS(KFLB)
14112 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14113C...Check PT2MAX > mQ^2
14114 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14115 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14116 & 'No Q creation possible.')
14117 MINT(51)=1
14118 RETURN
14119 ELSE
14120C...Check for physical z values (m == MQ / sqrt(s))
14121C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14122 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14123 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14124 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14125 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14126 & 'Q creation.')
14127 MINT(51)=1
14128 RETURN
14129 ENDIF
14130 ENDIF
14131 ENDIF
14132 100 CONTINUE
14133 ENDIF
14134
14135 MINT(354)=0
14136C...Zero joining array
14137 DO 110 MJ=1,240
14138 MJOIND(1,MJ)=0
14139 MJOIND(2,MJ)=0
14140 110 CONTINUE
14141
14142C----------------------------------------------------------------------
14143C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14144C...MINT(30). Store if emission PT2 scale is largest so far.
14145C...Also generate test joinings if MSTP(96)=1.
14146 ELSEIF(MODE.EQ.0) THEN
14147 IFAIL=-1
14148 MECOR=0
14149 ISUB=MINT(1)
14150 JS=MINT(30)
14151C...No shower for structureless beam
14152 IF (MINT(44+JS).EQ.1) RETURN
14153 MI=MINT(36)
14154 SHAT=VINT(44)
14155C...Absolute shower max scale = VINT(56)
14156 PT2=MIN(PT2NOW,VINT(56))
14157 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14158C...Define for which processes ME corrections have been implemented.
14159 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14160 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14161 & .142.OR.ISUB.EQ.144) MECOR=1
14162 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14163 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14164C...Calculate preweighting factor for ME-corrected processes.
14165 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14166 ENDIF
14167C...Basic info on daughter for which to find mother.
14168 KFLB=K(IMI(JS,MI,1),2)
14169 KFLBA=IABS(KFLB)
14170C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14171C...second companion.
14172 KSVCB=MAX(-1,IMI(JS,MI,2))
14173C...Treat "first" companion of a pair like an ordinary sea quark
14174C...(except that creation diagram is not allowed)
14175 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14176C...X (rescaled to [0,1])
14177 XB=XMI(JS,MI)/VINT(142+JS)
14178C...Massive quarks (use physical masses.)
14179 RMQ2=0D0
14180 MQMASS=0
14181 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14182 RMQ2=RMC2
14183 IF (KFLBA.EQ.5) RMQ2=RMB2
14184C...Special threshold treatment for non-photon beams
14185 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14186 ENDIF
14187
14188C...Flags for parton distribution calls.
14189 MINT(105)=MINT(102+JS)
14190 MINT(109)=MINT(106+JS)
14191 VINT(120)=VINT(2+JS)
14192
14193C...Calculate initial parton distribution weights.
14194 IF(XB.GE.XMXC) THEN
14195 RETURN
14196 ELSEIF(MQMASS.EQ.0) THEN
14197 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14198 ELSE
14199C...Initialize massive quark PT2 dependent pdf underestimate.
14200 PT20=PT2
14201 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14202C.!.Tentative treatment of massive valence quarks.
14203 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14204 XG0=XFB(21)
14205 TPM0=LOG(PT20/RMQ2)
14206 WPDF0=TPM0*XG0/XQ0
14207 ENDIF
14208 IF (KFLBA.LE.6) THEN
14209C...For quarks, only include respective sea, val, or cmp part.
14210 IF (KSVCB.LE.0) THEN
14211 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14212 ELSE
14213C...Find companion's companion
14214 MISEA=0
14215 120 MISEA=MISEA+1
14216 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14217 XS=XMI(JS,MISEA)
14218 XREM=VINT(142+JS)
14219 YS=XS/(XREM+XS)
14220C...Momentum fraction of the companion quark.
14221C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14222 YB=XB*(1D0-YS)
14223 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14224 ENDIF
14225 ENDIF
14226
14227C...Determine overestimated z range: switch at c and b masses.
14228 130 IF (PT2.GT.TMIN*RMB2) THEN
14229 IZRG=3
14230 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14231 B0=23D0/6D0
14232 ALAM2=ALAM5**2
14233 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14234 IZRG=2
14235 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14236 B0=25D0/6D0
14237 ALAM2=ALAM4**2
14238 ELSE
14239 IZRG=1
14240 PT2MNE=PT2CUT
14241 B0=27D0/6D0
14242 ALAM2=ALAM3**2
14243 ENDIF
14244C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14245 ALAM2=ALAM2/PARP(64)
14246C...Overestimated ZMAX:
14247 IF (MQMASS.EQ.0) THEN
14248C...Massless
14249 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14250 & /PT2MNE)-1D0)
14251 ELSE
14252C...Massive (limit for bremsstrahlung diagram > creation)
14253 FMQ=SQRT(RMQ2/SHTNOW(MI))
14254 ZMAX=1D0/(1D0+FMQ)
14255 ENDIF
14256 ZMIN=XB/XMXC
14257
14258C...If kinematically impossible then do not evolve.
14259 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14260
14261C...Reset Altarelli-Parisi and PDF weights.
14262 DO 140 KFL=-5,5
14263 WTAP(KFL)=0D0
14264 WTPDF(KFL)=0D0
14265 140 CONTINUE
14266 WTAP(21)=0D0
14267 WTPDF(21)=0D0
14268C...Zero joining weights and compute X(partner) and X(mother) values.
14269 IF (MSTP(96).NE.0) THEN
14270 NJN=0
14271 DO 150 MJ=1,MINT(31)
14272 WTAPJ(MJ)=0D0
14273 WTPDFJ(MJ)=0D0
14274 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14275 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14276 & +XMI(JS,MI))
14277 150 CONTINUE
14278 ENDIF
14279
14280C...Approximate Altarelli-Parisi weights (integrated AP dz).
14281C...q -> q, g -> q or q -> q + gamma (already set which).
14282 IF(KFLBA.LE.5) THEN
14283C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14284 IF (KSVCB.LT.0) THEN
14285 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14286 ELSE
14287 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14288 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14289 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14290 ENDIF
14291 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14292 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14293 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14294 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14295 WTAP(KFLB)=WTFF*WTAP(KFLB)
14296 WTAP(21)=WTGF*WTAP(21)
14297 WTAPE=WTFF*WTAPE
14298 ENDIF
14299 IF (KSVCB.GE.1) THEN
14300C...Kill normal creation but add joining diagrams for cmp quark.
14301 WTAP(21)=0D0
14302 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14303 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14304 & " quark here. Not handled yet, giving up!")
14305 PT2=0D0
14306 MINT(51)=1
14307 RETURN
14308 ENDIF
14309C...Check for possible joinings
14310 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14311C...Find companion's companion.
14312 MJ=0
14313 160 MJ=MJ+1
14314 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14315 IF (MJOIND(JS,MJ).EQ.0) THEN
14316 Y(MI)=YB+YS
14317 Z=YB/Y(MI)
14318 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14319 IF (WTAPJ(MJ).GT.1D-6) THEN
14320 NJN=1
14321 ELSE
14322 WTAPJ(MJ)=0D0
14323 ENDIF
14324 ENDIF
14325C...Add trial gluon joinings.
14326 DO 170 MJ=1,MINT(31)
14327 KFLC=K(IMI(JS,MJ,1),2)
14328 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14329 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14330 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14331 IF (WTAPJ(MJ).GT.1D-6) THEN
14332 NJN=NJN+1
14333 ELSE
14334 WTAPJ(MJ)=0D0
14335 ENDIF
14336 170 CONTINUE
14337 ENDIF
14338 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14339C...Kill creation diagram for val quarks and sea quarks with companions.
14340 WTAP(21)=0D0
14341 ELSEIF (MQMASS.EQ.0) THEN
14342C...Extra safety factor for massless sea quark creation.
14343 WTAP(21)=WTAP(21)*1.25D0
14344 ENDIF
14345
14346C... q -> g, g -> g.
14347 ELSEIF(KFLB.EQ.21) THEN
14348C...Here we decide later whether a quark picked up is valence or
14349C...sea, so we maintain the extra factor sqrt(z) since we deal
14350C...with the *sum* of sea and valence in this context.
14351 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14352C...new: do not allow backwards evol to pick up heavy flavour.
14353 DO 180 KFL=1,MIN(3,MSTP(58))
14354 WTAP(KFL)=WTAPQ
14355 WTAP(-KFL)=WTAPQ
14356 180 CONTINUE
14357 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14358 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14359 WTAPQ=WTFG*WTAPQ
14360 WTAP(21)=WTGG*WTAP(21)
14361 ENDIF
14362C...Check for possible joinings (companions handled separately above)
14363 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14364 & THEN
14365 DO 190 MJ=1,MINT(31)
14366 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14367 KSVCC=IMI(JS,MJ,2)
14368 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14369 IF (KSVCC.GE.1) GOTO 190
14370 KFLC=K(IMI(JS,MJ,1),2)
14371C...Only try g -> g + g once.
14372 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14373 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14374 IF (KFLC.EQ.21) THEN
14375 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14376 ELSE
14377 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14378 ENDIF
14379 IF (WTAPJ(MJ).GT.1D-6) THEN
14380 NJN=NJN+1
14381 ELSE
14382 WTAPJ(MJ)=0D0
14383 ENDIF
14384 190 CONTINUE
14385 ENDIF
14386 ENDIF
14387
14388C...Initialize massive quark evolution
14389 IF (MQMASS.NE.0) THEN
14390 RML=(RMQ2+VINT(18))/ALAM2
14391 TML=LOG(RML)
14392 TPL=LOG((PT2+VINT(18))/ALAM2)
14393 TPM=LOG((PT2+VINT(18))/RMQ2)
14394 WN=WTAP(21)*WPDF0/B0
14395 ENDIF
14396
14397
14398C...Loopback point for iteration
14399 NTRY=0
14400 NTHRES=0
14401 200 NTRY=NTRY+1
14402 IF(NTRY.GT.500) THEN
14403 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14404 MINT(51)=1
14405 RETURN
14406 ENDIF
14407
14408C... Calculate PDF weights and sum for evolution rate.
14409 WTSUM=0D0
14410 XFBO=MAX(1D-10,XFB(KFLB))
14411 DO 210 KFL=-5,5
14412 WTPDF(KFL)=XFB(KFL)/XFBO
14413 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14414 210 CONTINUE
14415C...Only add gluon mother diagram for massless KFLB.
14416 IF(MQMASS.EQ.0) THEN
14417 WTPDF(21)=XFB(21)/XFBO
14418 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14419 ENDIF
14420 WTSUM=MAX(0.0001D0,WTSUM)
14421 WTSUMS=WTSUM
14422C...Add joining diagrams where applicable.
14423 WTJOIN=0D0
14424 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14425 DO 220 MJ=1,MINT(31)
14426 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14427 WTPDFJ(MJ)=1D0/XFBO
14428C...x and x*pdf (+ sea/val) for parton C.
14429 KFLC=K(IMI(JS,MJ,1),2)
14430 KFLCA=IABS(KFLC)
14431 KSVCC=MAX(-1,IMI(JS,MJ,2))
14432 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14433 MINT(30)=JS
14434 MINT(36)=MJ
14435 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14436 MINT(36)=MI
14437 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14438 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14439 ELSEIF (KSVCC.GE.1) THEN
14440 print*, 'error! parton C is companion!'
14441 ENDIF
14442 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14443C...x and x*pdf (+ sea/val) for parton A.
14444 KFLA=21
14445 KSVCA=0
14446 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14447 KFLA=KFLB
14448 KSVCA=KSVCB
14449 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14450 KFLA=KFLC
14451 KSVCA=KSVCC
14452 ENDIF
14453 MINT(30)=JS
14454 IF (KSVCA.LE.0) THEN
14455C...Consider C the "evolved" parton if B is gluon. Val/sea
14456C...counting will then be done correctly in PYPDFU.
14457 IF (KFLBA.EQ.21) MINT(36)=MJ
14458 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14459 MINT(36)=MI
14460 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14461 ELSE
14462C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
14463 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
14464 ENDIF
14465 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
14466 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
14467 220 CONTINUE
14468 ENDIF
14469
14470C...Pick normal pT2 (in overestimated z range).
14471 230 PT2OLD=PT2
14472 WTSUM=WTSUMS
14473 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
14474 KFLC=21
14475
14476C...Evolve q -> q gamma separately, pick it if larger pT.
14477 IF(KFLBA.LE.5) THEN
14478 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
14479 IF(PT2QED.GT.PT2) THEN
14480 PT2=PT2QED
14481 KFLC=22
14482 KFLA=KFLB
14483 ENDIF
14484 ENDIF
14485
14486C... Evolve massive quark creation separately.
14487 MCRQQ=0
14488 IF (MQMASS.NE.0) THEN
14489 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
14490 & -VINT(18)
14491C... Ensure mininimum PT2CR and force creation near threshold.
14492 IF (PT2CR.LT.TMIN*RMQ2) THEN
14493 NTHRES=NTHRES+1
14494 IF (NTHRES.GT.50) THEN
14495 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
14496 & 'massive quark creation. Gave up trying.')
14497 MINT(51)=1
14498 RETURN
14499 ENDIF
14500 PT2=0D0
14501 PT2CR=TMIN*RMQ2
14502 MCRQQ=2
14503 ENDIF
14504C... Select largest PT2 (brems or creation):
14505 IF (PT2CR.GT.PT2) THEN
14506 MCRQQ=MAX(MCRQQ,1)
14507 WTSUM=0D0
14508 PT2=PT2CR
14509 KFLA=21
14510 ELSE
14511 MCRQQ=0
14512 KFLA=KFLB
14513 ENDIF
14514C... Compute logarithms for this PT2
14515 TPL=LOG((PT2+VINT(18))/ALAM2)
14516 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
14517 WTCRQQ=TPM/LOG(PT2/RMQ2)
14518 ENDIF
14519
14520C...Evolve joining separately
14521 MJOIN=0
14522 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14523 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
14524 & -VINT(18)
14525 IF (PT2JN.GE.PT2) THEN
14526 MJOIN=1
14527 PT2=PT2JN
14528 ENDIF
14529 ENDIF
14530
14531C...Loopback if crossed c/b mass thresholds.
14532 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
14533 PT2=RMB2
14534 GOTO 130
14535 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
14536 PT2=RMC2
14537 GOTO 130
14538 ENDIF
14539
14540C...Speed up shower. Skip if higher-PT acceptable branching
14541C...already found somewhere else.
14542C...Also finish if below lower cutoff.
14543
14544 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
14545
14546C...Select parton A flavour (massive Q handled above.)
14547 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
14548 WTRAN=PYR(0)*WTSUM
14549 KFLA=-6
14550 240 KFLA=KFLA+1
14551 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
14552 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
14553 IF(KFLA.EQ.6) KFLA=21
14554 ELSEIF (MJOIN.EQ.1) THEN
14555C...Tentative joining accept/reject.
14556 WTRAN=PYR(0)*WTJOIN
14557 MJ=0
14558 250 MJ=MJ+1
14559 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
14560 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
14561 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
14562 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
14563 & ' Rejected.')
14564 GOTO 230
14565 ENDIF
14566C...x*pdf (+ sea/val) at new pT2 for parton B.
14567 IF (KSVCB.LE.0) THEN
14568 MINT(30)=JS
14569 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14570 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
14571 ELSE
14572C...Companion distributions do not evolve.
14573 XFB(KFLB)=XFBO
14574 ENDIF
14575 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
14576 KFLC=K(IMI(JS,MJ,1),2)
14577 KFLCA=IABS(KFLC)
14578 KSVCC=MAX(-1,IMI(JS,MJ,2))
14579 IF (KSVCB.GE.1) KSVCC=-1
14580C...x*pdf (+ sea/val) at new pT2 for parton C.
14581 MINT(30)=JS
14582 MINT(36)=MJ
14583 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14584 MINT(36)=MI
14585 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14586 WTVETO=WTVETO/XFJ(KFLC)
14587C...x and x*pdf (+ sea/val) at new pT2 for parton A.
14588 KFLA=21
14589 KSVCA=0
14590 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14591 KFLA=KFLB
14592 KSVCA=KSVCB
14593 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14594 KFLA=KFLC
14595 KSVCA=KSVCC
14596 ENDIF
14597 IF (KSVCA.LE.0) THEN
14598 MINT(30)=JS
14599 IF (KFLB.EQ.21) MINT(36)=MJ
14600 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
14601 MINT(36)=MI
14602 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
14603 ELSE
14604 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
14605 ENDIF
14606 WTVETO=WTVETO*XFJ(KFLA)
14607C...Monte Carlo veto.
14608 IF (WTVETO.LT.PYR(0)) GOTO 200
14609C...If accept, save PT2 of this joining.
14610 IF (PT2.GT.PT2MX) THEN
14611 PT2MX=PT2
14612 JSMX=2+JS
14613 MJN1MX=MJ
14614 MJN2MX=MI
14615 WTAPJ(MJ)=0D0
14616 NJN=0
14617 ENDIF
14618C...Exit and continue evolution.
14619 GOTO 380
14620 ENDIF
14621 KFLAA=IABS(KFLA)
14622
14623C...Choose z value (still in overestimated range) and corrective weight.
14624C...Unphysical z will be rejected below when Q2 has is computed.
14625 WTZ=0D0
14626
14627C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
14628C...q -> q + g or q -> q + gamma (already set which).
14629 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
14630 IF (KSVCB.LT.0) THEN
14631 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
14632 ELSE
14633 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
14634 Z=((1-ZFAC)/(1+ZFAC))**2
14635 ENDIF
14636 WTZ=0.5D0*(1D0+Z**2)
14637C...Massive weight correction.
14638 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
14639C...Valence quark weight correction (extra sqrt)
14640 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
14641
14642C...q -> g + q.
14643C...NB: MQ>0 not yet implemented. Forced absent above.
14644 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
14645 KFLC=KFLA
14646 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
14647 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14648
14649C...g -> q + qbar.
14650 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
14651 KFLC=-KFLB
14652 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
14653 WTZ=Z**2+(1D0-Z)**2
14654C...Massive correction
14655 IF (MQMASS.NE.0) THEN
14656 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
14657C...Extra safety margin for light sea quark creation
14658 ELSEIF (KSVCB.LT.0) THEN
14659 WTZ=WTZ/1.25D0
14660 ENDIF
14661
14662C...g -> g + g.
14663 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14664 KFLC=21
14665 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
14666 & (ZMAX*(1D0-ZMIN)))**PYR(0))
14667 WTZ=(1D0-Z*(1D0-Z))**2
14668 ENDIF
14669
14670C...Derive Q2 from pT2.
14671 Q2B=PT2/(1D0-Z)
14672 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
14673
14674C...Loopback if outside allowed z range for given pT2.
14675 RM2C=PYMASS(KFLC)**2
14676 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
14677 IF (PT2ADJ.LT.1D-6) GOTO 230
14678
14679C...Loopback if nonordered in angle/rapidity.
14680 IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
14681 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
14682 & GOTO 230
14683 ENDIF
14684
14685C...Select phi angle of branching at random.
14686 PHI=PARU(2)*PYR(0)
14687
14688C...Matrix-element corrections for some processes.
14689 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14690 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
14691 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14692 WTZ=WTZ*WTME/WTFF
14693 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
14694 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14695 WTZ=WTZ*WTME/WTGF
14696 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14697 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14698 WTZ=WTZ*WTME/WTFG
14699 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14700 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
14701 WTZ=WTZ*WTME/WTGG
14702 ENDIF
14703 ENDIF
14704
14705C...Parton distributions at new pT2 but old x.
14706 MINT(30)=JS
14707 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
14708C...Treat val and cmp separately
14709 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
14710 IF (KSVCB.GE.1)
14711 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14712 XFBN=XFN(KFLB)
14713 IF(XFBN.LT.1D-20) THEN
14714 IF(KFLA.EQ.KFLB) THEN
14715 WTAP(KFLB)=0D0
14716 GOTO 200
14717 ELSE
14718 XFBN=1D-10
14719 XFN(KFLB)=XFBN
14720 ENDIF
14721 ENDIF
14722 DO 260 KFL=-5,5
14723 XFB(KFL)=XFN(KFL)
14724 260 CONTINUE
14725 XFB(21)=XFN(21)
14726
14727C...Parton distributions at new pT2 and new x.
14728 XA=XB/Z
14729 MINT(30)=JS
14730 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
14731 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
14732C...q -> q + g: only consider respective sea, val, or cmp content.
14733 IF (KSVCB.LE.0) THEN
14734 XFA(KFLA)=XPSVC(KFLA,KSVCB)
14735 ELSE
14736 YA=XA*(1D0-YS)
14737 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
14738 ENDIF
14739 ENDIF
14740 XFAN=XFA(KFLA)
14741 IF(XFAN.LT.1D-20) THEN
14742 GOTO 200
14743 ENDIF
14744
14745C...If weighting fails continue evolution.
14746 WTTOT=0D0
14747 IF (MCRQQ.EQ.0) THEN
14748 WTPDFA=1D0/WTPDF(KFLA)
14749 WTTOT=WTZ*XFAN/XFBN*WTPDFA
14750 ELSEIF(MCRQQ.EQ.1) THEN
14751 WTPDFA=TPM/WPDF0
14752 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
14753 XBEST=TPM/TPM0*XQ0
14754 ELSEIF(MCRQQ.EQ.2) THEN
14755C...Force massive quark creation.
14756 WTTOT=1D0
14757 ENDIF
14758
14759C...Loop back if trial emission fails.
14760 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
14761 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
14762 IF(WTTOT.LT.0D0) THEN
14763 WRITE(CHWT,'(1P,E12.4)') WTTOT
14764 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
14765 ELSEIF(WTTOT.GT.WTACC) THEN
14766 WRITE(CHWT,'(1P,E12.4)') WTTOT
14767 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
14768C...Too high weight: write out as error, but do not update error counter.
14769 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
14770 CALL PYERRM(19,
14771 & '(PYPTIS:) Weight '//CHWT//' above unity')
14772 IF (PT2.GT.PTEMAX) PTEMAX=PT2
14773 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
14774 ELSE
14775 CALL PYERRM(9,
14776 & '(PYPTIS:) Weight '//CHWT//' above unity')
14777 ENDIF
14778C...Useful for debugging but commented out for distribution:
14779C print*, 'JS, MI',JS, MI
14780C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
14781C print*, 'A -> B C',KFLA, KFLB, KFLC
14782C XFAO=XFBO/WTPDFA
14783C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
14784 ENDIF
14785
14786C...Save acceptable branching.
14787 IF(PT2.GT.PT2MX) THEN
14788 MIMX=MINT(36)
14789 JSMX=JS
14790 PT2MX=PT2
14791 KFLAMX=KFLA
14792 KFLCMX=KFLC
14793 RM2CMX=RM2C
14794 Q2BMX=Q2B
14795 ZMX=Z
14796 PT2AMX=PT2ADJ
14797 PHIMX=PHI
14798 ENDIF
14799
14800C----------------------------------------------------------------------
14801C...MODE= 1: Accept stored shower branching. Update event record etc.
14802 ELSEIF (MODE.EQ.1) THEN
14803 MI=MIMX
14804 JS=JSMX
14805 SHAT=SHTNOW(MI)
14806 SIDE=3D0-2D0*JS
14807C...Shift down rest of event record to make room for insertion.
14808 IT=IMISEP(MI)+1
14809 IM=IT+1
14810 IS=IMI(JS,MI,1)
14811 DO 280 I=N,IT,-1
14812 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
14813 KT1=K(I,4)/MSTU(5)**2
14814 KT2=K(I,5)/MSTU(5)**2
14815 ID1=MOD(K(I,4),MSTU(5))
14816 ID2=MOD(K(I,5),MSTU(5))
14817 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
14818 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
14819 IF (ID1.GE.IT) ID1=ID1+2
14820 IF (ID2.GE.IT) ID2=ID2+2
14821 IF (IM1.GE.IT) IM1=IM1+2
14822 IF (IM2.GE.IT) IM2=IM2+2
14823 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
14824 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
14825 DO 270 IX=1,5
14826 K(I+2,IX)=K(I,IX)
14827 P(I+2,IX)=P(I,IX)
14828 V(I+2,IX)=V(I,IX)
14829 270 CONTINUE
14830 MCT(I+2,1)=MCT(I,1)
14831 MCT(I+2,2)=MCT(I,2)
14832 280 CONTINUE
14833 N=N+2
14834C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
14835 DO 290 JI=1,MINT(31)
14836 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
14837 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
14838 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
14839 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
14840 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
14841C...Also update companion pointers to the present mother.
14842 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
14843 290 CONTINUE
14844 DO 300 IFS=1,NPART
14845 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
14846 300 CONTINUE
14847C...Zero entries dedicated for new timelike and mother partons.
14848 DO 320 I=IT,IT+1
14849 DO 310 J=1,5
14850 K(I,J)=0
14851 P(I,J)=0D0
14852 V(I,J)=0D0
14853 310 CONTINUE
14854 MCT(I,1)=0
14855 MCT(I,2)=0
14856 320 CONTINUE
14857
14858C...Define timelike and new mother partons. History.
14859 K(IT,1)=3
14860 K(IT,2)=KFLCMX
14861 K(IM,1)=14
14862 K(IM,2)=KFLAMX
14863 K(IS,3)=IM
14864 K(IT,3)=IM
14865C...Set mother origin = side.
14866 K(IM,3)=MINT(83)+JS+2
14867 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
14868
14869C...Define colour flow of branching.
14870 IM1=IM
14871 IM2=IM
14872C...q -> q + gamma.
14873 IF(K(IT,2).EQ.22) THEN
14874 K(IT,1)=1
14875 ID1=IS
14876 ID2=IS
14877C...q -> q + g.
14878 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
14879 ID1=IT
14880 ID2=IS
14881C...q -> g + q.
14882 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
14883 ID1=IS
14884 ID2=IT
14885C...qbar -> qbar + g.
14886 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
14887 ID1=IS
14888 ID2=IT
14889C...qbar -> g + qbar.
14890 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
14891 ID1=IT
14892 ID2=IS
14893C...g -> g + g; g -> q + qbar..
14894 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14895 ID1=IS
14896 ID2=IT
14897 ELSE
14898 ID1=IT
14899 ID2=IS
14900 ENDIF
14901 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
14902 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
14903 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14904 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14905 IF(ID1.NE.ID2) THEN
14906 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14907 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14908 ENDIF
14909 IF(K(IT,1).EQ.1) THEN
14910 K(IT,4)=0
14911 K(IT,5)=0
14912 ENDIF
14913C...Update IMI and colour tag arrays.
14914 IMI(JS,MI,1)=IM
14915 DO 330 MC=1,2
14916 MCT(IT,MC)=0
14917 MCT(IM,MC)=0
14918 330 CONTINUE
14919 DO 340 JCS=4,5
14920 KCS=JCS
14921C...If mother flag not yet set for spacelike parton, trace it.
14922 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
14923 IF(MINT(51).NE.0) RETURN
14924 340 CONTINUE
14925 DO 350 JCS=4,5
14926 KCS=JCS
14927C...If mother flag not yet set for timelike parton, trace it.
14928 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
14929 IF(MINT(51).NE.0) RETURN
14930 350 CONTINUE
14931
14932C...Boost recoiling parton to compensate for Q2 scale.
14933 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
14934 & (1D0+(1D0+Q2BMX/SHAT)**2)
14935 IR=IMI(3-JS,MI,1)
14936 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
14937
14938C...Define system to be rotated and boosted
14939C...(not including the 2 just added partons)
14940C...(but including the docu lines for first interaction)
14941 IMIN=IMISEP(MI-1)+1
14942 IF (MI.EQ.1) IMIN=MINT(83)+5
14943 IMAX=IMISEP(MI)-2
14944
14945C...Rotate back system in phi to compensate for subsequent rotation.
14946 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
14947
14948C...Define kinematics of new partons in old frame.
14949 IMAX=IMISEP(MI)
14950 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
14951 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
14952 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
14953 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
14954 P(IT,1)=P(IM,1)
14955 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
14956 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
14957 P(IT,5)=SQRT(RM2CMX)
14958
14959C...Update internal line, now spacelike
14960 P(IS,1)=P(IM,1)-P(IT,1)
14961 P(IS,2)=P(IM,2)-P(IT,2)
14962 P(IS,3)=P(IM,3)-P(IT,3)
14963 P(IS,4)=P(IM,4)-P(IT,4)
14964 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
14965C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
14966 IF (P(IS,5).LT.0D0) THEN
14967 P(IS,5)=-SQRT(ABS(P(IS,5)))
14968 ELSE
14969 P(IS,5)=SQRT(P(IS,5))
14970 ENDIF
14971
14972C...Boost entire system and rotate to new frame.
14973C...(including docu lines)
14974 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
14975 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
14976 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
14977 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
14978 MINT(51)=1
14979 IFAIL=-1
14980 RETURN
14981 ENDIF
14982 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
14983 I1=IMI(1,MI,1)
14984 THETA=PYANGL(P(I1,3),P(I1,1))
14985 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
14986
14987C...Global statistics.
14988 MINT(352)=MINT(352)+1
14989 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14990 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14991
14992C...Add parton with relevant pT scale for timelike shower.
14993 IF (K(IT,2).NE.22) THEN
14994 NPART=NPART+1
14995 IPART(NPART)=IT
14996 PTPART(NPART)=SQRT(PT2AMX)
14997 ENDIF
14998
14999C...Update saved variables.
15000 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15001 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15002 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15003 PT2SAV(JSMX,MIMX)=PT2MX
15004 ZSAV(JS,MIMX)=ZMX
15005
15006 KSA=IABS(K(IS,2))
15007 KMA=IABS(K(IM,2))
15008 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15009C...Gluon reconstructs to quark.
15010C...Decide whether newly created quark is valence or sea:
15011 MINT(30)=JS
15012 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15013 IF(MINT(51).NE.0) RETURN
15014 ENDIF
15015 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15016C...Quark reconstructs to gluon.
15017C...Now some guy may have lost his companion. Check.
15018 ICMP=IMI(JS,MI,2)
15019 IF (ICMP.GT.0) THEN
15020 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15021 & //' away. Cannot handle that yet. Giving up.')
15022 MINT(51)=1
15023 RETURN
15024 ELSEIF(ICMP.LT.0) THEN
15025C...A sea quark with companion still in BR was reconstructed to a gluon.
15026C...Companion should now be removed from the beam remnant.
15027C...(Momentum integral is automatically updated in next call to PYPDFU.)
15028 ICMP=-ICMP
15029 IFL=-K(IS,2)
15030 DO 370 JCMP=ICMP,NVC(JS,IFL)-1
15031 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15032 DO 360 JI=1,MINT(31)
15033 KMI=-IMI(JS,JI,2)
15034 JFL=-K(IMI(JS,JI,1),2)
15035 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15036 & ,2)+1
15037 360 CONTINUE
15038 370 CONTINUE
15039 NVC(JS,IFL)=NVC(JS,IFL)-1
15040 ENDIF
15041C...Set gluon IMI(JS,MI,2) = 0.
15042 IMI(JS,MI,2)=0
15043 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15044C...Quark reconstructing to quark. If sea with companion still in BR
15045C...then update associated x value.
15046C...(Momentum integral is automatically updated in next call to PYPDFU.)
15047 IF (IMI(JS,MI,2).LT.0) THEN
15048 ICMP=-IMI(JS,MI,2)
15049 IFL=-K(IS,2)
15050 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15051 ENDIF
15052 ENDIF
15053
15054 ENDIF
15055
15056C...If reached this point, normal exit.
15057 380 IFAIL=0
15058
15059 RETURN
15060 END
15061
15062C*********************************************************************
15063
15064C...PYMEMX
15065C...Generates maximum ME weight in some initial-state showers.
15066C...Inparameter MECOR: kind of hard scattering process
15067C...Outparameter WTFF: maximum weight for fermion -> fermion
15068C... WTGF: maximum weight for gluon/photon -> fermion
15069C... WTFG: maximum weight for fermion -> gluon/photon
15070C... WTGG: maximum weight for gluon -> gluon
15071
15072 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15073
15074C...Double precision and integer declarations.
15075 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15076 IMPLICIT INTEGER(I-N)
15077 INTEGER PYK,PYCHGE,PYCOMP
15078C...Commonblocks.
15079 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15080 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15081 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15082 COMMON/PYINT1/MINT(400),VINT(400)
15083 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15084 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15085
15086C...Default maximum weight.
15087 WTFF=1D0
15088 WTGF=1D0
15089 WTFG=1D0
15090 WTGG=1D0
15091
15092C...Select maximum weight by process.
15093 IF(MECOR.EQ.1) THEN
15094 WTFF=1D0
15095 WTGF=3D0
15096 ELSEIF(MECOR.EQ.2) THEN
15097 WTFG=1D0
15098 WTGG=1D0
15099 ENDIF
15100
15101 RETURN
15102 END
15103
15104C*********************************************************************
15105
15106C...PYMEWT
15107C...Calculates actual ME weight in some initial-state showers.
15108C...Inparameter MECOR: kind of hard scattering process
15109C... IFLCB: flavour combination of branching,
15110C... 1 for fermion -> fermion,
15111C... 2 for gluon/photon -> fermion
15112C... 3 for fermion -> gluon/photon,
15113C... 4 for gluon -> gluon
15114C... Q2: Q2 value of shower branching
15115C... Z: Z value of branching
15116C...In+outparameter PHIBR: azimuthal angle of branching
15117C...Outparameter WTME: actual ME weight
15118
15119 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15120
15121C...Double precision and integer declarations.
15122 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15123 IMPLICIT INTEGER(I-N)
15124 INTEGER PYK,PYCHGE,PYCOMP
15125C...Commonblocks.
15126 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15128 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15129 COMMON/PYINT1/MINT(400),VINT(400)
15130 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15131 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15132
15133C...Default output.
15134 WTME=1D0
15135
15136C...Define kinematics of shower branching in Mandelstam variables.
15137 SQM=VINT(44)
15138 SH=SQM/Z
15139 TH=-Q2
15140 UH=Q2-SQM*(1D0-Z)/Z
15141
15142C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15143 IF(MECOR.EQ.1) THEN
15144 IF(IFLCB.EQ.1) THEN
15145 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15146 ELSEIF(IFLCB.EQ.2) THEN
15147 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15148 ENDIF
15149
15150C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15151 ELSEIF(MECOR.EQ.2) THEN
15152 IF(IFLCB.EQ.3) THEN
15153 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15154 ELSEIF(IFLCB.EQ.4) THEN
15155 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15156 ENDIF
15157
15158C...Matrix-element corrections for q + qbar -> Higgs (h0)
15159 ELSEIF(MECOR.EQ.3) THEN
15160 IF(IFLCB.EQ.2) THEN
15161 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15162 1 (SH**2+2D0*SQM*(SQM-SH))
15163 ENDIF
15164 ENDIF
15165
15166 RETURN
15167 END
15168
15169C*********************************************************************
15170
15171C...PYPTMI
15172C...Handles the generation of additional interactions in the new
15173C...multiple interactions framework.
15174C...MODE=-1 : Initalize MI from scratch.
15175C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15176C... Sudakov for PT2, abort if below PT2CUT.
15177C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15178C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15179C...PT2NOW : Starting (max) PT2 scale for evolution.
15180C...PT2CUT : Lower limit for evolution.
15181C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15182C...IFAIL : Status return code.
15183C... = 0: All is well.
15184C... < 0: Phase space exhausted, generation to be terminated.
15185C... > 0: Additional interaction vetoed, but continue evolution.
15186
15187 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15188C...Double precision and integer declarations.
15189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15190 IMPLICIT INTEGER(I-N)
15191 INTEGER PYK,PYCHGE,PYCOMP
15192C...Parameter statement for maximum size of showers.
15193 PARAMETER (MAXNUR=1000)
15194C...Commonblocks.
15195 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15196 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15197 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15198 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15199 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15200 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15201 COMMON/PYINT1/MINT(400),VINT(400)
15202 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15203 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15204 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15205 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15206 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15207 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15208 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15209 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15210 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15211 COMMON/PYCTAG/NCT,MCT(4000,2)
15212C...Local arrays and saved variables.
15213 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15214
15215 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15216 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15217 & /PYISMX/,/PYCTAG/
15218 SAVE XT2FAC,SIGS
15219
15220 IFAIL=0
15221C...Set MI subprocess = QCD 2 -> 2.
15222 ISUB=96
15223
15224C----------------------------------------------------------------------
15225C...MODE=-1: Initialize from scratch
15226 IF (MODE.EQ.-1) THEN
15227C...Initialize PT2 array.
15228 PT2MI(1)=VINT(54)
15229C...Initialize list of incoming beams and partons from two sides.
15230 DO 110 JS=1,2
15231 DO 100 MI=1,240
15232 IMI(JS,MI,1)=0
15233 IMI(JS,MI,2)=0
15234 100 CONTINUE
15235 NMI(JS)=1
15236 IMI(JS,1,1)=MINT(84)+JS
15237 IMI(JS,1,2)=0
15238 XMI(JS,1)=VINT(40+JS)
15239C...Rescale x values to fractions of photon energy.
15240 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15241C...Hard reset: hard interaction initiators motherless by definition.
15242 K(MINT(84)+JS,3)=2+JS
15243 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15244 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15245 110 CONTINUE
15246 IMISEP(0)=MINT(84)
15247 IMISEP(1)=N
15248 IF (MOD(MSTP(81),10).GE.1) THEN
15249 IF(MSTP(82).LE.1) THEN
15250 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15251 & ,5))
15252 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15253 & VINT(317)/(VINT(318)*VINT(320))
15254 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15255 ELSE
15256 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15257 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15258 ENDIF
15259 ENDIF
15260C...Zero entries relating to scatterings beyond the first.
15261 DO 120 MI=2,240
15262 IMI(1,MI,1)=0
15263 IMI(2,MI,1)=0
15264 IMI(1,MI,2)=0
15265 IMI(2,MI,2)=0
15266 IMISEP(MI)=IMISEP(1)
15267 PT2MI(MI)=0D0
15268 XMI(1,MI)=0D0
15269 XMI(2,MI)=0D0
15270 120 CONTINUE
15271C...Initialize factors for PDF reshaping.
15272 DO 140 JS=1,2
15273 KFBEAM(JS)=MINT(10+JS)
15274 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15275 KFABM=IABS(KFBEAM(JS))
15276 KFSBM=ISIGN(1,KFBEAM(JS))
15277
15278C...Zero flavour content of incoming beam particle.
15279 KFIVAL(JS,1)=0
15280 KFIVAL(JS,2)=0
15281 KFIVAL(JS,3)=0
15282C... Flavour content of baryon.
15283 IF(KFABM.GT.1000) THEN
15284 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15285 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15286 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15287C... Flavour content of pi+-, K+-.
15288 ELSEIF(KFABM.EQ.211) THEN
15289 KFIVAL(JS,1)=KFSBM*2
15290 KFIVAL(JS,2)=-KFSBM
15291 ELSEIF(KFABM.EQ.321) THEN
15292 KFIVAL(JS,1)=-KFSBM*3
15293 KFIVAL(JS,2)=KFSBM*2
15294C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15295 ENDIF
15296
15297C...Zero initial valence and companion content.
15298 DO 130 IFL=-6,6
15299 NVC(JS,IFL)=0
15300 130 CONTINUE
15301 140 CONTINUE
15302C...Set up colour line tags starting from hard interaction initiators.
15303 NCT=0
15304C...Reset colour tag array and colour processing flags.
15305 DO 150 I=IMISEP(0)+1,N
15306 MCT(I,1)=0
15307 MCT(I,2)=0
15308 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15309 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15310 150 CONTINUE
15311C... Consider each side in turn.
15312 DO 170 JS=1,2
15313 I1=IMI(JS,1,1)
15314 I2=IMI(3-JS,1,1)
15315 DO 160 JCS=4,5
15316 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15317 & GOTO 160
15318 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15319 KCS=JCS
15320 CALL PYCTTR(I1,KCS,I2)
15321 IF(MINT(51).NE.0) RETURN
15322 160 CONTINUE
15323 170 CONTINUE
15324
15325C...Range checking for companion quark pdf large-x param.
15326 IF (MSTP(87).LT.0) THEN
15327 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15328 & ' MSTP(87)=0')
15329 MSTP(87)=0
15330 ELSEIF (MSTP(87).GT.4) THEN
15331 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15332 & ' MSTP(87)=4')
15333 MSTP(87)=4
15334 ENDIF
15335
15336C----------------------------------------------------------------------
15337C...MODE=0: Generate trial interaction. Return codes:
15338C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15339C...IFAIL = 0: Additional interaction generated at PT2.
15340C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15341 ELSEIF (MODE.EQ.0) THEN
15342C...Abolute MI max scale = VINT(62)
15343 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15344 180 IF(MSTP(82).LE.1) THEN
15345 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15346 IF(XT2.LT.VINT(149)) IFAIL=-2
15347 ELSE
15348 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15349 IFAIL=-3
15350 ELSE
15351 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15352 & LOG(PYR(0)))-VINT(149)
15353 ENDIF
15354 ENDIF
15355C...Also exit if below lower limit or if higher trial branching
15356C...already found.
15357 PT2=0.25D0*VINT(2)*XT2
15358 IF (PT2.LE.PT2CUT) IFAIL=-4
15359 IF (PT2.LE.PT2MX) IFAIL=-5
15360 IF (IFAIL.NE.0) THEN
15361 PT2=0D0
15362 RETURN
15363 ENDIF
15364 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15365 VINT(25)=4D0*PT2/VINT(2)
15366 XT2=VINT(25)
15367
15368C...Choose tau and y*. Calculate cos(theta-hat).
15369 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15370 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15371 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15372 ELSE
15373 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15374 ENDIF
15375 VINT(21)=TAU
15376C...New: require shat > 1.
15377 IF(TAU*VINT(2).LT.1D0) GOTO 180
15378 CALL PYKLIM(2)
15379 RYST=PYR(0)
15380 MYST=1
15381 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15382 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15383 CALL PYKMAP(2,MYST,PYR(0))
15384 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15385
15386C...Check that x not used up. Accept or reject kinematical variables.
15387 X1M=SQRT(TAU)*EXP(VINT(22))
15388 X2M=SQRT(TAU)*EXP(-VINT(22))
15389 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15390 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15391 CALL PYSIGH(NCHN,SIGS)
15392 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15393 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15394 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
15395
15396C...Save if highest PT so far.
15397 IF (PT2.GT.PT2MX) THEN
15398 JSMX=0
15399 MIMX=MINT(31)+1
15400 PT2MX=PT2
15401 ENDIF
15402
15403C----------------------------------------------------------------------
15404C...MODE=1: Generate and save accepted scattering.
15405 ELSEIF (MODE.EQ.1) THEN
15406 PT2=PT2NOW
15407C...Reset K, P, V, and MCT vectors.
15408 DO 200 I=N+1,N+4
15409 DO 190 J=1,5
15410 K(I,J)=0
15411 P(I,J)=0D0
15412 V(I,J)=0D0
15413 190 CONTINUE
15414 MCT(I,1)=0
15415 MCT(I,2)=0
15416 200 CONTINUE
15417
15418 NTRY=0
15419C...Choose flavour of reacting partons (and subprocess).
15420 210 NTRY=NTRY+1
15421 IF (NTRY.GT.50) THEN
15422 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
15423 & //'interaction. Giving up!')
15424 MINT(51)=1
15425 RETURN
15426 ENDIF
15427 RSIGS=SIGS*PYR(0)
15428 DO 220 ICHN=1,NCHN
15429 KFL1=ISIG(ICHN,1)
15430 KFL2=ISIG(ICHN,2)
15431 ICONMI=ISIG(ICHN,3)
15432 RSIGS=RSIGS-SIGH(ICHN)
15433 IF(RSIGS.LE.0D0) GOTO 230
15434 220 CONTINUE
15435
15436C...Reassign to appropriate process codes.
15437 230 ISUBMI=ICONMI/10
15438 ICONMI=MOD(ICONMI,10)
15439
15440C...Choose new quark flavour for annihilation graphs
15441 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
15442 SH=VINT(21)*VINT(2)
15443 CALL PYWIDT(21,SH,WDTP,WDTE)
15444 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
15445 DO 250 I=1,MDCY(21,3)
15446 KFLF=KFDP(I+MDCY(21,2)-1,1)
15447 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
15448 IF(RKFL.LE.0D0) GOTO 260
15449 250 CONTINUE
15450 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
15451 IF(KFLF.GE.4) GOTO 240
15452 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
15453 KFLF=4
15454 ICONMI=ICONMI-2
15455 ELSEIF(ISUBMI.EQ.53) THEN
15456 KFLF=5
15457 ICONMI=ICONMI-4
15458 ENDIF
15459 ENDIF
15460
15461C...Final state flavours and colour flow: default values
15462 JS=1
15463 KFL3=KFL1
15464 KFL4=KFL2
15465 KCC=20
15466 KCS=ISIGN(1,KFL1)
15467
15468 IF(ISUBMI.EQ.11) THEN
15469C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
15470 KCC=ICONMI
15471 IF(KFL1*KFL2.LT.0) KCC=KCC+2
15472
15473 ELSEIF(ISUBMI.EQ.12) THEN
15474C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
15475 KFL3=ISIGN(KFLF,KFL1)
15476 KFL4=-KFL3
15477 KCC=4
15478
15479 ELSEIF(ISUBMI.EQ.13) THEN
15480C...f + fbar -> g + g; th arbitrary
15481 KFL3=21
15482 KFL4=21
15483 KCC=ICONMI+4
15484
15485 ELSEIF(ISUBMI.EQ.28) THEN
15486C...f + g -> f + g; th = (p(f)-p(f))**2
15487 IF(KFL1.EQ.21) JS=2
15488 KCC=ICONMI+6
15489 IF(KFL1.EQ.21) KCC=KCC+2
15490 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
15491 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
15492
15493 ELSEIF(ISUBMI.EQ.53) THEN
15494C...g + g -> f + fbar; th arbitrary
15495 KCS=(-1)**INT(1.5D0+PYR(0))
15496 KFL3=ISIGN(KFLF,KCS)
15497 KFL4=-KFL3
15498 KCC=ICONMI+10
15499
15500 ELSEIF(ISUBMI.EQ.68) THEN
15501C...g + g -> g + g; th arbitrary
15502 KCC=ICONMI+12
15503 KCS=(-1)**INT(1.5D0+PYR(0))
15504 ENDIF
15505
15506C...Check that massive sea quarks have non-zero phase space for g -> Q Q
15507 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
15508 & .OR.IABS(KFL4).EQ.5) THEN
15509 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
15510 IF (PT2.LE.1.05*RMMAX2) THEN
15511 IF (NTRY.EQ.1) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
15512 & //' created below threshold. Rejected.')
15513 GOTO 210
15514 ENDIF
15515 ENDIF
15516
15517C...Store flavours of scattering.
15518 MINT(13)=KFL1
15519 MINT(14)=KFL2
15520 MINT(15)=KFL1
15521 MINT(16)=KFL2
15522 MINT(21)=KFL3
15523 MINT(22)=KFL4
15524
15525C...Set flavours and mothers of scattering partons.
15526 K(N+1,1)=14
15527 K(N+2,1)=14
15528 K(N+3,1)=3
15529 K(N+4,1)=3
15530 K(N+1,2)=KFL1
15531 K(N+2,2)=KFL2
15532 K(N+3,2)=KFL3
15533 K(N+4,2)=KFL4
15534 K(N+1,3)=MINT(83)+1
15535 K(N+2,3)=MINT(83)+2
15536 K(N+3,3)=N+1
15537 K(N+4,3)=N+2
15538
15539C...Store colour connection indices.
15540 DO 270 J=1,2
15541 JC=J
15542 IF(KCS.EQ.-1) JC=3-J
15543 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
15544 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
15545 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
15546 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
15547 270 CONTINUE
15548
15549C...Store incoming and outgoing partons in their CM-frame.
15550 SHR=SQRT(VINT(21))*VINT(1)
15551 P(N+1,3)=0.5D0*SHR
15552 P(N+1,4)=0.5D0*SHR
15553 P(N+2,3)=-0.5D0*SHR
15554 P(N+2,4)=0.5D0*SHR
15555 P(N+3,5)=PYMASS(K(N+3,2))
15556 P(N+4,5)=PYMASS(K(N+4,2))
15557 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
15558 IFAIL=1
15559 RETURN
15560 ENDIF
15561 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
15562 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
15563 P(N+4,4)=SHR-P(N+3,4)
15564 P(N+4,3)=-P(N+3,3)
15565
15566C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
15567 PHI=PARU(2)*PYR(0)
15568 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
15569
15570C...Global statistics.
15571 MINT(351)=MINT(351)+1
15572 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
15573 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
15574
15575C...Keep track of loose colour ends and information on scattering.
15576 MINT(31)=MINT(31)+1
15577 MINT(36)=MINT(31)
15578 PT2MI(MINT(36))=PT2
15579 IMISEP(MINT(31))=N+4
15580 DO 280 JS=1,2
15581 IMI(JS,MINT(31),1)=N+JS
15582 IMI(JS,MINT(31),2)=0
15583 XMI(JS,MINT(31))=VINT(40+JS)
15584 NMI(JS)=NMI(JS)+1
15585C...Update cumulative counters
15586 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
15587 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
15588 280 CONTINUE
15589
15590C...Add to list of final state partons
15591 IPART(NPART+1)=N+3
15592 IPART(NPART+2)=N+4
15593 PTPART(NPART+1)=SQRT(PT2)
15594 PTPART(NPART+2)=SQRT(PT2)
15595 NPART=NPART+2
15596
15597C...Initialize ISR
15598 NISGEN(1,MINT(31))=0
15599 NISGEN(2,MINT(31))=0
15600
15601C...Update ER
15602 N=N+4
15603 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
15604 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
15605 MINT(51)=1
15606 RETURN
15607 ENDIF
15608
15609C...Finally, assign colour tags to new partons
15610 DO 300 JS=1,2
15611 I1=IMI(JS,MINT(31),1)
15612 I2=IMI(3-JS,MINT(31),1)
15613 DO 290 JCS=4,5
15614 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15615 & GOTO 290
15616 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
15617 KCS=JCS
15618 CALL PYCTTR(I1,KCS,I2)
15619 IF(MINT(51).NE.0) RETURN
15620 290 CONTINUE
15621 300 CONTINUE
15622
15623C----------------------------------------------------------------------
15624C...MODE=2: Decide whether quarks in last scattering were valence,
15625C...companion, or sea.
15626 ELSEIF (MODE.EQ.2) THEN
15627 JS=MINT(30)
15628 MI=MINT(36)
15629 PT2=PT2NOW
15630 KFSBM=ISIGN(1,MINT(10+JS))
15631 IFL=K(IMI(JS,MI,1),2)
15632 IMI(JS,MI,2)=0
15633 IF (IABS(IFL).GE.6) THEN
15634 IF (IABS(IFL).EQ.6) THEN
15635 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
15636 ENDIF
15637 RETURN
15638 ENDIF
15639C...Get PDFs at X(rescaled) and PT2 of the current initiator.
15640C...(Do not include the parton itself in the X rescaling.)
15641 X=XMI(JS,MI)
15642 XRSC=X/(VINT(142+JS)+X)
15643C...Note: XPSVC = x*pdf.
15644 MINT(30)=JS
15645 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
15646 SEA=XPSVC(IFL,-1)
15647 VAL=XPSVC(IFL,0)
15648 CMP=0D0
15649 DO 310 IVC=1,NVC(JS,IFL)
15650 CMP=CMP+XPSVC(IFL,IVC)
15651 310 CONTINUE
15652
15653C...Decide (Extra factor x cancels in the dvision).
15654 320 RVCS=PYR(0)*(SEA+VAL+CMP)
15655 IVNOW=1
15656 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
15657C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
15658 IVNOW=0
15659 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
15660 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
15661 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
15662 IF(KFIVAL(JS,1).EQ.0) THEN
15663 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
15664 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
15665 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
15666 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
15667 ELSE
15668C...Count down valence remaining. Do not count current scattering.
15669 DO 340 I1=1,NMI(JS)
15670 IF (I1.EQ.MINT(36)) GOTO 340
15671 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
15672 & IVNOW=IVNOW-1
15673 340 CONTINUE
15674 ENDIF
15675 IF(IVNOW.EQ.0) GOTO 330
15676C...Mark valence.
15677 IMI(JS,MI,2)=0
15678C...Sets valence content of gamma, pi0, K0S, K0L if not done.
15679 IF(KFIVAL(JS,1).EQ.0) THEN
15680 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
15681 KFIVAL(JS,1)=IFL
15682 KFIVAL(JS,2)=-IFL
15683 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
15684 KFIVAL(JS,1)=IFL
15685 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
15686 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
15687 ENDIF
15688 ENDIF
15689
15690 ELSEIF (RVCS.LE.VAL+SEA) THEN
15691C...If sea, add opposite sign companion parton. Store X and I.
15692 NVC(JS,-IFL)=NVC(JS,-IFL)+1
15693 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
15694C...Set pointer to companion
15695 IMI(JS,MI,2)=-NVC(JS,-IFL)
15696
15697 ELSE
15698C...If companion, decide which one.
15699 IF (NVC(JS,IFL).EQ.0) THEN
15700 CMP=0D0
15701 CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
15702 GOTO 320
15703 ENDIF
15704 CMPSUM=VAL+SEA
15705 ISEL=0
15706 350 ISEL=ISEL+1
15707 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
15708 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
15709C...Find original sea (anti-)quark. Do not consider current scattering.
15710 IASSOC=0
15711 DO 360 I1=1,NMI(JS)
15712 IF (I1.EQ.MINT(36)) GOTO 360
15713 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
15714 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
15715 IMI(JS,MI,2)=IMI(JS,I1,1)
15716 IMI(JS,I1,2)=IMI(JS,MI,1)
15717 ENDIF
15718 360 CONTINUE
15719C...Mark companion "out-kicked".
15720 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
15721 ENDIF
15722
15723 ENDIF
15724 RETURN
15725 END
15726
15727C*********************************************************************
15728
15729C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
15730C...Giving the x*f pdf of a companion quark, with its partner at XS,
15731C...using an approximate gluon density like (1-X)^NPOW/X. The value
15732C...corresponds to an unrescaled range between 0 and 1-X.
15733
15734 FUNCTION PYFCMP(XC,XS,NPOW)
15735 IMPLICIT NONE
15736 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
15737 INTEGER NPOW
15738
15739 PYFCMP=0D0
15740C...Parent gluon momentum fraction
15741 Y=XC+XS
15742 IF (Y.GE.1D0) RETURN
15743C...Common factor (includes factor XC, since PYFCMP=x*f)
15744 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
15745C...Store normalized companion x*f distribution.
15746 IF (NPOW.LE.0) THEN
15747 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
15748 ELSEIF (NPOW.EQ.1) THEN
15749 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
15750 ELSEIF (NPOW.EQ.2) THEN
15751 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
15752 & +3D0*XS*(1D0+XS)*LOG(XS)))
15753 ELSEIF (NPOW.EQ.3) THEN
15754 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
15755 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15756 ELSEIF (NPOW.GE.4) THEN
15757 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
15758 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
15759 ENDIF
15760 RETURN
15761 END
15762
15763C*********************************************************************
15764
15765C...PYPCMP: Auxiliary to PYPDFU.
15766C...Giving the momentum integral of a companion quark, with its
15767C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
15768C...The value corresponds to an unrescaled range between 0 and 1-XS.
15769
15770 FUNCTION PYPCMP(XS,NPOW)
15771 IMPLICIT NONE
15772 DOUBLE PRECISION XS, PYPCMP
15773 INTEGER NPOW
15774 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
15775 PYPCMP=0D0
15776 ELSEIF (NPOW.LE.0) THEN
15777 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
15778 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
15779 ELSEIF (NPOW.EQ.1) THEN
15780 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
15781 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
15782 ELSEIF (NPOW.EQ.2) THEN
15783 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
15784 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
15785 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
15786 & -3D0*XS*LOG(XS)*(1+XS)))
15787 ELSEIF (NPOW.EQ.3) THEN
15788 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
15789 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
15790 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
15791 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
15792 ELSE
15793 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
15794 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
15795 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
15796 & -6D0*XS*LOG(XS)*(1D0+XS)))
15797 ENDIF
15798 RETURN
15799 END
15800
15801C*********************************************************************
15802
15803C...PYUPRE
15804C...Rearranges contents of the HEPEUP commonblock so that
15805C...mothers precede daughters and daughters of a decay are
15806C...listed consecutively.
15807
15808 SUBROUTINE PYUPRE
15809
15810C...Double precision and integer declarations.
15811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15812 IMPLICIT INTEGER(I-N)
15813
15814C...User process event common block.
15815 INTEGER MAXNUP
15816 PARAMETER (MAXNUP=500)
15817 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
15818 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
15819 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
15820 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
15821 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
15822 SAVE /HEPEUP/
15823
15824C...Local arrays.
15825 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
15826 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
15827 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
15828
15829C...Check whether a rearrangement is required.
15830 NEED=0
15831 DO 100 IUP=1,NUP
15832 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
15833 100 CONTINUE
15834 DO 110 IUP=2,NUP
15835 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
15836 110 CONTINUE
15837
15838 IF(NEED.NE.0) THEN
15839C...Find the new order that particles should have.
15840 NEWPOS(0)=0
15841 NNEW=0
15842 INEW=-1
15843 120 INEW=INEW+1
15844 DO 130 IUP=1,NUP
15845 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
15846 NNEW=NNEW+1
15847 NEWPOS(NNEW)=IUP
15848 ENDIF
15849 130 CONTINUE
15850 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
15851 IF(NNEW.NE.NUP) THEN
15852 CALL PYERRM(2,
15853 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
15854 RETURN
15855 ENDIF
15856
15857C...Copy old info into temporary storage.
15858 DO 150 I=1,NUP
15859 IDUPT(I)=IDUP(I)
15860 ISTUPT(I)=ISTUP(I)
15861 MOTUPT(1,I)=MOTHUP(1,I)
15862 MOTUPT(2,I)=MOTHUP(2,I)
15863 ICOUPT(1,I)=ICOLUP(1,I)
15864 ICOUPT(2,I)=ICOLUP(2,I)
15865 DO 140 J=1,5
15866 PUPT(J,I)=PUP(J,I)
15867 140 CONTINUE
15868 VTIUPT(I)=VTIMUP(I)
15869 SPIUPT(I)=SPINUP(I)
15870 150 CONTINUE
15871
15872C...Copy info back into HEPEUP in right order.
15873 DO 180 I=1,NUP
15874 IOLD=NEWPOS(I)
15875 IDUP(I)=IDUPT(IOLD)
15876 ISTUP(I)=ISTUPT(IOLD)
15877 MOTHUP(1,I)=0
15878 MOTHUP(2,I)=0
15879 DO 160 IMOT=1,I-1
15880 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
15881 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
15882 160 CONTINUE
15883 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
15884 MOTHSW=MOTHUP(1,I)
15885 MOTHUP(1,I)=MOTHUP(2,I)
15886 MOTHUP(2,I)=MOTHSW
15887 ENDIF
15888 ICOLUP(1,I)=ICOUPT(1,IOLD)
15889 ICOLUP(2,I)=ICOUPT(2,IOLD)
15890 DO 170 J=1,5
15891 PUP(J,I)=PUPT(J,IOLD)
15892 170 CONTINUE
15893 VTIMUP(I)=VTIUPT(IOLD)
15894 SPINUP(I)=SPIUPT(IOLD)
15895 180 CONTINUE
15896 ENDIF
15897
15898c...If incoming particles are massive recalculate to put them massless.
15899 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
15900 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
15901 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
15902 PUP(4,1)=0.5D0*PPLUS
15903 PUP(3,1)=PUP(4,1)
15904 PUP(5,1)=0D0
15905 PUP(4,2)=0.5D0*PMINUS
15906 PUP(3,2)=-PUP(4,2)
15907 PUP(5,2)=0D0
15908 ENDIF
15909
15910 RETURN
15911 END
15912
15913C*********************************************************************
15914
15915C...PYADSH
15916C...Administers the generation of successive final-state showers
15917C...in external processes.
15918
15919 SUBROUTINE PYADSH(NFIN)
15920
15921C...Double precision and integer declarations.
15922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15923 IMPLICIT INTEGER(I-N)
15924 INTEGER PYK,PYCHGE,PYCOMP
15925C...Parameter statement for maximum size of showers.
15926 PARAMETER (MAXNUR=1000)
15927C...Commonblocks.
15928 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15930 COMMON/PYCTAG/NCT,MCT(4000,2)
15931 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15933 COMMON/PYINT1/MINT(400),VINT(400)
15934 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
15935C...Local array.
15936 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
15937
15938C...Set primary vertex.
15939 DO 100 J=1,5
15940 V(MINT(83)+5,J)=0D0
15941 V(MINT(83)+6,J)=0D0
15942 V(MINT(84)+1,J)=0D0
15943 V(MINT(84)+2,J)=0D0
15944 100 CONTINUE
15945
15946C...Isolate systems of particles with the same mother.
15947 NSYS=0
15948 IMS=-1
15949 DO 140 I=MINT(84)+3,NFIN
15950 IM=K(I,3)
15951 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
15952 IF(IM.NE.IMS) THEN
15953 NSYS=NSYS+1
15954 IBEG(NSYS)=I
15955 IMS=IM
15956 ENDIF
15957
15958C...Set production vertices.
15959 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
15960 & THEN
15961 DO 110 J=1,4
15962 V(I,J)=0D0
15963 110 CONTINUE
15964 ELSE
15965 DO 120 J=1,4
15966 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
15967 120 CONTINUE
15968 ENDIF
15969 IF(MSTP(125).GE.1) THEN
15970 IDOC=I-MSTP(126)+4
15971 DO 130 J=1,5
15972 V(IDOC,J)=V(I,J)
15973 130 CONTINUE
15974 ENDIF
15975 140 CONTINUE
15976
15977C...End loop over systems. Return if no showers to be performed.
15978 IBEG(NSYS+1)=NFIN+1
15979 IF(MSTP(71).LE.0) RETURN
15980
15981C...Loop through systems of particles; check that sensible size.
15982 DO 270 ISYS=1,NSYS
15983 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
15984 IF(MINT(35).LE.1) THEN
15985 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
15986 GOTO 270
15987 ELSEIF(NSIZ.LE.1) THEN
15988 CALL PYERRM(2,'(PYADSH:) only one particle in system')
15989 GOTO 270
15990 ELSEIF(NSIZ.GT.80) THEN
15991 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
15992 GOTO 270
15993 ENDIF
15994 ENDIF
15995
15996C...Save status codes and daughters of showering particles; reset them.
15997 DO 150 J=1,4
15998 PSUM(J)=0D0
15999 150 CONTINUE
16000 DO 170 II=1,NSIZ
16001 I=IBEG(ISYS)-1+II
16002 KSAV(II,1)=K(I,1)
16003 IF(K(I,1).GT.10) THEN
16004 K(I,1)=1
16005 IF(KSAV(II,1).EQ.14) K(I,1)=3
16006 ENDIF
16007 IF(KSAV(II,1).LE.10) THEN
16008 ELSEIF(K(I,1).EQ.1) THEN
16009 KSAV(II,4)=K(I,4)
16010 KSAV(II,5)=K(I,5)
16011 K(I,4)=0
16012 K(I,5)=0
16013 ELSE
16014 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16015 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16016 K(I,4)=K(I,4)-KSAV(II,4)
16017 K(I,5)=K(I,5)-KSAV(II,5)
16018 ENDIF
16019 DO 160 J=1,4
16020 PSUM(J)=PSUM(J)+P(I,J)
16021 160 CONTINUE
16022 170 CONTINUE
16023
16024C...Perform shower.
16025 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16026 & PSUM(3)**2))
16027 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16028 NSAV=N
16029 IF(MINT(35).LE.1) THEN
16030 IF(NSIZ.EQ.2) THEN
16031 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16032 ELSE
16033 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16034 ENDIF
16035
16036C...For external processes, first call, also ISR partons radiate.
16037C...Can use existing PYPART list, removing partons that radiate later.
16038 ELSEIF(ISYS.EQ.1) THEN
16039 NPARTN=0
16040 DO 175 II=1,NPART
16041 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16042 NPARTN=NPARTN+1
16043 IPART(NPARTN)=IPART(II)
16044 PTPART(NPARTN)=PTPART(II)
16045 ENDIF
16046 175 CONTINUE
16047 NPART=NPARTN
16048 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16049 ELSE
16050C...For subsequent calls use the systems excluded above.
16051 NPART=NSIZ
16052 NPARTD=0
16053 DO 180 II=1,NSIZ
16054 I=IBEG(ISYS)-1+II
16055 IPART(II)=I
16056 PTPART(II)=0.5D0*QMAX
16057 180 CONTINUE
16058 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16059 ENDIF
16060
16061C...Look up showered copies of original showering particles.
16062 DO 260 II=1,NSIZ
16063 I=IBEG(ISYS)-1+II
16064 IMV=I
16065C...Particles without daughters need not be studied.
16066 IF(KSAV(II,1).LE.10) GOTO 260
16067 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16068 ELSEIF(K(I,1).EQ.11) THEN
16069 190 IMV=MOD(K(IMV,4),MSTU(5))
16070 IF(K(IMV,1).EQ.11) GOTO 190
16071 ELSE
16072 KDA1=MOD(K(I,4),MSTU(5))
16073 IF(KDA1.GT.0) THEN
16074 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16075 ENDIF
16076 KDA2=MOD(K(I,5),MSTU(5))
16077 IF(KDA2.GT.0) THEN
16078 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16079 ENDIF
16080 DO 200 I3=I+1,N
16081 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16082 & THEN
16083 IMV=I3
16084 KDA1=MOD(K(I3,4),MSTU(5))
16085 IF(KDA1.GT.0) THEN
16086 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16087 ENDIF
16088 KDA2=MOD(K(I3,5),MSTU(5))
16089 IF(KDA2.GT.0) THEN
16090 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16091 ENDIF
16092 ENDIF
16093 200 CONTINUE
16094 ENDIF
16095
16096C...Restore daughter info of original partons to showered copies.
16097 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16098 IF(KSAV(II,1).LE.10) THEN
16099 ELSEIF(K(I,1).EQ.1) THEN
16100 K(IMV,4)=KSAV(II,4)
16101 K(IMV,5)=KSAV(II,5)
16102 ELSE
16103 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16104 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16105 ENDIF
16106
16107C...Reset mother info of existing daughters to showered copies.
16108 DO 210 I3=IBEG(ISYS+1),NFIN
16109 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16110 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16111 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16112 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16113 ENDIF
16114 210 CONTINUE
16115
16116C...Boost all original daughters to new frame of showered copy.
16117C...Also update their colour tags.
16118 IF(IMV.NE.I) THEN
16119 DO 220 J=1,3
16120 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16121 220 CONTINUE
16122 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16123 DO 230 J=1,3
16124 BETA(J)=FAC*BETA(J)
16125 230 CONTINUE
16126 DO 250 I3=IBEG(ISYS+1),NFIN
16127 IMO=I3
16128 240 IMO=K(IMO,3)
16129 IF(MSTP(128).LE.0) THEN
16130 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16131 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16132 & THEN
16133 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16134 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16135 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16136 ENDIF
16137 ELSE
16138 IF(IMO.EQ.IMV) THEN
16139 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16140 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16141 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16142 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16143 GOTO 240
16144 ENDIF
16145 ENDIF
16146 250 CONTINUE
16147 ENDIF
16148 260 CONTINUE
16149
16150C...End of loop over showering systems
16151 270 CONTINUE
16152
16153 RETURN
16154 END
16155
16156C*********************************************************************
16157
16158C...PYVETO
16159C...Interface to UPVETO, which allows user to veto event generation
16160C...on the parton level, after parton showers but before multiple
16161C...interactions, beam remnants and hadronization is added.
16162
16163 SUBROUTINE PYVETO(IVETO)
16164
16165C...All real arithmetic in double precision.
16166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16167C...Three Pythia functions return integers, so need declaring.
16168 INTEGER PYK,PYCHGE,PYCOMP
16169
16170C...PYTHIA commonblocks.
16171 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16172 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16173 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16174 COMMON/PYINT1/MINT(400),VINT(400)
16175 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16176C...HEPEVT commonblock.
16177 PARAMETER (NMXHEP=4000)
16178 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16179 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16180 DOUBLE PRECISION PHEP,VHEP
16181 SAVE /HEPEVT/
16182C...Local array.
16183 DIMENSION IRESO(100)
16184
16185C...Define longitudinal boost from initiator rest frame to cm frame.
16186 IF(MINT(35).EQ.3) THEN
16187C...The last frame is different depending upon old and new shower
16188 GAMMA=1D0
16189 GABEZ=0D0
16190 ELSE
16191 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16192 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16193 ENDIF
16194
16195C... Reset counters.
16196 NEVHEP=0
16197 NHEP=0
16198 NRESO=0
16199
16200C...Oth pass: identify beam and incoming partons
16201 DO 140 I=MINT(83)+1,MINT(83)+6
16202 ISTORE=0
16203C IF(K(I,2).EQ.94.OR.K(I,2).EQ.0) THEN
16204 IF(K(I,2).EQ.94) THEN
16205
16206 ELSE
16207 ISTORE=1
16208 NHEP=NHEP+1
16209 II=NHEP
16210 NRESO=NRESO+1
16211 IRESO(NRESO)=I
16212 IMOTH=K(I,3)
16213 ENDIF
16214 IF(ISTORE.EQ.1) THEN
16215C...Copy parton info, boosting momenta along z axis to cm frame.
16216 ISTHEP(II)=2
16217 IDHEP(II)=K(I,2)
16218 PHEP(1,II)=P(I,1)
16219 PHEP(2,II)=P(I,2)
16220 IF(II.GT.2) THEN
16221 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16222 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16223 ELSE
16224 PHEP(3,II)=P(I,3)
16225 PHEP(4,II)=P(I,4)
16226 ENDIF
16227 PHEP(5,II)=P(I,5)
16228C...Store one mother. Rest of history and vertex info zeroed.
16229 JMOHEP(1,II)=IMOTH
16230 JMOHEP(2,II)=0
16231 JDAHEP(1,II)=0
16232 JDAHEP(2,II)=0
16233 VHEP(1,II)=0D0
16234 VHEP(2,II)=0D0
16235 VHEP(3,II)=0D0
16236 VHEP(4,II)=0D0
16237 ENDIF
16238 140 CONTINUE
16239
16240C...First pass: identify final locations of resonances
16241C...and of their daughters before showering.
16242 DO 150 I=MINT(84)+3,N
16243 ISTORE=0
16244 IMOTH=0
16245
16246C...Skip shower CM frame documentation lines.
16247 IF(K(I,2).EQ.94) THEN
16248
16249C... Store a new intermediate product, when mother in documentation.
16250 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16251 & K(I,3).LE.MINT(84)) THEN
16252 ISTORE=1
16253 NHEP=NHEP+1
16254 II=NHEP
16255 NRESO=NRESO+1
16256 IRESO(NRESO)=I
16257 IMOTH=K(K(I,3),3)
16258
16259C... Store a new intermediate product, when mother in main section.
16260 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16261 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16262 ISTORE=1
16263 NHEP=NHEP+1
16264 II=NHEP
16265 NRESO=NRESO+1
16266 IRESO(NRESO)=I
16267 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3))
16268 ENDIF
16269
16270 IF(ISTORE.EQ.1) THEN
16271C...Copy parton info, boosting momenta along z axis to cm frame.
16272 ISTHEP(II)=2
16273 IDHEP(II)=K(I,2)
16274 PHEP(1,II)=P(I,1)
16275 PHEP(2,II)=P(I,2)
16276 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16277 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16278 PHEP(5,II)=P(I,5)
16279C...Store one mother. Rest of history and vertex info zeroed.
16280 JMOHEP(1,II)=IMOTH
16281 JMOHEP(2,II)=0
16282 JDAHEP(1,II)=I
16283 JDAHEP(2,II)=0
16284 VHEP(1,II)=0D0
16285 VHEP(2,II)=0D0
16286 VHEP(3,II)=0D0
16287 VHEP(4,II)=0D0
16288 ENDIF
16289 150 CONTINUE
16290
16291C...Second pass: identify current set of "final" partons.
16292 DO 200 I=MINT(84)+3,N
16293 ISTORE=0
16294 IMOTH=0
16295
16296C...Store a final parton.
16297 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16298 ISTORE=1
16299 NHEP=NHEP+1
16300 II=NHEP
16301C..Trace it back through shower, to check if from documented particle.
16302 IHIST=I
16303 ISAVE=IHIST
16304 160 CONTINUE
16305 IF(IHIST.GT.MINT(84)) THEN
16306 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16307 DO 170 IRI=1,NRESO
16308 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16309 170 CONTINUE
16310 ISAVE=IHIST
16311 IHIST=K(IHIST,3)
16312 IF(IMOTH.EQ.0) GOTO 160
16313 ELSEIF(IHIST.LE.4) THEN
16314 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16315 ISTORE=0
16316 NHEP=NHEP-1
16317 ELSE
16318 IMOTH=IHIST
16319 ENDIF
16320 ENDIF
16321 ENDIF
16322
16323 IF(ISTORE.EQ.1) THEN
16324C...Copy parton info, boosting momenta along z axis to cm frame.
16325 ISTHEP(II)=1
16326 IDHEP(II)=K(I,2)
16327 PHEP(1,II)=P(I,1)
16328 PHEP(2,II)=P(I,2)
16329 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16330 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16331 PHEP(5,II)=P(I,5)
16332C...Store one mother. Rest of history and vertex info zeroed.
16333 JMOHEP(1,II)=IMOTH
16334 JMOHEP(2,II)=0
16335 JDAHEP(1,II)=0
16336 JDAHEP(2,II)=0
16337 VHEP(1,II)=0D0
16338 VHEP(2,II)=0D0
16339 VHEP(3,II)=0D0
16340 VHEP(4,II)=0D0
16341 ENDIF
16342 200 CONTINUE
16343
16344C...Call user-written routine to decide whether to keep events.
16345 CALL UPVETO(IVETO)
16346
16347 RETURN
16348 END
16349C*********************************************************************
16350
16351C...PYRESD
16352C...Allows resonances to decay (including parton showers for hadronic
16353C...channels).
16354
16355 SUBROUTINE PYRESD(IRES)
16356
16357C...Double precision and integer declarations.
16358 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16359 IMPLICIT INTEGER(I-N)
16360 INTEGER PYK,PYCHGE,PYCOMP
16361C...Parameter statement to help give large particle numbers.
16362 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16363 &KEXCIT=4000000,KDIMEN=5000000)
16364C...Parameter statement for maximum size of showers.
16365 PARAMETER (MAXNUR=1000)
16366C...Commonblocks.
16367 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16368 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16369 COMMON/PYCTAG/NCT,MCT(4000,2)
16370 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16371 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16372 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16373 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16374 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16375 COMMON/PYINT1/MINT(400),VINT(400)
16376 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16377 COMMON/PYINT4/MWID(500),WIDS(500,5)
16378 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16379 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/
16380C...Local arrays and complex and character variables.
16381 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16382 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16383 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16384 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16385 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16386 COMPLEX FGK,HA(6,6),HC(6,6)
16387 REAL TIR,UIR
16388 CHARACTER CODE*9,MASS*9
16389
16390C...The F, Xi and Xj functions of Gunion and Kunszt
16391C...(Phys. Rev. D33, 665, plus errata from the authors).
16392 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16393 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16394 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16395 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16396 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16397 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16398 &2D0*(D34/D56+D56/D34))
16399
16400C...Some general constants.
16401 XW=PARU(102)
16402 XWV=XW
16403 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
16404 XW1=1D0-XW
16405 SQMZ=PMAS(23,1)**2
16406
16407 GMMZ=PMAS(23,1)*PMAS(23,2)
16408 SQMW=PMAS(24,1)**2
16409 GMMW=PMAS(24,1)*PMAS(24,2)
16410 SH=VINT(44)
16411
16412C...Boost and rotate to rest frame of incoming partons,
16413C...to get proper amount of smearing of decay angles.
16414 IBST=0
16415 IF(IRES.EQ.0) THEN
16416 IBST=1
16417 ETOTIN=P(MINT(84)+1,4)+P(MINT(84)+2,4)
16418 BEXIN=(P(MINT(84)+1,1)+P(MINT(84)+2,1))/ETOTIN
16419 BEYIN=(P(MINT(84)+1,2)+P(MINT(84)+2,2))/ETOTIN
16420 BEZIN=(P(MINT(84)+1,3)+P(MINT(84)+2,3))/ETOTIN
16421 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
16422 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
16423 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
16424 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
16425 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
16426 ENDIF
16427
16428C...Reset original resonance configuration.
16429 DO 100 JT=1,8
16430 IREF(1,JT)=0
16431 100 CONTINUE
16432
16433C...Define initial one, two or three objects for subprocess.
16434 IHDEC=0
16435 IF(IRES.EQ.0) THEN
16436 ISUB=MINT(1)
16437 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
16438 IREF(1,1)=MINT(84)+2+ISET(ISUB)
16439 IREF(1,4)=MINT(83)+6+ISET(ISUB)
16440 JTMAX=1
16441 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
16442 IREF(1,1)=MINT(84)+1+ISET(ISUB)
16443 IREF(1,2)=MINT(84)+2+ISET(ISUB)
16444 IREF(1,4)=MINT(83)+5+ISET(ISUB)
16445 IREF(1,5)=MINT(83)+6+ISET(ISUB)
16446 JTMAX=2
16447 ELSEIF(ISET(ISUB).EQ.5) THEN
16448 IREF(1,1)=MINT(84)+3
16449 IREF(1,2)=MINT(84)+4
16450 IREF(1,3)=MINT(84)+5
16451 IREF(1,4)=MINT(83)+7
16452 IREF(1,5)=MINT(83)+8
16453 IREF(1,6)=MINT(83)+9
16454 JTMAX=3
16455 ENDIF
16456
16457C...Define original resonance for odd cases.
16458 ELSE
16459 ISUB=0
16460 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
16461 & IHDEC=1
16462 IF(IHDEC.EQ.1) ISUB=3
16463 IREF(1,1)=IRES
16464 IREF(1,4)=K(IRES,3)
16465 IRESTM=IRES
16466 IF(IREF(1,4).GT.MINT(84)) THEN
16467 110 ITMPMO=IREF(1,4)
16468 IF(K(ITMPMO,2).EQ.94) THEN
16469 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
16470 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
16471 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
16472 IRESTM=ITMPMO
16473C...Explicitly check that reference particle exists, otherwise stop recursion
16474 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
16475 IREF(1,4)=K(ITMPMO,3)
16476 GOTO 110
16477 ENDIF
16478 ENDIF
16479 ENDIF
16480 IF(IREF(1,4).GT.MINT(84)) THEN
16481 EMATCH=1D10
16482 IREF14=IREF(1,4)
16483 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
16484 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
16485 & EMATCH) THEN
16486 IREF(1,4)=II
16487 EMATCH=ABS(P(II,4)-P(IREF14,4))
16488 ENDIF
16489 120 CONTINUE
16490 ENDIF
16491 JTMAX=1
16492 ENDIF
16493
16494C...Check if initial resonance has been moved (in resonance + jet).
16495 DO 140 JT=1,3
16496 IF(IREF(1,JT).GT.0) THEN
16497 IF(K(IREF(1,JT),1).GT.10) THEN
16498 KFA=IABS(K(IREF(1,JT),2))
16499 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
16500 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16501 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16502 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16503 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16504 ENDIF
16505 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16506 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16507 ENDIF
16508 DO 130 I=IREF(1,JT)+1,N
16509 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
16510 & I.EQ.KDA2)) THEN
16511 IREF(1,JT)=I
16512 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
16513 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
16514 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
16515 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16516 ENDIF
16517 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
16518 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16519 ENDIF
16520 ENDIF
16521 130 CONTINUE
16522 ELSE
16523 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
16524 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
16525 ENDIF
16526 ENDIF
16527 ENDIF
16528 140 CONTINUE
16529
16530C...Set decay vertex for initial resonances
16531 DO 160 JT=1,JTMAX
16532 DO 150 I=1,4
16533 V(IREF(1,JT),I)=0D0
16534 150 CONTINUE
16535 160 CONTINUE
16536
16537C...Loop over decay history.
16538 NP=1
16539 IP=0
16540 170 IP=IP+1
16541 NINH=0
16542 JTMAX=2
16543 IF(IREF(IP,2).EQ.0) JTMAX=1
16544 IF(IREF(IP,3).NE.0) JTMAX=3
16545 IT4=0
16546 NSAV=N
16547
16548C...Check for Higgs which appears as decay product of user-process.
16549 IF(ISUB.EQ.0) THEN
16550 IHDEC=0
16551 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
16552 & .EQ.36) IHDEC=1
16553 IF(IHDEC.EQ.1) ISUB=3
16554 ENDIF
16555
16556C...Start treatment of one, two or three resonances in parallel.
16557 180 N=NSAV
16558 DO 340 JT=1,JTMAX
16559 ID=IREF(IP,JT)
16560 KDCY(JT)=0
16561 KFL1(JT)=0
16562 KFL2(JT)=0
16563 KFL3(JT)=0
16564 KEQL(JT)=0
16565 NSD(JT)=ID
16566 ITJUNC(JT)=0
16567
16568C...Check whether particle can/is allowed to decay.
16569 IF(ID.EQ.0) GOTO 330
16570 KFA=IABS(K(ID,2))
16571 KCA=PYCOMP(KFA)
16572 IF(MWID(KCA).EQ.0) GOTO 330
16573 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
16574 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
16575 & KFA.EQ.18) IT4=IT4+1
16576 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
16577 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
16578
16579C...Choose lifetime and determine decay vertex.
16580 IF(K(ID,1).EQ.5) THEN
16581 V(ID,5)=0D0
16582 ELSEIF(K(ID,1).NE.4) THEN
16583 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
16584 ENDIF
16585 DO 190 J=1,4
16586 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
16587 190 CONTINUE
16588
16589C...Determine whether decay allowed or not.
16590 MOUT=0
16591 IF(MSTJ(22).EQ.2) THEN
16592 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
16593 ELSEIF(MSTJ(22).EQ.3) THEN
16594 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
16595 ELSEIF(MSTJ(22).EQ.4) THEN
16596 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
16597 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
16598 ENDIF
16599 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
16600 K(ID,1)=4
16601 GOTO 330
16602 ENDIF
16603
16604C...Info for selection of decay channel: sign, pairings.
16605 IF(KCHG(KCA,3).EQ.0) THEN
16606 IPM=2
16607 ELSE
16608 IPM=(5-ISIGN(1,K(ID,2)))/2
16609 ENDIF
16610 KFB=0
16611 IF(JTMAX.EQ.2) THEN
16612 KFB=IABS(K(IREF(IP,3-JT),2))
16613 ELSEIF(JTMAX.EQ.3) THEN
16614 JT2=JT+1-3*(JT/3)
16615 KFB=IABS(K(IREF(IP,JT2),2))
16616 IF(KFB.NE.KFA) THEN
16617 JT2=JT+2-3*((JT+1)/3)
16618 KFB=IABS(K(IREF(IP,JT2),2))
16619 ENDIF
16620 ENDIF
16621
16622C...Select decay channel.
16623 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
16624 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
16625 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
16626 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
16627 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
16628 IF(WDTE0S.LE.0D0) GOTO 330
16629 RKFL=WDTE0S*PYR(0)
16630 IDL=0
16631 200 IDL=IDL+1
16632 IDC=IDL+MDCY(KCA,2)-1
16633 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
16634 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
16635 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
16636
16637C...Read out flavours and colour charges of decay channel chosen.
16638 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
16639 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
16640 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
16641 KFC1A=PYCOMP(IABS(KFL1(JT)))
16642 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
16643 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
16644 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
16645 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
16646 KFC2A=PYCOMP(IABS(KFL2(JT)))
16647 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
16648 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
16649 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
16650 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
16651 KCQ3(JT)=0
16652 IF(KFL3(JT).NE.0) THEN
16653 KFC3A=PYCOMP(IABS(KFL3(JT)))
16654 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
16655 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
16656 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
16657 ENDIF
16658
16659C...Set/save further info on channel.
16660 KDCY(JT)=1
16661 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
16662 NSD(JT)=N
16663 HGZ(JT,1)=VINT(111)
16664 HGZ(JT,2)=VINT(112)
16665 HGZ(JT,3)=VINT(114)
16666 JTZ=JT
16667
16668C...Select masses; to begin with assume resonances narrow.
16669 DO 220 I=1,3
16670 P(N+I,5)=0D0
16671 PMMN(I)=0D0
16672 IF(I.EQ.1) THEN
16673 KFLW=IABS(KFL1(JT))
16674 KCW=KFC1A
16675 ELSEIF(I.EQ.2) THEN
16676 KFLW=IABS(KFL2(JT))
16677 KCW=KFC2A
16678 ELSEIF(I.EQ.3) THEN
16679 IF(KFL3(JT).EQ.0) GOTO 220
16680 KFLW=IABS(KFL3(JT))
16681 KCW=KFC3A
16682 ENDIF
16683 P(N+I,5)=PMAS(KCW,1)
16684CMRENNA++
16685C...This prevents SUSY/t particles from becoming too light.
16686 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
16687 PMMN(I)=PMAS(KCW,1)
16688 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
16689 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
16690 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
16691 & PMAS(PYCOMP(KFDP(IDC,2)),1)
16692 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
16693 & PMAS(PYCOMP(KFDP(IDC,3)),1)
16694 PMMN(I)=MIN(PMMN(I),PMSUM)
16695 ENDIF
16696 210 CONTINUE
16697CMRENNA--
16698 ELSEIF(KFLW.EQ.6) THEN
16699 PMMN(I)=PMAS(24,1)+PMAS(5,1)
16700 ENDIF
16701 220 CONTINUE
16702
16703C...Check which two out of three are widest.
16704 IWID1=1
16705 IWID2=2
16706 PWID1=PMAS(KFC1A,2)
16707 PWID2=PMAS(KFC2A,2)
16708 KFLW1=IABS(KFL1(JT))
16709 KFLW2=IABS(KFL2(JT))
16710 IF(KFL3(JT).NE.0) THEN
16711 PWID3=PMAS(KFC3A,2)
16712 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
16713 IWID1=3
16714 PWID1=PWID3
16715 KFLW1=IABS(KFL3(JT))
16716 ELSEIF(PWID3.GT.PWID2) THEN
16717 IWID2=3
16718 PWID2=PWID3
16719 KFLW2=IABS(KFL3(JT))
16720 ENDIF
16721 ENDIF
16722
16723C...If all narrow then only check that masses consistent.
16724 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
16725 & PWID2.LT.PARP(41))) THEN
16726CMRENNA++
16727C....Handle near degeneracy cases.
16728 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
16729 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16730 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
16731 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
16732 ENDIF
16733 ENDIF
16734CMRENNA--
16735 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
16736 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
16737 MINT(51)=1
16738 GOTO 720
16739 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
16740 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
16741 MINT(51)=1
16742 GOTO 720
16743 ENDIF
16744
16745C...For three wide resonances select narrower of three
16746C...according to BW decoupled from rest.
16747 ELSE
16748 PMTOT=P(ID,5)
16749 IF(KFL3(JT).NE.0) THEN
16750 IWID3=6-IWID1-IWID2
16751 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
16752 & KFLW1-KFLW2
16753 LOOP=0
16754 230 LOOP=LOOP+1
16755 P(N+IWID3,5)=PYMASS(KFLW3)
16756 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
16757 PMTOT=PMTOT-P(N+IWID3,5)
16758 ENDIF
16759C...Select other two correlated within remaining phase space.
16760 IF(IP.EQ.1) THEN
16761 CKIN45=CKIN(45)
16762 CKIN47=CKIN(47)
16763 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
16764 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
16765 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16766 & P(N+IWID2,5))
16767 CKIN(45)=CKIN45
16768 CKIN(47)=CKIN47
16769 ELSE
16770 CKIN(49)=PMMN(IWID1)
16771 CKIN(50)=PMMN(IWID2)
16772 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
16773 & P(N+IWID2,5))
16774 CKIN(49)=0D0
16775 CKIN(50)=0D0
16776 ENDIF
16777 IF(MINT(51).EQ.1) GOTO 720
16778 ENDIF
16779
16780C...Begin fill decay products, with colour flow for coloured objects.
16781 MSTU10=MSTU(10)
16782 MSTU(10)=1
16783 MSTU(19)=1
16784
16785C...Three-body decays
16786 IF(KFL3(JT).NE.0) THEN
16787 DO 250 I=N+1,N+3
16788 DO 240 J=1,5
16789 K(I,J)=0
16790 V(I,J)=0D0
16791 240 CONTINUE
16792 MCT(I,1)=0
16793 MCT(I,2)=0
16794 250 CONTINUE
16795 K(N+1,1)=1
16796 K(N+1,2)=KFL1(JT)
16797 K(N+2,1)=1
16798 K(N+2,2)=KFL2(JT)
16799 K(N+3,1)=1
16800 K(N+3,2)=KFL3(JT)
16801 IDIN=ID
16802
16803C...Generate kinematics (default is flat)
16804 CALL PYTBDY(IDIN)
16805
16806C...Set generic colour flows whenever unambiguous,
16807C...(independently of the order of the decay products)
16808C...Sum up total colour content
16809 NANT=0
16810 NTRI=0
16811 NOCT=0
16812 KCQ(0)=KCQM(JT)
16813 KCQ(1)=KCQ1(JT)
16814 KCQ(2)=KCQ2(JT)
16815 KCQ(3)=KCQ3(JT)
16816 DO 255 J=0,3
16817 IF (KCQ(J).EQ.-1) THEN
16818 NANT=NANT+1
16819 IANT(NANT)=N+J
16820 ELSEIF (KCQ(J).EQ.1) THEN
16821 NTRI=NTRI+1
16822 ITRI(NTRI)=N+J
16823 ELSEIF (KCQ(J).EQ.2) THEN
16824 NOCT=NOCT+1
16825 IOCT(NOCT)=N+J
16826 ENDIF
16827 255 CONTINUE
16828
16829C...Set color flow for generic 1 -> N processes (N arbitrary)
16830 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
16831C...All singlets: do nothing
16832
16833 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
16834C...Two octets, zero triplets, n singlets:
16835 IF (KCQ(0).EQ.2) THEN
16836C...8 -> 8 + n(1)
16837 K(ID,4)=K(ID,4)+IOCT(2)
16838 K(ID,5)=K(ID,5)+IOCT(2)
16839 K(IOCT(2),1)=3
16840 K(IOCT(2),4)=MSTU(5)*ID
16841 K(IOCT(2),5)=MSTU(5)*ID
16842 MCT(IOCT(2),1)=MCT(ID,1)
16843 MCT(IOCT(2),2)=MCT(ID,2)
16844 ELSE
16845C...1 -> 8 + 8 + n(1)
16846 K(IOCT(1),1)=3
16847 K(IOCT(1),4)=MSTU(5)*IOCT(2)
16848 K(IOCT(1),5)=MSTU(5)*IOCT(2)
16849 K(IOCT(2),1)=3
16850 K(IOCT(2),4)=MSTU(5)*IOCT(1)
16851 K(IOCT(2),5)=MSTU(5)*IOCT(1)
16852 NCT=NCT+1
16853 MCT(IOCT(1),1)=NCT
16854 MCT(IOCT(2),2)=NCT
16855 NCT=NCT+1
16856 MCT(IOCT(2),1)=NCT
16857 MCT(IOCT(1),2)=NCT
16858 ENDIF
16859
16860 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
16861C...Two triplets, zero octets, n singlets.
16862 IF (KCQ(0).EQ.1) THEN
16863C...3 -> 3 + n(1)
16864 K(ID,4)=K(ID,4)+ITRI(2)
16865 K(ITRI(2),1)=3
16866 K(ITRI(2),4)=MSTU(5)*ID
16867 MCT(ITRI(2),1)=MCT(ID,1)
16868 ELSEIF (KCQ(0).EQ.-1) THEN
16869C...3bar -> 3bar + n(1)
16870 K(ID,5)=K(ID,5)+IANT(2)
16871 K(IANT(2),1)=3
16872 K(IANT(2),5)=MSTU(5)*ID
16873 MCT(IANT(2),2)=MCT(ID,2)
16874 ELSE
16875C...1 -> 3 + 3bar + n(1)
16876 K(ITRI(1),1)=3
16877 K(ITRI(1),4)=MSTU(5)*IANT(1)
16878 K(IANT(1),1)=3
16879 K(IANT(1),5)=MSTU(5)*ITRI(1)
16880 NCT=NCT+1
16881 MCT(ITRI(1),1)=NCT
16882 MCT(IANT(1),2)=NCT
16883 ENDIF
16884
16885 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
16886C...Two triplets, one octet, n singlets.
16887 IF (KCQ(0).EQ.2) THEN
16888C...8 -> 3 + 3bar + n(1)
16889 K(ID,4)=K(ID,4)+ITRI(1)
16890 K(ID,5)=K(ID,5)+IANT(1)
16891 K(ITRI(1),1)=3
16892 K(ITRI(1),4)=MSTU(5)*ID
16893 K(IANT(1),1)=3
16894 K(IANT(1),5)=MSTU(5)*ID
16895 MCT(ITRI(1),1)=MCT(ID,1)
16896 MCT(IANT(1),2)=MCT(ID,2)
16897 ELSEIF (KCQ(0).EQ.1) THEN
16898C...3 -> 8 + 3 + n(1)
16899 K(ID,4)=K(ID,4)+IOCT(1)
16900 K(IOCT(1),1)=3
16901 K(IOCT(1),4)=MSTU(5)*ID
16902 K(IOCT(1),5)=MSTU(5)*ITRI(2)
16903 K(ITRI(2),1)=3
16904 K(ITRI(2),4)=MSTU(5)*IOCT(1)
16905 MCT(IOCT(1),1)=MCT(ID,1)
16906 NCT=NCT+1
16907 MCT(IOCT(1),2)=NCT
16908 MCT(ITRI(2),1)=NCT
16909 ELSEIF (KCQ(0).EQ.-1) THEN
16910C...3bar -> 8 + 3bar + n(1)
16911 K(ID,5)=K(ID,5)+IOCT(1)
16912 K(IOCT(1),1)=3
16913 K(IOCT(1),5)=MSTU(5)*ID
16914 K(IOCT(1),4)=MSTU(5)*IANT(2)
16915 K(IANT(2),1)=3
16916 K(IANT(2),5)=MSTU(5)*IOCT(1)
16917 MCT(IOCT(1),2)=MCT(ID,2)
16918 NCT=NCT+1
16919 MCT(IOCT(1),1)=NCT
16920 MCT(IANT(2),2)=NCT
16921 ELSE
16922C...1 -> 3 + 3bar + 8 + n(1)
16923 K(ITRI(1),1)=3
16924 K(ITRI(1),4)=MSTU(5)*IOCT(1)
16925 K(IOCT(1),1)=3
16926 K(IOCT(1),5)=MSTU(5)*ITRI(1)
16927 K(IOCT(1),4)=MSTU(5)*IANT(1)
16928 K(IANT(1),1)=3
16929 K(IANT(1),5)=MSTU(5)*IOCT(1)
16930 NCT=NCT+1
16931 MCT(ITRI(1),1)=NCT
16932 MCT(IOCT(1),2)=NCT
16933 NCT=NCT+1
16934 MCT(IOCT(1),1)=NCT
16935 MCT(IANT(1),2)=NCT
16936 ENDIF
16937CPS-- End of generic cases
16938C...(could three octets also be handled?)
16939C...(could (some of) the RPV cases be made generic as well?)
16940
16941C...Special cases (= old treatment)
16942C...Set colour flow for t -> W + b + Z.
16943 ELSEIF(KFA.EQ.6) THEN
16944 K(N+2,1)=3
16945 ISID=4
16946 IF(KCQM(JT).EQ.-1) ISID=5
16947 IDAU=N+2
16948 K(ID,ISID)=K(ID,ISID)+IDAU
16949 K(IDAU,ISID)=MSTU(5)*ID
16950
16951C...Set colour flow in three-body decays - programmed as special cases.
16952
16953 ELSEIF(KFC2A.LE.6) THEN
16954 K(N+2,1)=3
16955 K(N+3,1)=3
16956 ISID=4
16957 IF(KFL2(JT).LT.0) ISID=5
16958 K(N+2,ISID)=MSTU(5)*(N+3)
16959 K(N+3,9-ISID)=MSTU(5)*(N+2)
16960C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
16961 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
16962 & .AND.KFL3(JT).NE.0) THEN
16963 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
16964C...3-body decays of squarks to colour singlets plus one quark
16965 IF (KQSUMA.EQ.1) THEN
16966C...Find quark
16967 IQ=0
16968 IF (KCQ1(JT).NE.0) IQ=1
16969 IF (KCQ2(JT).NE.0) IQ=2
16970 IF (KCQ3(JT).NE.0) IQ=3
16971 ISID=4
16972 IF (K(N+IQ,2).LT.0) ISID=5
16973 K(N+IQ,1)=3
16974 K(ID,ISID)=K(ID,ISID)+(N+IQ)
16975 K(N+IQ,ISID)=MSTU(5)*ID
16976 ENDIF
16977C...PS--
16978 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
16979 K(N+1,1)=3
16980 K(N+2,1)=3
16981 K(N+3,1)=3
16982 ISID=4
16983 IF(KFL2(JT).LT.0) ISID=5
16984 K(N+1,ISID)=MSTU(5)*(N+2)
16985 K(N+1,9-ISID)=MSTU(5)*(N+3)
16986 K(N+2,ISID)=MSTU(5)*(N+1)
16987 K(N+3,9-ISID)=MSTU(5)*(N+1)
16988 ELSEIF(KFA.EQ.KSUSY1+21) THEN
16989 K(N+2,1)=3
16990 K(N+3,1)=3
16991 ISID=4
16992 IF(KFL2(JT).LT.0) ISID=5
16993 K(ID,ISID)=K(ID,ISID)+(N+2)
16994 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
16995 K(N+2,ISID)=MSTU(5)*ID
16996 K(N+3,9-ISID)=MSTU(5)*ID
16997CMRENNA--
16998
16999 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17000 & IABS(KCQ2(JT)).EQ.1) THEN
17001 K(N+2,1)=3
17002 K(N+3,1)=3
17003 ISID=4
17004 IF(KFL2(JT).LT.0) ISID=5
17005 K(N+2,ISID)=MSTU(5)*(N+3)
17006 K(N+3,9-ISID)=MSTU(5)*(N+2)
17007 ENDIF
17008
17009 NSAV=N
17010
17011C...Set colour flow in three-body decays with baryon number violation.
17012C...Neutralino and chargino decays first.
17013 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17014 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17015 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17016 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17017C...Insert junction to keep track of colours.
17018 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17019 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17020 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17021C...Set special junction codes:
17022 K(N+4,1)=42
17023 K(N+4,2)=88
17024
17025C...Order decay products by invariant mass. (will be used in PYSTRF).
17026 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)-
17027 & P(N+1,3)*P(N+2,3)
17028 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)-
17029 & P(N+1,3)*P(N+3,3)
17030 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)-
17031 & P(N+2,3)*P(N+3,3)
17032 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17033 K(N+4,4)=N+3+K(N+4,4)
17034 K(N+4,5)=N+1+MSTU(5)*(N+2)
17035 ELSEIF(PM13.LT.PM23) THEN
17036 K(N+4,4)=N+2+K(N+4,4)
17037 K(N+4,5)=N+1+MSTU(5)*(N+3)
17038 ELSE
17039 K(N+4,4)=N+1+K(N+4,4)
17040 K(N+4,5)=N+2+MSTU(5)*(N+3)
17041 ENDIF
17042 DO 260 J=1,5
17043 P(N+4,J)=0D0
17044 V(N+4,J)=0D0
17045 260 CONTINUE
17046C...Connect daughters to junction.
17047 DO 270 II=N+1,N+3
17048 K(II,4)=0
17049 K(II,5)=0
17050 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17051 270 CONTINUE
17052C...Particle counter should be stepped up one extra for junction.
17053 N=N+1
17054
17055C...Gluino decays.
17056 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17057 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17058 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17059C...Insert junction to keep track of colours.
17060 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17061 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17062 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17063 K(N+4,1)=42
17064 K(N+4,2)=88
17065 DO 280 J=1,5
17066 P(N+4,J)=0D0
17067 V(N+4,J)=0D0
17068 280 CONTINUE
17069 CTMSUM=0D0
17070 DO 290 II=N+1,N+3
17071 K(II,4)=0
17072 K(II,5)=0
17073C...Start by connecting all daughters to junction.
17074 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17075C...Only consider colour topologies with off shell resonances.
17076 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17077 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17078 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17079 IF (RMGLU-RMQ1.LT.RMRES) THEN
17080C...Calculate propagators for each colour topology.
17081 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17082 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17083 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17084 ELSE
17085 CTM2(II-N)=0D0
17086 ENDIF
17087 CTMSUM=CTMSUM+CTM2(II-N)
17088 290 CONTINUE
17089 CTMSUM=PYR(0)*CTMSUM
17090C...Select colour topology J, with most off shell least likely.
17091 J=0
17092 300 J=J+1
17093 CTMSUM=CTMSUM-CTM2(J)
17094 IF (CTMSUM.GT.0D0) GOTO 300
17095C...The lucky winner gets its colour (anti-colour) directly from gluino.
17096 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17097 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17098C...The other gluino colour is connected to junction
17099 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17100 & MSTU(5)
17101 K(N+4,4)=K(N+4,4)+ID
17102C...Lastly, connect junction to remaining daughters.
17103 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17104C...Particle counter should be stepped up one extra for junction.
17105 N=N+1
17106 ENDIF
17107
17108C...Update particle counter.
17109 N=N+3
17110
17111C...2) Everything else two-body decay.
17112 ELSE
17113 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17114 MCT(N-1,1)=0
17115 MCT(N-1,2)=0
17116 MCT(N,1)=0
17117 MCT(N,2)=0
17118C...First set colour flow as if mother colour singlet.
17119 IF(KCQ1(JT).NE.0) THEN
17120 K(N-1,1)=3
17121 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17122 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17123 ENDIF
17124 IF(KCQ2(JT).NE.0) THEN
17125 K(N,1)=3
17126 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17127 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17128 ENDIF
17129C...Then redirect colour flow if mother (anti)triplet.
17130 IF(KCQM(JT).EQ.0) THEN
17131 ELSEIF(KCQM(JT).NE.2) THEN
17132 ISID=4
17133 IF(KCQM(JT).EQ.-1) ISID=5
17134 IDAU=N-1
17135 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17136 K(ID,ISID)=K(ID,ISID)+IDAU
17137 K(IDAU,ISID)=MSTU(5)*ID
17138C...Then redirect colour flow if mother octet.
17139 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17140 IDAU=N-1
17141 IF(KCQ1(JT).EQ.0) IDAU=N
17142 K(ID,4)=K(ID,4)+IDAU
17143 K(ID,5)=K(ID,5)+IDAU
17144 K(IDAU,4)=MSTU(5)*ID
17145 K(IDAU,5)=MSTU(5)*ID
17146 ELSE
17147 ISID=4
17148 IF(KCQ1(JT).EQ.-1) ISID=5
17149 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17150 K(ID,ISID)=K(ID,ISID)+(N-1)
17151 K(ID,9-ISID)=K(ID,9-ISID)+N
17152 K(N-1,ISID)=MSTU(5)*ID
17153 K(N,9-ISID)=MSTU(5)*ID
17154 ENDIF
17155
17156C...Insert junction
17157 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17158 N=N+1
17159C...~q* mother: type 3 junction. ~q mother: type 4.
17160 ITJUNC(JT)=(7+KCQM(JT))/2
17161C...Specify junction KF and set colour flow from junction
17162 K(N,1)=42
17163 K(N,2)=88
17164 K(N,3)=ID
17165C...Junction type encoded together with mother:
17166 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17167 K(N,5)=N-1+MSTU(5)*(N-2)
17168C...Zero P and V for junction (V filled later)
17169 DO 310 J=1,5
17170 P(N,J)=0D0
17171 V(N,J)=0D0
17172 310 CONTINUE
17173C...Set colour flow from mother to junction
17174 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17175C...Set colour flow from daughters to junction
17176 DO 320 II=N-2,N-1
17177 K(II,4) = 0
17178 K(II,5) = 0
17179C...(Anti-)colour mother is junction.
17180 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17181 320 CONTINUE
17182 ENDIF
17183 ENDIF
17184
17185C...End loop over resonances for daughter flavour and mass selection.
17186 MSTU(10)=MSTU10
17187 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17188 & NINH=NINH+1
17189 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17190 & KFL1(JT).EQ.0) THEN
17191 WRITE(CODE,'(I9)') K(ID,2)
17192 WRITE(MASS,'(F9.3)') P(ID,5)
17193 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17194 & CODE//' with mass'//MASS)
17195 MINT(51)=1
17196 GOTO 720
17197 ENDIF
17198 340 CONTINUE
17199
17200C...Check for allowed combinations. Skip if no decays.
17201 IF(JTMAX.EQ.1) THEN
17202 IF(KDCY(1).EQ.0) GOTO 710
17203 ELSEIF(JTMAX.EQ.2) THEN
17204 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17205 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17206 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17207 ELSEIF(JTMAX.EQ.3) THEN
17208 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17209 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17210 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17211 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17212 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17213 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17214 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17215 ENDIF
17216
17217C...Special case: matrix element option for Z0 decay to quarks.
17218 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17219 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17220
17221C...Check consistency of MSTJ options set.
17222 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17223 CALL PYERRM(6,
17224 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17225 MSTJ(110)=1
17226 ENDIF
17227 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17228 CALL PYERRM(6,
17229 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17230
17231 MSTJ(111)=0
17232 ENDIF
17233
17234C...Select alpha_strong behaviour.
17235 MST111=MSTU(111)
17236 PAR112=PARU(112)
17237 MSTU(111)=MSTJ(108)
17238 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17239 & MSTU(111)=1
17240 PARU(112)=PARJ(121)
17241 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17242
17243C...Find axial fraction in total cross section for scalar gluon model.
17244 PARJ(171)=0D0
17245 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17246 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17247 POLL=1D0-PARJ(131)*PARJ(132)
17248 SFF=1D0/(16D0*XW*XW1)
17249 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17250 & (PARJ(123)*PARJ(124))**2)
17251 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17252 VE=4D0*XW-1D0
17253 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17254 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17255 & (PARJ(132)-PARJ(131)))
17256 KFLC=IABS(KFL1(1))
17257 PMQ=PYMASS(KFLC)
17258 QF=KCHG(KFLC,1)/3D0
17259 VQ=1D0
17260 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17261 & 1D0-(2D0*PMQ/P(ID,5))**2))
17262 VF=SIGN(1D0,QF)-4D0*QF*XW
17263 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17264 & VF**2*HF1W)+VQ**3*HF1W
17265 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17266 ENDIF
17267
17268C...Choice of jet configuration.
17269 CALL PYXJET(P(ID,5),NJET,CUT)
17270 KFLC=IABS(KFL1(1))
17271 KFLN=21
17272 IF(NJET.EQ.4) THEN
17273 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17274 ELSEIF(NJET.EQ.3) THEN
17275 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17276 ELSE
17277 MSTJ(120)=1
17278 ENDIF
17279
17280C...Fill jet configuration; return if incorrect kinematics.
17281 NC=N-2
17282 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17283 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17284 ELSEIF(NJET.EQ.2) THEN
17285 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17286 ELSEIF(NJET.EQ.3) THEN
17287 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17288 ELSEIF(KFLN.EQ.21) THEN
17289 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17290 & X12,X14)
17291 ELSE
17292 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17293 & X12,X14)
17294 ENDIF
17295 IF(MSTU(24).NE.0) THEN
17296 MINT(51)=1
17297 MSTU(111)=MST111
17298 PARU(112)=PAR112
17299 GOTO 720
17300 ENDIF
17301
17302C...Angular orientation according to matrix element.
17303 IF(MSTJ(106).EQ.1) THEN
17304 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17305 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17306 CTHE(1)=COS(THEZ)
17307 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17308 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17309 ENDIF
17310
17311C...Boost partons to Z0 rest frame.
17312 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17313 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17314
17315C...Mark decayed resonance and add documentation lines,
17316 K(ID,1)=K(ID,1)+10
17317 IDOC=MINT(83)+MINT(4)
17318 DO 360 I=NC+1,N
17319 I1=MINT(83)+MINT(4)+1
17320 K(I,3)=I1
17321 IF(MSTP(128).GE.1) K(I,3)=ID
17322 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17323 MINT(4)=MINT(4)+1
17324 K(I1,1)=21
17325 K(I1,2)=K(I,2)
17326 K(I1,3)=IREF(IP,4)
17327 DO 350 J=1,5
17328 P(I1,J)=P(I,J)
17329 350 CONTINUE
17330 ENDIF
17331 360 CONTINUE
17332
17333C...Generate parton shower.
17334 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17335 CALL PYSHOW(N-1,N,P(ID,5))
17336 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17337 NPART=2
17338 IPART(1)=N-1
17339 IPART(2)=N
17340 PTPART(1)=0.5D0*P(ID,5)
17341 PTPART(2)=PTPART(1)
17342 NCT=NCT+1
17343 IF(K(N-1,2).GT.0) THEN
17344 MCT(N-1,1)=NCT
17345 MCT(N,2)=NCT
17346 ELSE
17347 MCT(N-1,2)=NCT
17348 MCT(N,1)=NCT
17349 ENDIF
17350 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17351 ENDIF
17352
17353C... End special case for Z0: skip ahead.
17354 MSTU(111)=MST111
17355 PARU(112)=PAR112
17356 GOTO 700
17357 ENDIF
17358
17359C...Order incoming partons and outgoing resonances.
17360 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17361 &NINH.EQ.0) THEN
17362 ILIN(1)=MINT(84)+1
17363 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17364 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17365 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17366 ILIN(2)=2*MINT(84)+3-ILIN(1)
17367 IMIN=1
17368 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17369 & .EQ.36) IMIN=3
17370 IMAX=2
17371 IORD=1
17372 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17373 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17374 IAKIPD=IABS(K(IREF(IP,IORD),2))
17375 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17376 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17377
17378C...Order decay products of resonances.
17379 DO 370 JT=IORD,3-IORD,3-2*IORD
17380 IF(KDCY(JT).EQ.0) THEN
17381 ILIN(IMAX+1)=NSD(JT)
17382 IMAX=IMAX+1
17383 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
17384 ILIN(IMAX+1)=N+2*JT-1
17385 ILIN(IMAX+2)=N+2*JT
17386 IMAX=IMAX+2
17387 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17388 K(N+2*JT,2)=K(NSD(JT)+2,2)
17389 ELSE
17390 ILIN(IMAX+1)=N+2*JT
17391
17392 ILIN(IMAX+2)=N+2*JT-1
17393 IMAX=IMAX+2
17394 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
17395 K(N+2*JT,2)=K(NSD(JT)+2,2)
17396 ENDIF
17397 370 CONTINUE
17398
17399C...Find charge, isospin, left- and righthanded couplings.
17400 DO 390 I=IMIN,IMAX
17401 DO 380 J=1,4
17402 COUP(I,J)=0D0
17403 380 CONTINUE
17404 KFA=IABS(K(ILIN(I),2))
17405 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
17406 COUP(I,1)=KCHG(KFA,1)/3D0
17407 COUP(I,2)=(-1)**MOD(KFA,2)
17408 COUP(I,4)=-2D0*COUP(I,1)*XWV
17409 COUP(I,3)=COUP(I,2)+COUP(I,4)
17410 390 CONTINUE
17411
17412C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
17413 IF(ISUB.EQ.22) THEN
17414 DO 420 I=3,5,2
17415 I1=IORD
17416 IF(I.EQ.5) I1=3-IORD
17417 DO 410 J1=1,2
17418 DO 400 J2=1,2
17419 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
17420 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
17421 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
17422 & COUP(I,J2+2)**2
17423 400 CONTINUE
17424 410 CONTINUE
17425 420 CONTINUE
17426 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17427 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
17428 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
17429 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
17430
17431 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
17432 ENDIF
17433 ENDIF
17434
17435C...Select angular orientation type - Z'/W' only.
17436 MZPWP=0
17437 IF(ISUB.EQ.141) THEN
17438 IF(PYR(0).LT.PARU(130)) MZPWP=1
17439 IF(IP.EQ.2) THEN
17440 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
17441 IAKIR=IABS(K(IREF(2,2),2))
17442 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17443 IF(IAKIR.LE.20) MZPWP=2
17444 ENDIF
17445 IF(IP.GE.3) MZPWP=2
17446 ELSEIF(ISUB.EQ.142) THEN
17447 IF(PYR(0).LT.PARU(136)) MZPWP=1
17448 IF(IP.EQ.2) THEN
17449 IAKIR=IABS(K(IREF(2,2),2))
17450 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
17451 IF(IAKIR.LE.20) MZPWP=2
17452 ENDIF
17453 IF(IP.GE.3) MZPWP=2
17454 ENDIF
17455
17456C...Select random angles (begin of weighting procedure).
17457 430 DO 440 JT=1,JTMAX
17458 IF(KDCY(JT).EQ.0) GOTO 440
17459 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
17460 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
17461 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
17462 PHI(JT)=VINT(24)
17463 ELSE
17464 CTHE(JT)=2D0*PYR(0)-1D0
17465 PHI(JT)=PARU(2)*PYR(0)
17466 ENDIF
17467 440 CONTINUE
17468
17469 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
17470C...Construct massless four-vectors.
17471 DO 460 I=N+1,N+4
17472 K(I,1)=1
17473 DO 450 J=1,5
17474 P(I,J)=0D0
17475 V(I,J)=0D0
17476 450 CONTINUE
17477 460 CONTINUE
17478 DO 470 JT=1,JTMAX
17479 IF(KDCY(JT).EQ.0) GOTO 470
17480 ID=IREF(IP,JT)
17481 P(N+2*JT-1,3)=0.5D0*P(ID,5)
17482 P(N+2*JT-1,4)=0.5D0*P(ID,5)
17483 P(N+2*JT,3)=-0.5D0*P(ID,5)
17484 P(N+2*JT,4)=0.5D0*P(ID,5)
17485 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
17486 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17487 470 CONTINUE
17488
17489C...Store incoming and outgoing momenta, with random rotation to
17490C...avoid accidental zeroes in HA expressions.
17491 IF(ISUB.NE.0) THEN
17492 DO 490 I=IMIN,IMAX
17493 K(N+4+I,1)=1
17494 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
17495 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
17496 P(N+4+I,5)=P(ILIN(I),5)
17497 DO 480 J=1,3
17498 P(N+4+I,J)=P(ILIN(I),J)
17499 480 CONTINUE
17500 490 CONTINUE
17501 500 THERR=ACOS(2D0*PYR(0)-1D0)
17502 PHIRR=PARU(2)*PYR(0)
17503 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
17504 DO 520 I=IMIN,IMAX
17505 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
17506 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
17507 DO 510 J=1,4
17508 PK(I,J)=P(N+4+I,J)
17509 510 CONTINUE
17510 520 CONTINUE
17511 ENDIF
17512
17513C...Calculate internal products.
17514 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
17515 & ISUB.EQ.142) THEN
17516 DO 540 I1=IMIN,IMAX-1
17517 DO 530 I2=I1+1,IMAX
17518 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
17519 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
17520 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
17521 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
17522 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
17523 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
17524 HC(I1,I2)=CONJG(HA(I1,I2))
17525 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
17526 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
17527 HA(I2,I1)=-HA(I1,I2)
17528 HC(I2,I1)=-HC(I1,I2)
17529 530 CONTINUE
17530 540 CONTINUE
17531 ENDIF
17532
17533C...Calculate four-products.
17534 IF(ISUB.NE.0) THEN
17535 DO 560 I=1,2
17536 DO 550 J=1,4
17537 PK(I,J)=-PK(I,J)
17538 550 CONTINUE
17539 560 CONTINUE
17540 DO 580 I1=IMIN,IMAX-1
17541 DO 570 I2=I1+1,IMAX
17542 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
17543 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
17544 PKK(I2,I1)=PKK(I1,I2)
17545 570 CONTINUE
17546 580 CONTINUE
17547 ENDIF
17548 ENDIF
17549
17550 KFAGM=IABS(IREF(IP,7))
17551 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
17552C...Isotropic decay selected by user.
17553 WT=1D0
17554 WTMAX=1D0
17555
17556 ELSEIF(JTMAX.EQ.3) THEN
17557C...Isotropic decay when three mother particles.
17558 WT=1D0
17559 WTMAX=1D0
17560
17561 ELSEIF(IT4.GE.1) THEN
17562C... Isotropic decay t -> b + W etc for 4th generation q and l.
17563 WT=1D0
17564 WTMAX=1D0
17565
17566 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
17567 & IREF(IP,7).EQ.36) THEN
17568C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
17569C...CP-odd case added by Kari Ertresvag Myklevoll.
17570C...Now also with mixed Higgs CP-states
17571 ETA=PARP(25)
17572 IF(IP.EQ.1) WTMAX=SH**2
17573 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
17574 KFA=IABS(K(IREF(IP,1),2))
17575 KFT=IABS(K(IREF(IP,2),2))
17576
17577 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
17578 & MSTP(25).GE.3) THEN
17579C...For mixed CP states need epsilon product.
17580 P10=PK(3,4)
17581 P20=PK(4,4)
17582 P30=PK(5,4)
17583 P40=PK(6,4)
17584 P11=PK(3,1)
17585 P21=PK(4,1)
17586 P31=PK(5,1)
17587 P41=PK(6,1)
17588 P12=PK(3,2)
17589 P22=PK(4,2)
17590 P32=PK(5,2)
17591 P42=PK(6,2)
17592 P13=PK(3,3)
17593 P23=PK(4,3)
17594 P33=PK(5,3)
17595 P43=PK(6,3)
17596 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
17597 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
17598 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
17599 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
17600 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
17601 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
17602 & P22*P30*P41+P13*P22*P31*P40
17603C...For mixed CP states need gauge boson masses.
17604 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
17605 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
17606 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
17607 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
17608 XMV=PMAS(KFA,1)
17609 ENDIF
17610
17611C...Z decay
17612 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
17613 KFLF1A=IABS(KFL1(1))
17614 EF1=KCHG(KFLF1A,1)/3D0
17615 AF1=SIGN(1D0,EF1+0.1D0)
17616 VF1=AF1-4D0*EF1*XWV
17617 KFLF2A=IABS(KFL1(2))
17618 EF2=KCHG(KFLF2A,1)/3D0
17619 AF2=SIGN(1D0,EF2+0.1D0)
17620 VF2=AF2-4D0*EF2*XWV
17621 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
17622 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17623 & THEN
17624C...CP-even decay
17625 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
17626 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
17627 ELSEIF(MSTP(25).LE.2) THEN
17628C...CP-odd decay
17629 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17630 & -2*PKK(3,4)*PKK(5,6)
17631 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17632 & (PKK(3,4)*PKK(5,6))
17633 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17634 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
17635 ELSE
17636C...Mixed CP states.
17637 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
17638 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
17639 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
17640 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
17641 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17642 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17643 & +PKK(3,4)*PKK(5,6)
17644 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17645 & +VA12AS*PKK(3,4)*PKK(5,6)
17646 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17647 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17648 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17649 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
17650 ENDIF
17651
17652C...W decay
17653 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
17654 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
17655 & THEN
17656C...CP-even decay
17657 WT=16D0*PKK(3,5)*PKK(4,6)
17658 ELSEIF(MSTP(25).LE.2) THEN
17659C...CP-odd decay
17660 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
17661 & -2*PKK(3,4)*PKK(5,6)
17662 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
17663 & (PKK(3,4)*PKK(5,6))
17664 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
17665 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
17666 ELSE
17667C...Mixed CP states.
17668 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
17669 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
17670 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
17671 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
17672 & +PKK(3,4)*PKK(5,6)
17673 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
17674 & +PKK(3,4)*PKK(5,6)
17675 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
17676 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
17677 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
17678 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
17679 ENDIF
17680
17681C...No angular correlations in other Higgs decays.
17682 ELSE
17683 WT=WTMAX
17684 ENDIF
17685
17686 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
17687 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
17688 & THEN
17689C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
17690 I1=IREF(IP,8)
17691 IF(MOD(KFAGM,2).EQ.0) THEN
17692 I2=N+1
17693 I3=N+2
17694 ELSE
17695 I2=N+2
17696 I3=N+1
17697 ENDIF
17698 I4=IREF(IP,2)
17699 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
17700 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
17701 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
17702 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
17703
17704 ELSEIF(ISUB.EQ.1) THEN
17705C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
17706 EI=KCHG(IABS(MINT(15)),1)/3D0
17707 AI=SIGN(1D0,EI+0.1D0)
17708 VI=AI-4D0*EI*XWV
17709 EF=KCHG(IABS(KFL1(1)),1)/3D0
17710 AF=SIGN(1D0,EF+0.1D0)
17711
17712 VF=AF-4D0*EF*XWV
17713 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
17714 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17715 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
17716 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17717 & (VI**2+AI**2)*VINT(114)*VF**2)
17718 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
17719 & 4D0*VI*AI*VINT(114)*VF*AF)
17720 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
17721 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
17722 WTMAX=2D0*(WT1+ABS(WT3))
17723
17724 ELSEIF(ISUB.EQ.2) THEN
17725C...Angular weight for W+/- -> 2 quarks/leptons.
17726 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
17727 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
17728 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
17729 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
17730 WTMAX=4D0
17731
17732 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
17733C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
17734C...-> gluon/gamma + 2 quarks/leptons.
17735 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17736 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17737 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17738 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17739 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17740 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17741 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17742 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17743 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17744 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17745 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17746 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17747 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
17748 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
17749 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17750 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
17751
17752 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
17753C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
17754C...-> gluon/gamma + 2 quarks/leptons.
17755 WT=PKK(1,3)**2+PKK(2,4)**2
17756 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
17757
17758 ELSEIF(ISUB.EQ.22) THEN
17759C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
17760 S34=P(IREF(IP,IORD),5)**2
17761 S56=P(IREF(IP,3-IORD),5)**2
17762 TI=PKK(1,3)+PKK(1,4)+S34
17763 UI=PKK(1,5)+PKK(1,6)+S56
17764 TIR=REAL(TI)
17765 UIR=REAL(UI)
17766 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
17767 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
17768 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
17769 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
17770 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
17771 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
17772 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
17773 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
17774
17775 WT=
17776 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
17777 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
17778 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
17779 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
17780 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
17781 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
17782 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
17783 & 1D0/UI**2))
17784
17785 ELSEIF(ISUB.EQ.23) THEN
17786C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
17787 D34=P(IREF(IP,IORD),5)**2
17788 D56=P(IREF(IP,3-IORD),5)**2
17789 DT=PKK(1,3)+PKK(1,4)+D34
17790 DU=PKK(1,5)+PKK(1,6)+D56
17791 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
17792 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17793 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
17794 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
17795
17796 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
17797 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
17798 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
17799 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
17800 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
17801 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
17802
17803 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
17804C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
17805C...(or H0, or A0).
17806 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
17807 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
17808 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
17809 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
17810 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17811
17812 ELSEIF(ISUB.EQ.25) THEN
17813C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
17814 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
17815 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
17816 D34=P(IREF(IP,IORD),5)**2
17817 D56=P(IREF(IP,3-IORD),5)**2
17818 DT=PKK(1,3)+PKK(1,4)+D34
17819 DU=PKK(1,5)+PKK(1,6)+D56
17820 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
17821 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
17822 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
17823 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
17824 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
17825 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
17826 & REAL(CBWW)*FGK(1,2,5,6,3,4))
17827 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17828 IF(MSTP(50).LE.0) THEN
17829 WT=FGK135**2+(CCWW*FGK253)**2
17830 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
17831 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
17832 & DJGK(DT,DU)))
17833 ELSE
17834 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
17835 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
17836 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
17837 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
17838 ENDIF
17839
17840 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
17841C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
17842C...(or H0, or A0).
17843 WT=PKK(1,3)*PKK(2,4)
17844 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
17845
17846 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
17847C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
17848C...-> f + 2 quarks/leptons.
17849 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17850 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17851 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
17852 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17853 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17854 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
17855 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17856 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
17857 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
17858 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
17859 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
17860 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
17861 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
17862 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
17863 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
17864 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
17865 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
17866 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
17867
17868 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
17869C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
17870 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
17871 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
17872 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
17873
17874 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
17875 & ISUB.EQ.77) THEN
17876C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
17877 WT=16D0*PKK(3,5)*PKK(4,6)
17878 WTMAX=SH**2
17879
17880 ELSEIF(ISUB.EQ.110) THEN
17881C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
17882 WT=1D0
17883 WTMAX=1D0
17884
17885 ELSEIF(ISUB.EQ.141) THEN
17886 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17887C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
17888C...Couplings of incoming flavour.
17889 KFAI=IABS(MINT(15))
17890 EI=KCHG(KFAI,1)/3D0
17891 AI=SIGN(1D0,EI+0.1D0)
17892 VI=AI-4D0*EI*XWV
17893 KFAIC=1
17894 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
17895 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
17896 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
17897 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
17898 VPI=PARU(119+2*KFAIC)
17899 API=PARU(120+2*KFAIC)
17900 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
17901 VPI=PARJ(178+2*KFAIC)
17902 API=PARJ(179+2*KFAIC)
17903 ELSE
17904 VPI=PARJ(186+2*KFAIC)
17905 API=PARJ(187+2*KFAIC)
17906 ENDIF
17907C...Couplings of final flavour.
17908 KFAF=IABS(KFL1(1))
17909 EF=KCHG(KFAF,1)/3D0
17910 AF=SIGN(1D0,EF+0.1D0)
17911 VF=AF-4D0*EF*XWV
17912 KFAFC=1
17913 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
17914 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
17915 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
17916 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
17917 VPF=PARU(119+2*KFAFC)
17918 APF=PARU(120+2*KFAFC)
17919 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
17920 VPF=PARJ(178+2*KFAFC)
17921 APF=PARJ(179+2*KFAFC)
17922 ELSE
17923 VPF=PARJ(186+2*KFAFC)
17924 APF=PARJ(187+2*KFAFC)
17925 ENDIF
17926C...Asymmetry and weight.
17927 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
17928 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
17929 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
17930 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
17931 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
17932 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
17933 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
17934 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17935 WTMAX=2D0+ABS(ASYM)
17936 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
17937C...Angular weight for f + fbar -> Z' -> W+ + W-.
17938 RM1=P(NSD(1)+1,5)**2/SH
17939 RM2=P(NSD(1)+2,5)**2/SH
17940 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
17941 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
17942 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
17943 & (RM2-RM1)**2)
17944 WT=CFLAT+CCOS2*CTHE(1)**2
17945 WTMAX=CFLAT+MAX(0D0,CCOS2)
17946 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
17947 & IABS(KFL1(1)).EQ.37)) THEN
17948C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
17949 WT=1D0-CTHE(1)**2
17950 WTMAX=1D0
17951 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
17952C...Angular weight for f + fbar -> Z' -> Z0 + h0.
17953 RM1=P(NSD(1)+1,5)**2/SH
17954 RM2=P(NSD(1)+2,5)**2/SH
17955 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
17956 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
17957 WTMAX=1D0+FLAM2/(8D0*RM1)
17958 ELSEIF(MZPWP.EQ.0) THEN
17959C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17960C...(W:s like if intermediate Z).
17961 D34=P(IREF(IP,IORD),5)**2
17962 D56=P(IREF(IP,3-IORD),5)**2
17963 DT=PKK(1,3)+PKK(1,4)+D34
17964 DU=PKK(1,5)+PKK(1,6)+D56
17965 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
17966 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
17967 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
17968 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
17969 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
17970 ELSEIF(MZPWP.EQ.1) THEN
17971C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
17972C...(W:s approximately longitudinal, like if intermediate H).
17973 WT=16D0*PKK(3,5)*PKK(4,6)
17974 WTMAX=SH**2
17975 ELSE
17976C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
17977C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
17978 WT=1D0
17979 WTMAX=1D0
17980 ENDIF
17981
17982 ELSEIF(ISUB.EQ.142) THEN
17983 IF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
17984C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
17985 KFAI=IABS(MINT(15))
17986 KFAIC=1
17987 IF(KFAI.GT.10) KFAIC=2
17988 VI=PARU(129+2*KFAIC)
17989 AI=PARU(130+2*KFAIC)
17990 KFAF=IABS(KFL1(1))
17991 KFAFC=1
17992 IF(KFAF.GT.10) KFAFC=2
17993 VF=PARU(129+2*KFAFC)
17994 AF=PARU(130+2*KFAFC)
17995 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
17996 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
17997 WTMAX=2D0+ABS(ASYM)
17998 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
17999C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18000 RM1=P(NSD(1)+1,5)**2/SH
18001 RM2=P(NSD(1)+2,5)**2/SH
18002 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18003 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18004 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18005 & (RM2-RM1)**2)
18006 WT=CFLAT+CCOS2*CTHE(1)**2
18007 WTMAX=CFLAT+MAX(0D0,CCOS2)
18008 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18009C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18010 RM1=P(NSD(1)+1,5)**2/SH
18011 RM2=P(NSD(1)+2,5)**2/SH
18012 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18013 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18014 WTMAX=1D0+FLAM2/(8D0*RM1)
18015 ELSEIF(MZPWP.EQ.0) THEN
18016C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18017C...(W/Z like if intermediate W).
18018 D34=P(IREF(IP,IORD),5)**2
18019 D56=P(IREF(IP,3-IORD),5)**2
18020 DT=PKK(1,3)+PKK(1,4)+D34
18021 DU=PKK(1,5)+PKK(1,6)+D56
18022 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18023 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18024 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18025 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18026 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18027 ELSEIF(MZPWP.EQ.1) THEN
18028C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18029C...(W/Z approximately longitudinal, like if intermediate H).
18030 WT=16D0*PKK(3,5)*PKK(4,6)
18031 WTMAX=SH**2
18032 ELSE
18033C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18034C...t + bbar -> t + W + bbar.
18035 WT=1D0
18036 WTMAX=1D0
18037 ENDIF
18038
18039 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18040 & THEN
18041C...Isotropic decay of leptoquarks (assumed spin 0).
18042 WT=1D0
18043 WTMAX=1D0
18044
18045 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18046C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18047 SIDE=1D0
18048 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18049 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18050 WT=1D0+SIDE*CTHE(1)
18051 WTMAX=2D0
18052 ELSEIF(IP.EQ.1) THEN
18053
18054 RM1=P(NSD(1)+1,5)**2/SH
18055 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18056 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18057 ELSE
18058C...W/Z decay assumed isotropic, since not known.
18059 WT=1D0
18060 WTMAX=1D0
18061 ENDIF
18062
18063 ELSEIF(ISUB.EQ.149) THEN
18064C...Isotropic decay of techni-eta.
18065 WT=1D0
18066 WTMAX=1D0
18067
18068 ELSEIF(ISUB.EQ.191) THEN
18069 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18070C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18071C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18072 WT=1D0-CTHE(1)**2
18073 WTMAX=1D0
18074 ELSEIF(IP.EQ.1) THEN
18075C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18076 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18077 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18078 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18079 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18080 KFAI=IABS(MINT(15))
18081 EI=KCHG(KFAI,1)/3D0
18082 AI=SIGN(1D0,EI+0.1D0)
18083 VI=AI-4D0*EI*XWV
18084 VALI=0.5D0*(VI+AI)
18085 VARI=0.5D0*(VI-AI)
18086 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18087 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18088 KFAF=IABS(KFL1(1))
18089 EF=KCHG(KFAF,1)/3D0
18090 AF=SIGN(1D0,EF+0.1D0)
18091 VF=AF-4D0*EF*XWV
18092 VALF=0.5D0*(VF+AF)
18093 VARF=0.5D0*(VF-AF)
18094 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18095 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18096 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18097 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18098 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18099 WTMAX=4D0*MAX(ASAME,AFLIP)
18100 ELSE
18101C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18102 WT=1D0
18103 WTMAX=1D0
18104 ENDIF
18105
18106 ELSEIF(ISUB.EQ.192) THEN
18107 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18108C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18109C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18110 WT=1D0-CTHE(1)**2
18111 WTMAX=1D0
18112 ELSEIF(IP.EQ.1) THEN
18113C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18114 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18115 WT=(1D0+CTHESG)**2
18116 WTMAX=4D0
18117 ELSE
18118C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18119 WT=1D0
18120 WTMAX=1D0
18121 ENDIF
18122
18123 ELSEIF(ISUB.EQ.193) THEN
18124 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18125C...Angular weight for f + fbar -> omega_tc0 ->
18126C...gamma pi_tc0 or Z0 pi_tc0.
18127 WT=1D0+CTHE(1)**2
18128 WTMAX=2D0
18129 ELSEIF(IP.EQ.1) THEN
18130C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18131 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18132 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18133 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18134 KFAI=IABS(MINT(15))
18135 EI=KCHG(KFAI,1)/3D0
18136 AI=SIGN(1D0,EI+0.1D0)
18137 VI=AI-4D0*EI*XWV
18138 VALI=0.5D0*(VI+AI)
18139 VARI=0.5D0*(VI-AI)
18140 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18141 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18142 KFAF=IABS(KFL1(1))
18143 EF=KCHG(KFAF,1)/3D0
18144 AF=SIGN(1D0,EF+0.1D0)
18145 VF=AF-4D0*EF*XWV
18146 VALF=0.5D0*(VF+AF)
18147 VARF=0.5D0*(VF-AF)
18148 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18149 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18150 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18151 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18152 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18153 WTMAX=4D0*MAX(BSAME,BFLIP)
18154 ELSE
18155C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18156 WT=1D0
18157 WTMAX=1D0
18158 ENDIF
18159
18160 ELSEIF(ISUB.EQ.353) THEN
18161C...Angular weight for Z_R0 -> 2 quarks/leptons.
18162 EI=KCHG(IABS(MINT(15)),1)/3D0
18163 AI=SIGN(1D0,EI+0.1D0)
18164 VI=AI-4D0*EI*XWV
18165 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18166 AF=SIGN(1D0,EF+0.1D0)
18167 VF=AF-4D0*EF*XWV
18168 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18169 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18170 WT2=RMF*(VI**2+AI**2)*VF**2
18171 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18172 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18173 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18174 WTMAX=2D0*(WT1+ABS(WT3))
18175
18176 ELSEIF(ISUB.EQ.354) THEN
18177C...Angular weight for W_R+/- -> 2 quarks/leptons.
18178 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18179 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18180 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18181 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18182 WTMAX=4D0
18183
18184 ELSEIF(ISUB.EQ.391) THEN
18185C...Angular weight for f + fbar -> G* -> f + fbar
18186 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18187 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18188 WTMAX=2D0
18189C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18190C...implemented by M.-C. Lemaire
18191 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18192 & IABS(KFL1(1)).EQ.22)) THEN
18193 WT=1D0-CTHE(1)**4
18194 WTMAX=1D0
18195C...Other G* decays not yet implemented angular distributions.
18196 ELSE
18197 WT=1D0
18198 WTMAX=1D0
18199 ENDIF
18200
18201 ELSEIF(ISUB.EQ.392) THEN
18202C...Angular weight for g + g -> G* -> f + fbar
18203 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18204 WT=1D0-CTHE(1)**4
18205 WTMAX=1D0
18206C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18207C...implemented by M.-C. Lemaire
18208 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18209 & IABS(KFL1(1)).EQ.22)) THEN
18210 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18211 WTMAX=8D0
18212C...Other G* decays not yet implemented angular distributions.
18213 ELSE
18214 WT=1D0
18215 WTMAX=1D0
18216 ENDIF
18217
18218C...Obtain correct angular distribution by rejection techniques.
18219 ELSE
18220 WT=1D0
18221 WTMAX=1D0
18222 ENDIF
18223 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18224
18225C...Construct massive four-vectors using angles chosen.
18226 590 DO 690 JT=1,JTMAX
18227 IF(KDCY(JT).EQ.0) GOTO 690
18228 ID=IREF(IP,JT)
18229 DO 600 J=1,5
18230 DPMO(J)=P(ID,J)
18231 600 CONTINUE
18232 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18233CMRENNA++
18234 IF(KFL3(JT).EQ.0) THEN
18235 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18236 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18237 N0=NSD(JT)+2
18238 ELSE
18239 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18240 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18241 N0=NSD(JT)+3
18242 ENDIF
18243
18244 DO 610 J=1,4
18245 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18246 610 CONTINUE
18247C...Fill in position of decay vertex.
18248 DO 630 I=NSD(JT)+1,N0
18249 DO 620 J=1,4
18250 V(I,J)=VDCY(J)
18251 620 CONTINUE
18252 V(I,5)=0D0
18253
18254 630 CONTINUE
18255CMRENNA--
18256
18257C...Mark decayed resonances; trace history.
18258 K(ID,1)=K(ID,1)+10
18259 KFA=IABS(K(ID,2))
18260 KCA=PYCOMP(KFA)
18261 IF(KCQM(JT).NE.0) THEN
18262C...Do not kill colour flow through coloured resonance!
18263 ELSE
18264 K(ID,4)=NSD(JT)+1
18265 K(ID,5)=NSD(JT)+2
18266C...If 3-body or 2-body with junction:
18267 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18268C...If 3-body with junction:
18269 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18270 ENDIF
18271
18272C...Add documentation lines.
18273 ISUBRG=MAX(1,MIN(500,MINT(1)))
18274 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18275 IDOC=MINT(83)+MINT(4)
18276CMRENNA+++
18277 IHI=NSD(JT)+2
18278 IF(KFL3(JT).NE.0) IHI=IHI+1
18279 DO 650 I=NSD(JT)+1,IHI
18280CMRENNA---
18281 I1=MINT(83)+MINT(4)+1
18282 K(I,3)=I1
18283 IF(MSTP(128).GE.1) K(I,3)=ID
18284 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18285 MINT(4)=MINT(4)+1
18286 K(I1,1)=21
18287 K(I1,2)=K(I,2)
18288 K(I1,3)=IREF(IP,JT+3)
18289 DO 640 J=1,5
18290 P(I1,J)=P(I,J)
18291 640 CONTINUE
18292 ENDIF
18293 650 CONTINUE
18294 ELSE
18295 K(NSD(JT)+1,3)=ID
18296 K(NSD(JT)+2,3)=ID
18297C...If 3-body or 2-body with junction:
18298 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18299C...If 3-body with junction:
18300 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18301 ENDIF
18302
18303C...Do showering of two or three objects.
18304 NSHBEF=N
18305 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18306 IF(KFL3(JT).EQ.0) THEN
18307 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18308 ELSE
18309 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18310 ENDIF
18311
18312c...For pT-ordered shower need set up first, especially colour tags.
18313C...(Need to set up colour tags even if MSTP(71) = 0)
18314 ELSEIF(MINT(35).GE.2) THEN
18315 NPART=2
18316 IF(KFL3(JT).NE.0) NPART=3
18317 IPART(1)=NSD(JT)+1
18318 IPART(2)=NSD(JT)+2
18319 IPART(3)=NSD(JT)+3
18320 PTPART(1)=0.5D0*P(ID,5)
18321 PTPART(2)=PTPART(1)
18322 PTPART(3)=PTPART(1)
18323 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18324 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18325 IF(MOTHER.LE.NSD(JT)) THEN
18326 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18327 ELSE
18328 NCT=NCT+1
18329 MCT(NSD(JT)+1,1)=NCT
18330 MCT(MOTHER,2)=NCT
18331 ENDIF
18332 ENDIF
18333 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18334 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18335 IF(MOTHER.LE.NSD(JT)) THEN
18336 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18337 ELSE
18338 NCT=NCT+1
18339 MCT(NSD(JT)+1,2)=NCT
18340 MCT(MOTHER,1)=NCT
18341 ENDIF
18342 ENDIF
18343 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18344 & KCQ2(JT).EQ.2)) THEN
18345 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18346 IF(MOTHER.LE.NSD(JT)) THEN
18347 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18348 ELSE
18349 NCT=NCT+1
18350 MCT(NSD(JT)+2,1)=NCT
18351 MCT(MOTHER,2)=NCT
18352 ENDIF
18353 ENDIF
18354 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18355 & KCQ2(JT).EQ.2)) THEN
18356 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18357 IF(MOTHER.LE.NSD(JT)) THEN
18358 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18359 ELSE
18360 NCT=NCT+1
18361 MCT(NSD(JT)+2,2)=NCT
18362 MCT(MOTHER,1)=NCT
18363 ENDIF
18364 ENDIF
18365 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18366 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18367 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18368 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18369 ENDIF
18370 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18371 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18372 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18373 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18374 ENDIF
18375 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18376 ENDIF
18377 NSHAFT=N
18378 IF(JT.EQ.1) NAFT1=N
18379
18380C...Check if decay products moved by shower.
18381 NSD1=NSD(JT)+1
18382 NSD2=NSD(JT)+2
18383 NSD3=NSD(JT)+3
18384 IF(NSHAFT.GT.NSHBEF) THEN
18385 IF(K(NSD1,1).GT.10) THEN
18386 DO 660 I=NSHBEF+1,NSHAFT
18387 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
18388 660 CONTINUE
18389 ENDIF
18390 IF(K(NSD2,1).GT.10) THEN
18391 DO 670 I=NSHBEF+1,NSHAFT
18392 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
18393 & I.NE.NSD1) NSD2=I
18394 670 CONTINUE
18395 ENDIF
18396 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
18397 DO 680 I=NSHBEF+1,NSHAFT
18398 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
18399 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
18400 680 CONTINUE
18401 ENDIF
18402 ENDIF
18403
18404C...Store decay products for further treatment.
18405 NP=NP+1
18406 IREF(NP,1)=NSD1
18407 IREF(NP,2)=NSD2
18408 IREF(NP,3)=0
18409 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
18410 IREF(NP,4)=IDOC+1
18411 IREF(NP,5)=IDOC+2
18412 IREF(NP,6)=0
18413 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
18414 IREF(NP,7)=K(IREF(IP,JT),2)
18415 IREF(NP,8)=IREF(IP,JT)
18416 690 CONTINUE
18417
18418
18419C...Fill information for 2 -> 1 -> 2.
18420 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
18421 MINT(7)=MINT(83)+6+2*ISET(ISUB)
18422 MINT(8)=MINT(83)+7+2*ISET(ISUB)
18423 MINT(25)=KFL1(1)
18424 MINT(26)=KFL2(1)
18425 VINT(23)=CTHE(1)
18426 RM3=P(N-1,5)**2/SH
18427 RM4=P(N,5)**2/SH
18428 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18429 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
18430 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
18431 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
18432 VINT(47)=SQRT(VINT(48))
18433 ENDIF
18434
18435C...Possibility of colour rearrangement in W+W- events.
18436 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
18437 IAKF1=IABS(KFL1(1))
18438 IAKF2=IABS(KFL1(2))
18439 IAKF3=IABS(KFL2(1))
18440 IAKF4=IABS(KFL2(2))
18441 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
18442 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
18443 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
18444 IF(MINT(51).NE.0) RETURN
18445 ENDIF
18446
18447C...Loop back if needed.
18448 710 IF(IP.LT.NP) GOTO 170
18449
18450C...Boost back to standard frame.
18451 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
18452 &BEZIN)
18453
18454 RETURN
18455 END
18456
18457C*********************************************************************
18458
18459C...PYMULT
18460C...Initializes treatment of multiple interactions, selects kinematics
18461C...of hardest interaction if low-pT physics included in run, and
18462C...generates all non-hardest interactions.
18463
18464 SUBROUTINE PYMULT(MMUL)
18465
18466C...Double precision and integer declarations.
18467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
18468 IMPLICIT INTEGER(I-N)
18469 INTEGER PYK,PYCHGE,PYCOMP
18470C...Commonblocks.
18471 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
18472 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
18473 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
18474 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
18475 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
18476 COMMON/PYINT1/MINT(400),VINT(400)
18477 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
18478 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
18479 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
18480 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
18481 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
18482 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
18483C...Local arrays and saved variables.
18484 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
18485 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
18486 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
18487 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
18488
18489C...Initialization of multiple interaction treatment.
18490 IF(MMUL.EQ.1) THEN
18491 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
18492 ISUB=96
18493 MINT(1)=96
18494 VINT(63)=0D0
18495 VINT(64)=0D0
18496 VINT(143)=1D0
18497 VINT(144)=1D0
18498
18499C...Loop over phase space points: xT2 choice in 20 bins.
18500 100 SIGSUM=0D0
18501 DO 120 IXT2=1,20
18502 NMUL(IXT2)=MSTP(83)
18503 SIGM(IXT2)=0D0
18504 DO 110 ITRY=1,MSTP(83)
18505 RSCA=0.05D0*((21-IXT2)-PYR(0))
18506 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
18507 XT2=MAX(0.01D0*VINT(149),XT2)
18508 VINT(25)=XT2
18509
18510C...Choose tau and y*. Calculate cos(theta-hat).
18511 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18512 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18513 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18514 ELSE
18515 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18516 ENDIF
18517 VINT(21)=TAU
18518 CALL PYKLIM(2)
18519 RYST=PYR(0)
18520 MYST=1
18521 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18522 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18523 CALL PYKMAP(2,MYST,PYR(0))
18524 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18525
18526C...Calculate differential cross-section.
18527 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18528 CALL PYSIGH(NCHN,SIGS)
18529 SIGM(IXT2)=SIGM(IXT2)+SIGS
18530 110 CONTINUE
18531 SIGSUM=SIGSUM+SIGM(IXT2)
18532 120 CONTINUE
18533 SIGSUM=SIGSUM/(20D0*MSTP(83))
18534
18535C...Reject result if sigma(parton-parton) is smaller than hadronic one.
18536 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
18537 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
18538 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
18539 PARP(82)=0.9D0*PARP(82)
18540 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
18541 & VINT(2)
18542 GOTO 100
18543 ENDIF
18544 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
18545 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
18546
18547C...Start iteration to find k factor.
18548 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
18549 P83A=(1D0-PARP(83))**2
18550 P83B=2D0*PARP(83)*(1D0-PARP(83))
18551 P83C=PARP(83)**2
18552 CQ2I=1D0/PARP(84)**2
18553 CQ2R=2D0/(1D0+PARP(84)**2)
18554 SO=0.5D0
18555 XI=0D0
18556 YI=0D0
18557 XF=0D0
18558 YF=0D0
18559 XK=0.5D0
18560 IIT=0
18561 130 IF(IIT.EQ.0) THEN
18562 XK=2D0*XK
18563 ELSEIF(IIT.EQ.1) THEN
18564 XK=0.5D0*XK
18565 ELSE
18566 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
18567 ENDIF
18568
18569C...Evaluate overlap integrals. Find where to divide the b range.
18570 IF(MSTP(82).EQ.2) THEN
18571 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
18572 SOP=SP/PARU(1)
18573 ELSE
18574 IF(MSTP(82).EQ.3) THEN
18575 DELTAB=0.02D0
18576 ELSEIF(MSTP(82).EQ.4) THEN
18577 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
18578 ELSE
18579 POWIP=MAX(0.4D0,PARP(83))
18580 RPWIP=2D0/POWIP-1D0
18581 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
18582 SO=0D0
18583 ENDIF
18584 SP=0D0
18585 SOP=0D0
18586 BSP=0D0
18587 SOHIGH=0D0
18588 IBDIV=0
18589 B=-0.5D0*DELTAB
18590 140 B=B+DELTAB
18591 IF(MSTP(82).EQ.3) THEN
18592 OV=EXP(-B**2)/PARU(2)
18593 ELSEIF(MSTP(82).EQ.4) THEN
18594 OV=(P83A*EXP(-MIN(50D0,B**2))+
18595 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18596 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18597 ELSE
18598 OV=EXP(-B**POWIP)/PARU(2)
18599 SO=SO+PARU(2)*B*DELTAB*OV
18600 ENDIF
18601 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
18602 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
18603 SP=SP+PARU(2)*B*DELTAB*PACC
18604 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
18605 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
18606 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
18607 IBDIV=1
18608 BDIV=B+0.5D0*DELTAB
18609 ENDIF
18610 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
18611 ENDIF
18612 YK=PARU(1)*XK*SO/SP
18613
18614C...Continue iteration until convergence.
18615 IF(YK.LT.YKE) THEN
18616 XI=XK
18617 YI=YK
18618 IF(IIT.EQ.1) IIT=2
18619 ELSE
18620 XF=XK
18621 YF=YK
18622 IF(IIT.EQ.0) IIT=1
18623 ENDIF
18624 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
18625
18626C...Store some results for subsequent use.
18627 BAVG=BSP/SP
18628 VINT(145)=SIGSUM
18629 VINT(146)=SOP/SO
18630 VINT(147)=SOP/SP
18631 VNT145=VINT(145)
18632 VNT146=VINT(146)
18633 VNT147=VINT(147)
18634C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
18635 PIK=(VNT146/VNT147)*YKE
18636
18637C...Find relative weight for low and high impact parameter.
18638 PLOWB=PARU(1)*BDIV**2
18639 IF(MSTP(82).EQ.3) THEN
18640 PHIGHB=PIK*0.5*EXP(-BDIV**2)
18641 ELSEIF(MSTP(82).EQ.4) THEN
18642 S4A=P83A*EXP(-BDIV**2)
18643 S4B=P83B*EXP(-BDIV**2*CQ2R)
18644 S4C=P83C*EXP(-BDIV**2*CQ2I)
18645 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
18646 ELSEIF(PARP(83).GE.1.999D0) THEN
18647 PHIGHB=PIK*SOHIGH
18648 B2RPDV=BDIV**POWIP
18649 ELSE
18650 PHIGHB=PIK*SOHIGH
18651 B2RPDV=BDIV**POWIP
18652 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
18653 ENDIF
18654 PALLB=PLOWB+PHIGHB
18655
18656C...Initialize iteration in xT2 for hardest interaction.
18657 ELSEIF(MMUL.EQ.2) THEN
18658 VINT(145)=VNT145
18659 VINT(146)=VNT146
18660 VINT(147)=VNT147
18661 IF(MSTP(82).LE.0) THEN
18662 ELSEIF(MSTP(82).EQ.1) THEN
18663 XT2=1D0
18664 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18665 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18666 & VINT(317)/(VINT(318)*VINT(320))
18667 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18668 ELSEIF(MSTP(82).EQ.2) THEN
18669 XT2=1D0
18670 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18671 & VINT(149)*(1D0+VINT(149))
18672 ELSE
18673 XC2=4D0*CKIN(3)**2/VINT(2)
18674 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
18675 ENDIF
18676
18677C...Select impact parameter for hardest interaction.
18678 IF(MSTP(82).LE.2) RETURN
18679 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
18680C...Treatment in low b region.
18681 MINT(39)=1
18682 B=BDIV*SQRT(PYR(0))
18683 IF(MSTP(82).EQ.3) THEN
18684 OV=EXP(-B**2)/PARU(2)
18685 ELSEIF(MSTP(82).EQ.4) THEN
18686 OV=(P83A*EXP(-MIN(50D0,B**2))+
18687 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18688 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18689 ELSE
18690 OV=EXP(-B**POWIP)/PARU(2)
18691 ENDIF
18692 VINT(148)=OV/VNT147
18693 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
18694 XT2=1D0
18695 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
18696 & VINT(149)*(1D0+VINT(149))
18697 ELSE
18698C...Treatment in high b region.
18699 MINT(39)=2
18700 IF(MSTP(82).EQ.3) THEN
18701 B=SQRT(BDIV**2-LOG(PYR(0)))
18702 OV=EXP(-B**2)/PARU(2)
18703 ELSEIF(MSTP(82).EQ.4) THEN
18704 S4RNDM=PYR(0)*(S4A+S4B+S4C)
18705 IF(S4RNDM.LT.S4A) THEN
18706 B=SQRT(BDIV**2-LOG(PYR(0)))
18707 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
18708 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
18709 ELSE
18710 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
18711 ENDIF
18712 OV=(P83A*EXP(-MIN(50D0,B**2))+
18713 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
18714 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
18715 ELSEIF(PARP(83).GE.1.999D0) THEN
18716 144 B2RPW=B2RPDV-LOG(PYR(0))
18717 ACCIP=(B2RPW/B2RPDV)**RPWIP
18718 IF(ACCIP.LT.PYR(0)) GOTO 144
18719 OV=EXP(-B2RPW)/PARU(2)
18720 B=B2RPW**(1D0/POWIP)
18721 ELSE
18722 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
18723 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
18724 IF(ACCIP.LT.PYR(0)) GOTO 146
18725 OV=EXP(-B2RPW)/PARU(2)
18726 B=B2RPW**(1D0/POWIP)
18727 ENDIF
18728 VINT(148)=OV/VNT147
18729 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
18730 ENDIF
18731 IF(PACC.LT.PYR(0)) GOTO 142
18732 VINT(139)=B/BAVG
18733
18734 ELSEIF(MMUL.EQ.3) THEN
18735C...Low-pT or multiple interactions (first semihard interaction):
18736C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
18737C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
18738 ISUB=MINT(1)
18739 VINT(145)=VNT145
18740 VINT(146)=VNT146
18741 VINT(147)=VNT147
18742 IF(MSTP(82).LE.0) THEN
18743 XT2=0D0
18744 ELSEIF(MSTP(82).EQ.1) THEN
18745 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18746C...Use with "Sudakov" for low b values when impact parameter dependence.
18747 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
18748 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
18749 & VINT(149)))).GT.PYR(0)) XT2=1D0
18750 IF(XT2.GE.1D0) THEN
18751 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
18752 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
18753 & VINT(149)
18754 ELSE
18755 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
18756 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
18757 & VINT(149)
18758 ENDIF
18759 XT2=MAX(0.01D0*VINT(149),XT2)
18760C...Use without "Sudakov" for high b values when impact parameter dep.
18761 ELSE
18762 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
18763 & PYR(0)*(1D0-XC2))-VINT(149)
18764 XT2=MAX(0.01D0*VINT(149),XT2)
18765 ENDIF
18766 VINT(25)=XT2
18767
18768C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
18769 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
18770 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
18771 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
18772 ISUB=95
18773 MINT(1)=ISUB
18774 VINT(21)=0.01D0*VINT(149)
18775 VINT(22)=0D0
18776 VINT(23)=0D0
18777 VINT(25)=0.01D0*VINT(149)
18778
18779 ELSE
18780C...Multiple interactions (first semihard interaction).
18781C...Choose tau and y*. Calculate cos(theta-hat).
18782 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18783 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18784 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18785 ELSE
18786 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18787 ENDIF
18788 VINT(21)=TAU
18789 CALL PYKLIM(2)
18790 RYST=PYR(0)
18791 MYST=1
18792 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18793 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18794 CALL PYKMAP(2,MYST,PYR(0))
18795 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18796 ENDIF
18797 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
18798
18799C...Store results of cross-section calculation.
18800 ELSEIF(MMUL.EQ.4) THEN
18801 ISUB=MINT(1)
18802 VINT(145)=VNT145
18803 VINT(146)=VNT146
18804 VINT(147)=VNT147
18805 XTS=VINT(25)
18806 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
18807 IF(ISET(ISUB).EQ.2)
18808 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
18809 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
18810 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
18811 & (XTS+VINT(149))))
18812 IRBIN=INT(1D0+20D0*RBIN)
18813 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
18814 NMUL(IRBIN)=NMUL(IRBIN)+1
18815 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
18816 ENDIF
18817
18818C...Choose impact parameter if not already done.
18819 ELSEIF(MMUL.EQ.5) THEN
18820 ISUB=MINT(1)
18821 VINT(145)=VNT145
18822 VINT(146)=VNT146
18823 VINT(147)=VNT147
18824 150 IF(MINT(39).GT.0) THEN
18825 ELSEIF(MSTP(82).EQ.3) THEN
18826 EXPB2=PYR(0)
18827 B2=-LOG(PYR(0))
18828 VINT(148)=EXPB2/(PARU(2)*VNT147)
18829 VINT(139)=SQRT(B2)/BAVG
18830 ELSEIF(MSTP(82).EQ.4) THEN
18831 RTYPE=PYR(0)
18832 IF(RTYPE.LT.P83A) THEN
18833 B2=-LOG(PYR(0))
18834 ELSEIF(RTYPE.LT.P83A+P83B) THEN
18835 B2=-LOG(PYR(0))/CQ2R
18836 ELSE
18837 B2=-LOG(PYR(0))/CQ2I
18838 ENDIF
18839 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
18840 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
18841 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
18842 VINT(139)=SQRT(B2)/BAVG
18843 ELSEIF(PARP(83).GE.1.999D0) THEN
18844 POWIP=MAX(2D0,PARP(83))
18845 RPWIP=2D0/POWIP-1D0
18846 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
18847 160 IF(PYR(0).LT.PROB1) THEN
18848 B2RPW=PYR(0)**(0.5D0*POWIP)
18849 ACCIP=EXP(-B2RPW)
18850 ELSE
18851 B2RPW=1D0-LOG(PYR(0))
18852 ACCIP=B2RPW**RPWIP
18853 ENDIF
18854 IF(ACCIP.LT.PYR(0)) GOTO 160
18855 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18856 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18857 ELSE
18858 POWIP=MAX(0.4D0,PARP(83))
18859 RPWIP=2D0/POWIP-1D0
18860 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
18861 170 IF(PYR(0).LT.PROB1) THEN
18862 B2RPW=2D0*RPWIP*PYR(0)
18863 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
18864 ELSE
18865 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
18866 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
18867 ENDIF
18868 IF(ACCIP.LT .PYR(0)) GOTO 170
18869 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
18870 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
18871 ENDIF
18872
18873C...Multiple interactions (variable impact parameter) : reject with
18874C...probability exp(-overlap*cross-section above pT/normalization).
18875C...Does not apply to low-b region, where "Sudakov" already included.
18876 VINT(150)=1D0
18877 IF(MINT(39).NE.1) THEN
18878 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
18879 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
18880 DO 180 IBIN=IRBIN+1,20
18881 RNCOR=RNCOR+NMUL(IBIN)
18882 SIGCOR=SIGCOR+SIGM(IBIN)
18883 180 CONTINUE
18884 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
18885 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
18886 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
18887 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
18888 ENDIF
18889 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
18890 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
18891 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
18892 IF(VINT(150).LT.PYR(0)) GOTO 150
18893 VINT(150)=1D0
18894 ENDIF
18895
18896C...Generate additional multiple semihard interactions.
18897 ELSEIF(MMUL.EQ.6) THEN
18898 ISUBSV=MINT(1)
18899 VINT(145)=VNT145
18900 VINT(146)=VNT146
18901 VINT(147)=VNT147
18902 DO 190 J=11,80
18903 VINTSV(J)=VINT(J)
18904 190 CONTINUE
18905 ISUB=96
18906 MINT(1)=96
18907 VINT(151)=0D0
18908 VINT(152)=0D0
18909
18910C...Reconstruct strings in hard scattering.
18911 NMAX=MINT(84)+4
18912 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
18913 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
18914 NSTR=0
18915 DO 210 I=MINT(84)+1,NMAX
18916 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
18917 IF(KCS.EQ.0) GOTO 210
18918 DO 200 J=1,4
18919 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
18920 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
18921 IF(J.LE.2) THEN
18922 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
18923 ELSE
18924 IST=MOD(K(I,J+1),MSTU(5))
18925 ENDIF
18926 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
18927 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
18928 NSTR=NSTR+1
18929 IF(J.EQ.1.OR.J.EQ.4) THEN
18930 KSTR(NSTR,1)=I
18931 KSTR(NSTR,2)=IST
18932 ELSE
18933 KSTR(NSTR,1)=IST
18934 KSTR(NSTR,2)=I
18935 ENDIF
18936 200 CONTINUE
18937 210 CONTINUE
18938
18939C...Set up starting values for iteration in xT2.
18940 XT2=4D0*VINT(62)/VINT(2)
18941 IF(MSTP(82).LE.1) THEN
18942 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
18943 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
18944 & VINT(317)/(VINT(318)*VINT(320))
18945 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
18946 ELSE
18947 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
18948 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
18949 ENDIF
18950 VINT(63)=0D0
18951 VINT(64)=0D0
18952 VINT(143)=1D0-VINT(141)
18953 VINT(144)=1D0-VINT(142)
18954
18955C...Iterate downwards in xT2.
18956 220 IF(MSTP(82).LE.1) THEN
18957 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
18958 IF(XT2.LT.VINT(149)) GOTO 270
18959 ELSE
18960 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
18961 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
18962 & LOG(PYR(0)))-VINT(149)
18963 IF(XT2.LE.0D0) GOTO 270
18964 XT2=MAX(0.01D0*VINT(149),XT2)
18965 ENDIF
18966 VINT(25)=XT2
18967
18968C...Choose tau and y*. Calculate cos(theta-hat).
18969 IF(PYR(0).LE.COEF(ISUB,1)) THEN
18970 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
18971 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
18972 ELSE
18973 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
18974 ENDIF
18975 VINT(21)=TAU
18976 CALL PYKLIM(2)
18977 RYST=PYR(0)
18978 MYST=1
18979 IF(RYST.GT.COEF(ISUB,8)) MYST=2
18980 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
18981 CALL PYKMAP(2,MYST,PYR(0))
18982 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
18983
18984C...Check that x not used up. Accept or reject kinematical variables.
18985 X1M=SQRT(TAU)*EXP(VINT(22))
18986 X2M=SQRT(TAU)*EXP(-VINT(22))
18987 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
18988 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
18989 CALL PYSIGH(NCHN,SIGS)
18990 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
18991 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
18992
18993C...Reset K, P and V vectors. Select some variables.
18994 DO 240 I=N+1,N+2
18995 DO 230 J=1,5
18996 K(I,J)=0
18997 P(I,J)=0D0
18998 V(I,J)=0D0
18999 230 CONTINUE
19000 240 CONTINUE
19001 RFLAV=PYR(0)
19002 PT=0.5D0*VINT(1)*SQRT(XT2)
19003 PHI=PARU(2)*PYR(0)
19004 CTH=VINT(23)
19005
19006C...Add first parton to event record.
19007 K(N+1,1)=3
19008 K(N+1,2)=21
19009 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19010 & 1+INT((2D0+PARJ(2))*PYR(0))
19011 P(N+1,1)=PT*COS(PHI)
19012 P(N+1,2)=PT*SIN(PHI)
19013 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19014 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19015 P(N+1,5)=0D0
19016
19017C...Add second parton to event record.
19018 K(N+2,1)=3
19019 K(N+2,2)=21
19020 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19021 P(N+2,1)=-P(N+1,1)
19022 P(N+2,2)=-P(N+1,2)
19023 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19024 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19025 P(N+2,5)=0D0
19026
19027 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19028C....Choose relevant string pieces to place gluons on.
19029 DO 260 I=N+1,N+2
19030 DMIN=1D8
19031 DO 250 ISTR=1,NSTR
19032 I1=KSTR(ISTR,1)
19033 I2=KSTR(ISTR,2)
19034 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19035 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19036 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19037 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19038 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19039 DMIN=DIST
19040 IST1=I1
19041 IST2=I2
19042 ISTM=ISTR
19043 ENDIF
19044 250 CONTINUE
19045
19046C....Colour flow adjustments, new string pieces.
19047 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19048 & MOD(K(IST1,4),MSTU(5))
19049 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19050 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19051 K(I,5)=MSTU(5)*IST1
19052 K(I,4)=MSTU(5)*IST2
19053 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19054 & MOD(K(IST2,5),MSTU(5))
19055 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19056 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19057 KSTR(ISTM,2)=I
19058 KSTR(NSTR+1,1)=I
19059 KSTR(NSTR+1,2)=IST2
19060 NSTR=NSTR+1
19061 260 CONTINUE
19062
19063C...String drawing and colour flow for gluon loop.
19064 ELSEIF(K(N+1,2).EQ.21) THEN
19065 K(N+1,4)=MSTU(5)*(N+2)
19066 K(N+1,5)=MSTU(5)*(N+2)
19067 K(N+2,4)=MSTU(5)*(N+1)
19068 K(N+2,5)=MSTU(5)*(N+1)
19069 KSTR(NSTR+1,1)=N+1
19070 KSTR(NSTR+1,2)=N+2
19071 KSTR(NSTR+2,1)=N+2
19072 KSTR(NSTR+2,2)=N+1
19073 NSTR=NSTR+2
19074
19075C...String drawing and colour flow for qqbar pair.
19076 ELSE
19077 K(N+1,4)=MSTU(5)*(N+2)
19078 K(N+2,5)=MSTU(5)*(N+1)
19079 KSTR(NSTR+1,1)=N+1
19080 KSTR(NSTR+1,2)=N+2
19081 NSTR=NSTR+1
19082 ENDIF
19083
19084C...Global statistics.
19085 MINT(351)=MINT(351)+1
19086 VINT(351)=VINT(351)+PT
19087 IF (MINT(351).EQ.1) VINT(356)=PT
19088
19089C...Update remaining energy; iterate.
19090 N=N+2
19091 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19092 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19093 MINT(51)=1
19094 RETURN
19095 ENDIF
19096 MINT(31)=MINT(31)+1
19097 VINT(151)=VINT(151)+VINT(41)
19098 VINT(152)=VINT(152)+VINT(42)
19099 VINT(143)=VINT(143)-VINT(41)
19100 VINT(144)=VINT(144)-VINT(42)
19101C...Allow FSR for UE
19102 IF(MSTP(152).EQ.1) CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19103 IF(MINT(31).LT.240) GOTO 220
19104 270 CONTINUE
19105 MINT(1)=ISUBSV
19106 DO 280 J=11,80
19107 VINT(J)=VINTSV(J)
19108 280 CONTINUE
19109 ENDIF
19110
19111C...Format statements for printout.
19112 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19113 &'actions for MSTP(82) =',I2,' ******')
19114 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19115 &D9.2,' mb: rejected')
19116 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19117 &D9.2,' mb: accepted')
19118
19119 RETURN
19120 END
19121
19122C*********************************************************************
19123
19124C...PYREMN
19125C...Adds on target remnants (one or two from each side) and
19126C...includes primordial kT for hadron beams.
19127
19128 SUBROUTINE PYREMN(IPU1,IPU2)
19129
19130C...Double precision and integer declarations.
19131 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19132 IMPLICIT INTEGER(I-N)
19133 INTEGER PYK,PYCHGE,PYCOMP
19134C...Commonblocks.
19135 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19138 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19139 COMMON/PYINT1/MINT(400),VINT(400)
19140 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19141C...Local arrays.
19142 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19143 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19144
19145C...Find event type and remaining energy.
19146 ISUB=MINT(1)
19147 NS=N
19148 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19149 VINT(143)=1D0-VINT(141)
19150 VINT(144)=1D0-VINT(142)
19151 ENDIF
19152
19153C...Define initial partons.
19154 NTRY=0
19155 100 NTRY=NTRY+1
19156 DO 130 JT=1,2
19157 I=MINT(83)+JT+2
19158 IF(JT.EQ.1) IPU=IPU1
19159 IF(JT.EQ.2) IPU=IPU2
19160 K(I,1)=21
19161 K(I,2)=K(IPU,2)
19162 K(I,3)=I-2
19163 PMS(JT)=0D0
19164 VINT(156+JT)=0D0
19165 VINT(158+JT)=0D0
19166 IF(MINT(47).EQ.1) THEN
19167 DO 110 J=1,5
19168 P(I,J)=P(I-2,J)
19169 110 CONTINUE
19170 ELSEIF(ISUB.EQ.95) THEN
19171 K(I,2)=21
19172 ELSE
19173 P(I,5)=P(IPU,5)
19174
19175C...No primordial kT, or chosen according to truncated Gaussian or
19176C...exponential, or (for photon) predetermined or power law.
19177 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19178 IF(MSTP(91).LE.0) THEN
19179 PT=0D0
19180 ELSEIF(MSTP(91).EQ.1) THEN
19181 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19182 ELSE
19183 RPT1=PYR(0)
19184 RPT2=PYR(0)
19185 PT=-PARP(92)*LOG(RPT1*RPT2)
19186 ENDIF
19187 IF(PT.GT.PARP(93)) GOTO 120
19188 ELSEIF(MINT(106+JT).EQ.3) THEN
19189 PTA=SQRT(VINT(282+JT))
19190 PTB=0D0
19191 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19192 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19193 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19194 RPT1=PYR(0)
19195 RPT2=PYR(0)
19196 PTB=-PARP(99)*LOG(RPT1*RPT2)
19197 ENDIF
19198 IF(PTB.GT.PARP(100)) GOTO 120
19199 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19200 PT=PT*0.8D0**MINT(57)
19201 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19202 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19203 IF(MSTP(93).LE.0) THEN
19204 PT=0D0
19205 ELSEIF(MSTP(93).EQ.1) THEN
19206 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19207 ELSEIF(MSTP(93).EQ.2) THEN
19208 RPT1=PYR(0)
19209 RPT2=PYR(0)
19210 PT=-PARP(99)*LOG(RPT1*RPT2)
19211 ELSEIF(MSTP(93).EQ.3) THEN
19212 HA=PARP(99)**2
19213 HB=PARP(100)**2
19214 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19215 ELSE
19216 HA=PARP(99)**2
19217 HB=PARP(100)**2
19218 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19219 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19220 ENDIF
19221 IF(PT.GT.PARP(100)) GOTO 120
19222 ELSE
19223 PT=0D0
19224 ENDIF
19225 VINT(156+JT)=PT
19226 PHI=PARU(2)*PYR(0)
19227 P(I,1)=PT*COS(PHI)
19228 P(I,2)=PT*SIN(PHI)
19229 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19230 ENDIF
19231 130 CONTINUE
19232 IF(MINT(47).EQ.1) RETURN
19233
19234C...Kinematics construction for initial partons.
19235 I1=MINT(83)+3
19236 I2=MINT(83)+4
19237 IF(ISUB.EQ.95) THEN
19238 SHS=0D0
19239 SHR=0D0
19240 ELSE
19241 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19242 & (P(I1,2)+P(I2,2))**2
19243 SHR=SQRT(MAX(0D0,SHS))
19244 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19245 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19246 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19247 P(I2,4)=SHR-P(I1,4)
19248 P(I2,3)=-P(I1,3)
19249
19250C...Transform partons to overall CM-frame.
19251 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19252 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19253 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19254 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19255 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19256 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19257 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19258 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19259 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19260 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19261 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19262 ENDIF
19263
19264C...Optionally fix up x and Q2 definitions for leptoproduction.
19265 IDISXQ=0
19266 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19267 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19268 IF(IDISXQ.EQ.1) THEN
19269
19270C...Find where incoming and outgoing leptons/partons are sitting.
19271 LESD=1
19272 IF(MINT(42).EQ.1) LESD=2
19273 LPIN=MINT(83)+3-LESD
19274 LEIN=MINT(84)+LESD
19275 LQIN=MINT(84)+3-LESD
19276 LEOUT=MINT(84)+2+LESD
19277 LQOUT=MINT(84)+5-LESD
19278 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19279 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19280 LSCMS=0
19281 DO 140 I=MINT(84)+5,N
19282 IF(K(I,2).EQ.94) THEN
19283 LSCMS=I
19284 LEOUT=I+LESD
19285 LQOUT=I+3-LESD
19286 ENDIF
19287 140 CONTINUE
19288 LQBG=IPU1
19289 IF(LESD.EQ.1) LQBG=IPU2
19290
19291C...Calculate actual and wanted momentum transfer.
19292 XNOM=VINT(43-LESD)
19293 Q2NOM=-VINT(45)
19294 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19295 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19296 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19297 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19298 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19299 P(N+1,1)=FAC*P(LEOUT,1)
19300 P(N+1,2)=FAC*P(LEOUT,2)
19301 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19302 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19303 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19304 & P(N+1,3)**2)
19305 DO 150 J=1,4
19306 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19307 QNEW(J)=P(LEIN,J)-P(N+1,J)
19308 150 CONTINUE
19309
19310C...Boost outgoing electron and daughters.
19311 IF(LSCMS.EQ.0) THEN
19312 DO 160 J=1,4
19313 P(LEOUT,J)=P(N+1,J)
19314 160 CONTINUE
19315 ELSE
19316 DO 170 J=1,3
19317 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19318 170 CONTINUE
19319 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19320 DO 180 J=1,3
19321 DBE(J)=PINV*P(N+2,J)
19322 180 CONTINUE
19323 DO 200 I=LSCMS+1,N
19324 IORIG=I
19325 190 IORIG=K(IORIG,3)
19326 IF(IORIG.GT.LEOUT) GOTO 190
19327 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19328 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19329 200 CONTINUE
19330 ENDIF
19331
19332C...Copy shower initiator and all outgoing partons.
19333 NCOP=N+1
19334 K(NCOP,3)=LQBG
19335 DO 210 J=1,5
19336 P(NCOP,J)=P(LQBG,J)
19337 210 CONTINUE
19338 DO 240 I=MINT(84)+1,N
19339 ICOP=0
19340 IF(K(I,1).GT.10) GOTO 240
19341 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19342 ICOP=I
19343 ELSE
19344 IORIG=I
19345 220 IORIG=K(IORIG,3)
19346 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19347 ICOP=IORIG
19348 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19349 GOTO 220
19350 ENDIF
19351 ENDIF
19352 IF(ICOP.NE.0) THEN
19353 NCOP=NCOP+1
19354 K(NCOP,3)=I
19355 DO 230 J=1,5
19356 P(NCOP,J)=P(I,J)
19357 230 CONTINUE
19358 ENDIF
19359 240 CONTINUE
19360
19361C...Calculate relative rescaling factors.
19362 SLC=3-2*LESD
19363 PLCSUM=0D0
19364 DO 250 I=N+2,NCOP
19365 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19366 250 CONTINUE
19367 DO 260 I=N+2,NCOP
19368 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
19369 260 CONTINUE
19370
19371C...Transfer extra three-momentum of current.
19372 DO 280 I=N+2,NCOP
19373 DO 270 J=1,3
19374 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
19375 270 CONTINUE
19376 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19377 280 CONTINUE
19378
19379C...Iterate change of initiator momentum to get energy right.
19380 ITER=0
19381 290 ITER=ITER+1
19382 PEEX=-P(N+1,4)-QNEW(4)
19383 PEMV=-P(N+1,3)/P(N+1,4)
19384 DO 300 I=N+2,NCOP
19385 PEEX=PEEX+P(I,4)
19386 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
19387 300 CONTINUE
19388 IF(ABS(PEMV).LT.1D-10) THEN
19389 MINT(51)=1
19390 MINT(57)=MINT(57)+1
19391 RETURN
19392 ENDIF
19393 PZCH=-PEEX/PEMV
19394 P(N+1,3)=P(N+1,3)+PZCH
19395 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)
19396 DO 310 I=N+2,NCOP
19397 P(I,3)=P(I,3)+V(I,1)*PZCH
19398 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
19399 310 CONTINUE
19400 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
19401
19402C...Modify momenta in event record.
19403 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
19404 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
19405 IF(ABS(HBE).GE.1D0) THEN
19406 MINT(51)=1
19407 MINT(57)=MINT(57)+1
19408 RETURN
19409 ENDIF
19410 I=MINT(83)+5-LESD
19411 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
19412 DO 330 I=N+1,NCOP
19413 ICOP=K(I,3)
19414 DO 320 J=1,4
19415 P(ICOP,J)=P(I,J)
19416 320 CONTINUE
19417 330 CONTINUE
19418 ENDIF
19419
19420C...Check minimum invariant mass of remnant system(s).
19421 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
19422 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
19423 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19424 PMIN(0)=SQRT(PMS(0))
19425 DO 340 JT=1,2
19426 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
19427 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
19428 PMIN(JT)=0D0
19429 IF(MINT(44+JT).EQ.1) GOTO 340
19430 MINT(105)=MINT(102+JT)
19431 MINT(109)=MINT(106+JT)
19432 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
19433 IF(MINT(51).NE.0) THEN
19434 MINT(57)=MINT(57)+1
19435 RETURN
19436 ENDIF
19437 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
19438 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
19439 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
19440 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
19441 & P(MINT(83)+JT+2,2)**2)
19442 340 CONTINUE
19443 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
19444 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
19445 &PSYS(2,4))) THEN
19446 MINT(51)=1
19447 MINT(57)=MINT(57)+1
19448 RETURN
19449 ENDIF
19450
19451C...Loop over two remnants; skip if none there.
19452 I=NS
19453 DO 410 JT=1,2
19454 ISN(JT)=0
19455 IF(MINT(44+JT).EQ.1) GOTO 410
19456 IF(JT.EQ.1) IPU=IPU1
19457 IF(JT.EQ.2) IPU=IPU2
19458
19459C...Store first remnant parton.
19460 I=I+1
19461 IS(JT)=I
19462 ISN(JT)=1
19463 DO 350 J=1,5
19464 K(I,J)=0
19465 P(I,J)=0D0
19466 V(I,J)=0D0
19467 350 CONTINUE
19468 K(I,1)=1
19469 K(I,2)=KFLSP(JT)
19470 K(I,3)=MINT(83)+JT
19471 P(I,5)=PYMASS(K(I,2))
19472
19473C...First parton colour connections and kinematics.
19474 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
19475 IF(KCOL.EQ.2) THEN
19476 K(I,1)=3
19477 K(I,4)=MSTU(5)*IPU+IPU
19478 K(I,5)=MSTU(5)*IPU+IPU
19479 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19480 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19481 ELSEIF(KCOL.NE.0) THEN
19482 K(I,1)=3
19483 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
19484 K(I,KFLS+3)=IPU
19485 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19486 ENDIF
19487 IF(KFLCH(JT).EQ.0) THEN
19488 P(I,1)=-P(MINT(83)+JT+2,1)
19489 P(I,2)=-P(MINT(83)+JT+2,2)
19490 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19491 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19492 P(I,3)=PSYS(JT,3)
19493 P(I,4)=PSYS(JT,4)
19494
19495C...When extra remnant parton or hadron: store extra remnant.
19496 ELSE
19497 I=I+1
19498 ISN(JT)=2
19499 DO 360 J=1,5
19500 K(I,J)=0
19501 P(I,J)=0D0
19502 V(I,J)=0D0
19503 360 CONTINUE
19504 K(I,1)=1
19505 K(I,2)=KFLCH(JT)
19506 K(I,3)=MINT(83)+JT
19507 P(I,5)=PYMASS(K(I,2))
19508
19509C...Find parton colour connections of extra remnant.
19510 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
19511 IF(KCOL.EQ.2) THEN
19512 K(I,1)=3
19513 K(I,4)=MSTU(5)*IPU+IPU
19514 K(I,5)=MSTU(5)*IPU+IPU
19515 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
19516 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
19517 ELSEIF(KCOL.NE.0) THEN
19518 K(I,1)=3
19519 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
19520 K(I,KFLS+3)=IPU
19521 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
19522 ENDIF
19523
19524C...Relative transverse momentum when two remnants.
19525 LOOP=0
19526 370 LOOP=LOOP+1
19527 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
19528 IF(IABS(MINT(10+JT)).LT.20) THEN
19529 P(I-1,1)=0D0
19530 P(I-1,2)=0D0
19531 ELSE
19532 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
19533 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
19534 ENDIF
19535 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
19536 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
19537 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
19538 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19539
19540C...Meson or baryon; photon as meson. For splitup below.
19541 IMB=1
19542 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
19543
19544C***Relative distribution for electron into two electrons. Temporary!
19545 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
19546 & THEN
19547 CHI(JT)=PYR(0)
19548
19549C...Relative distribution of electron energy into electron plus parton.
19550 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
19551 XHRD=VINT(140+JT)
19552 XE=VINT(154+JT)
19553 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
19554
19555C...Relative distribution of energy for particle into two jets.
19556 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
19557 CHIK=PARP(92+2*IMB)
19558 IF(MSTP(92).LE.1) THEN
19559 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19560 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19561 ELSEIF(MSTP(92).EQ.2) THEN
19562 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
19563 ELSEIF(MSTP(92).EQ.3) THEN
19564 CUT=2D0*0.3D0/VINT(1)
19565 380 CHI(JT)=PYR(0)**2
19566 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
19567 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
19568 ELSEIF(MSTP(92).EQ.4) THEN
19569 CUT=2D0*0.3D0/VINT(1)
19570 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
19571 390 CHIR=CUT*CUTR**PYR(0)
19572 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
19573 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
19574 ELSE
19575 CUT=2D0*0.3D0/VINT(1)
19576 CUTA=CUT**(1D0-PARP(98))
19577 CUTB=(1D0+CUT)**(1D0-PARP(98))
19578 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
19579 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
19580 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
19581 ENDIF
19582
19583C...Relative distribution of energy for particle into jet plus particle.
19584 ELSE
19585 IF(MSTP(94).LE.1) THEN
19586 IF(IMB.EQ.1) CHI(JT)=PYR(0)
19587 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
19588 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19589 ELSEIF(MSTP(94).EQ.2) THEN
19590 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
19591 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
19592 ELSEIF(MSTP(94).EQ.3) THEN
19593 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
19594 CHI(JT)=ZZ
19595 ELSE
19596 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
19597 CHI(JT)=ZZ
19598 ENDIF
19599 ENDIF
19600
19601C...Construct total transverse mass; reject if too large.
19602 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
19603 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
19604 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
19605 IF(LOOP.LT.100) THEN
19606 GOTO 370
19607 ELSE
19608 MINT(51)=1
19609 MINT(57)=MINT(57)+1
19610 RETURN
19611 ENDIF
19612 ENDIF
19613 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
19614 VINT(158+JT)=CHI(JT)
19615
19616C...Subdivide longitudinal momentum according to value selected above.
19617 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
19618 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
19619 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
19620 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
19621 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
19622 ENDIF
19623 410 CONTINUE
19624 N=I
19625
19626C...Check if longitudinal boosts needed - if so pick two systems.
19627 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
19628 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
19629 IF(PDEV.LE.1D-6*VINT(1)) RETURN
19630 IF(ISN(1).EQ.0) THEN
19631 IR=0
19632 IL=2
19633 ELSEIF(ISN(2).EQ.0) THEN
19634 IR=1
19635 IL=0
19636 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
19637 IR=1
19638 IL=2
19639 ELSEIF(VINT(143).GT.0.2D0) THEN
19640 IR=1
19641 IL=0
19642 ELSEIF(VINT(144).GT.0.2D0) THEN
19643 IR=0
19644 IL=2
19645 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
19646 IR=1
19647 IL=0
19648 ELSE
19649 IR=0
19650 IL=2
19651 ENDIF
19652 IG=3-IR-IL
19653
19654C...E+-pL wanted for system to be modified.
19655 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
19656 PPB=VINT(1)
19657 PNB=VINT(1)
19658 ELSE
19659 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
19660 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
19661 ENDIF
19662
19663C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
19664 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
19665 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
19666 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
19667 DO 420 J=1,4
19668 PSYS(0,J)=0D0
19669 420 CONTINUE
19670 DO 450 I=MINT(84)+1,NS
19671 IF(K(I,1).GT.10) GOTO 450
19672 INCL=0
19673 IORIG=I
19674 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19675 IORIG=K(IORIG,3)
19676 IF(IORIG.GT.LPIN) GOTO 430
19677 IF(INCL.EQ.0) GOTO 450
19678 DO 440 J=1,4
19679 PSYS(0,J)=PSYS(0,J)+P(I,J)
19680 440 CONTINUE
19681 450 CONTINUE
19682 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
19683 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
19684 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
19685 ENDIF
19686
19687C...Construct longitudinal boosts.
19688 DPMTB=PPB*PNB
19689 DPMTR=PMS(IR)
19690 DPMTL=PMS(IL)
19691 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
19692 IF(DSQLAM.LE.1D-6*DPMTB) THEN
19693 MINT(51)=1
19694 MINT(57)=MINT(57)+1
19695 RETURN
19696 ENDIF
19697 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
19698 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
19699 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
19700 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
19701 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
19702 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
19703 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
19704
19705C...Perform longitudinal boosts.
19706 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
19707 P(IS(1),3)=0D0
19708 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
19709 ELSEIF(IR.EQ.1) THEN
19710 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
19711 ELSEIF(IDISXQ.EQ.1) THEN
19712 DO 470 I=I1,NS
19713 INCL=0
19714 IORIG=I
19715 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19716 IORIG=K(IORIG,3)
19717 IF(IORIG.GT.LPIN) GOTO 460
19718 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
19719 470 CONTINUE
19720 ELSE
19721 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
19722 ENDIF
19723 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
19724 P(IS(2),3)=0D0
19725 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
19726 ELSEIF(IL.EQ.2) THEN
19727 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
19728 ELSEIF(IDISXQ.EQ.1) THEN
19729 DO 490 I=I1,NS
19730 INCL=0
19731 IORIG=I
19732 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
19733 IORIG=K(IORIG,3)
19734 IF(IORIG.GT.LPIN) GOTO 480
19735 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
19736 490 CONTINUE
19737 ELSE
19738 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
19739 ENDIF
19740
19741C...Final check that energy-momentum conservation worked.
19742 PESUM=0D0
19743 PZSUM=0D0
19744 DO 500 I=MINT(84)+1,N
19745 IF(K(I,1).GT.10) GOTO 500
19746 PESUM=PESUM+P(I,4)
19747 PZSUM=PZSUM+P(I,3)
19748 500 CONTINUE
19749 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
19750 IF(PDEV.GT.1D-4*VINT(1)) THEN
19751 MINT(51)=1
19752 MINT(57)=MINT(57)+1
19753 RETURN
19754 ENDIF
19755
19756C...Calculate rotation and boost from overall CM frame to
19757C...hadronic CM frame in leptoproduction.
19758 MINT(91)=0
19759 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
19760 MINT(91)=1
19761 LESD=1
19762 IF(MINT(42).EQ.1) LESD=2
19763 LPIN=MINT(83)+3-LESD
19764
19765C...Sum upp momenta of everything not lepton or photon to define boost.
19766 DO 510 J=1,4
19767 PSUM(J)=0D0
19768 510 CONTINUE
19769 DO 530 I=1,N
19770 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
19771 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
19772 IF(K(I,2).EQ.22) GOTO 530
19773 DO 520 J=1,4
19774 PSUM(J)=PSUM(J)+P(I,J)
19775 520 CONTINUE
19776 530 CONTINUE
19777 VINT(223)=-PSUM(1)/PSUM(4)
19778 VINT(224)=-PSUM(2)/PSUM(4)
19779 VINT(225)=-PSUM(3)/PSUM(4)
19780
19781C...Boost incoming hadron to hadronic CM frame to determine rotations.
19782 K(N+1,1)=1
19783 DO 540 J=1,5
19784 P(N+1,J)=P(LPIN,J)
19785 V(N+1,J)=V(LPIN,J)
19786 540 CONTINUE
19787 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
19788 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
19789 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
19790 IF(LESD.EQ.2) THEN
19791 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
19792 ELSE
19793 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
19794 ENDIF
19795 ENDIF
19796
19797 RETURN
19798 END
19799
19800C*********************************************************************
19801
19802C...PYMIGN
19803C...Initializes treatment of new multiple interactions scenario,
19804C...selects kinematics of hardest interaction if low-pT physics
19805C...included in run, and generates all non-hardest interactions.
19806
19807 SUBROUTINE PYMIGN(MMUL)
19808
19809C...Double precision and integer declarations.
19810 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19811 IMPLICIT INTEGER(I-N)
19812 INTEGER PYK,PYCHGE,PYCOMP
19813 EXTERNAL PYALPS
19814 DOUBLE PRECISION PYALPS
19815C...Commonblocks.
19816 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19817 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19818 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19819 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
19820 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19821 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19822 COMMON/PYINT1/MINT(400),VINT(400)
19823 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19824 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19825 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19826 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19827 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
19828 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
19829 & XMI(2,240),PT2MI(240),IMISEP(0:240)
19830 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
19831 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
19832C...Local arrays and saved variables.
19833 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
19834 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
19835 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19836 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19837 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19838
19839C...Initialization of multiple interaction treatment.
19840 IF(MMUL.EQ.1) THEN
19841 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19842 ISUB=96
19843 MINT(1)=96
19844 VINT(63)=0D0
19845 VINT(64)=0D0
19846 VINT(143)=1D0
19847 VINT(144)=1D0
19848
19849C...Loop over phase space points: xT2 choice in 20 bins.
19850 100 SIGSUM=0D0
19851 DO 120 IXT2=1,20
19852 NMUL(IXT2)=MSTP(83)
19853 SIGM(IXT2)=0D0
19854 DO 110 ITRY=1,MSTP(83)
19855 RSCA=0.05D0*((21-IXT2)-PYR(0))
19856 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19857 XT2=MAX(0.01D0*VINT(149),XT2)
19858 VINT(25)=XT2
19859
19860C...Choose tau and y*. Calculate cos(theta-hat).
19861 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19862 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19863 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19864 ELSE
19865 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19866 ENDIF
19867 VINT(21)=TAU
19868 CALL PYKLIM(2)
19869 RYST=PYR(0)
19870 MYST=1
19871 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19872 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19873 CALL PYKMAP(2,MYST,PYR(0))
19874 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19875
19876C...Calculate differential cross-section.
19877 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19878 CALL PYSIGH(NCHN,SIGS)
19879 SIGM(IXT2)=SIGM(IXT2)+SIGS
19880 110 CONTINUE
19881 SIGSUM=SIGSUM+SIGM(IXT2)
19882 120 CONTINUE
19883 SIGSUM=SIGSUM/(20D0*MSTP(83))
19884
19885C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19886 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19887 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19888 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19889 PARP(82)=0.9D0*PARP(82)
19890 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19891 & VINT(2)
19892 GOTO 100
19893 ENDIF
19894 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19895 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19896
19897C...Start iteration to find k factor.
19898 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19899 P83A=(1D0-PARP(83))**2
19900 P83B=2D0*PARP(83)*(1D0-PARP(83))
19901 P83C=PARP(83)**2
19902 CQ2I=1D0/PARP(84)**2
19903 CQ2R=2D0/(1D0+PARP(84)**2)
19904 SO=0.5D0
19905 XI=0D0
19906 YI=0D0
19907 XF=0D0
19908 YF=0D0
19909 XK=0.5D0
19910 IIT=0
19911 130 IF(IIT.EQ.0) THEN
19912 XK=2D0*XK
19913 ELSEIF(IIT.EQ.1) THEN
19914 XK=0.5D0*XK
19915 ELSE
19916 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19917 ENDIF
19918
19919C...Evaluate overlap integrals. Find where to divide the b range.
19920 IF(MSTP(82).EQ.2) THEN
19921 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19922 SOP=SP/PARU(1)
19923 ELSE
19924 IF(MSTP(82).EQ.3) THEN
19925 DELTAB=0.02D0
19926 ELSEIF(MSTP(82).EQ.4) THEN
19927 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19928 ELSE
19929 POWIP=MAX(0.4D0,PARP(83))
19930 RPWIP=2D0/POWIP-1D0
19931 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19932 SO=0D0
19933 ENDIF
19934 SP=0D0
19935 SOP=0D0
19936 BSP=0D0
19937 SOHIGH=0D0
19938 IBDIV=0
19939 B=-0.5D0*DELTAB
19940 140 B=B+DELTAB
19941 IF(MSTP(82).EQ.3) THEN
19942 OV=EXP(-B**2)/PARU(2)
19943 ELSEIF(MSTP(82).EQ.4) THEN
19944 OV=(P83A*EXP(-MIN(50D0,B**2))+
19945 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19946 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19947 ELSE
19948 OV=EXP(-B**POWIP)/PARU(2)
19949 SO=SO+PARU(2)*B*DELTAB*OV
19950 ENDIF
19951 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19952 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19953 SP=SP+PARU(2)*B*DELTAB*PACC
19954 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19955 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19956 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19957 IBDIV=1
19958 BDIV=B+0.5D0*DELTAB
19959 ENDIF
19960 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19961 ENDIF
19962 YK=PARU(1)*XK*SO/SP
19963
19964C...Continue iteration until convergence.
19965 IF(YK.LT.YKE) THEN
19966 XI=XK
19967 YI=YK
19968 IF(IIT.EQ.1) IIT=2
19969 ELSE
19970 XF=XK
19971 YF=YK
19972 IF(IIT.EQ.0) IIT=1
19973 ENDIF
19974 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19975
19976C...Store some results for subsequent use.
19977 BAVG=BSP/SP
19978 VINT(145)=SIGSUM
19979 VINT(146)=SOP/SO
19980 VINT(147)=SOP/SP
19981 VNT145=VINT(145)
19982 VNT146=VINT(146)
19983 VNT147=VINT(147)
19984C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19985 PIK=(VNT146/VNT147)*YKE
19986
19987C...Find relative weight for low and high impact parameter..
19988 PLOWB=PARU(1)*BDIV**2
19989 IF(MSTP(82).EQ.3) THEN
19990 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19991 ELSEIF(MSTP(82).EQ.4) THEN
19992 S4A=P83A*EXP(-BDIV**2)
19993 S4B=P83B*EXP(-BDIV**2*CQ2R)
19994 S4C=P83C*EXP(-BDIV**2*CQ2I)
19995 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19996 ELSEIF(PARP(83).GE.1.999D0) THEN
19997 PHIGHB=PIK*SOHIGH
19998 B2RPDV=BDIV**POWIP
19999 ELSE
20000 PHIGHB=PIK*SOHIGH
20001 B2RPDV=BDIV**POWIP
20002 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20003 ENDIF
20004 PALLB=PLOWB+PHIGHB
20005
20006C...Initialize iteration in xT2 for hardest interaction.
20007 ELSEIF(MMUL.EQ.2) THEN
20008 VINT(145)=VNT145
20009 VINT(146)=VNT146
20010 VINT(147)=VNT147
20011 IF(MSTP(82).LE.0) THEN
20012 ELSEIF(MSTP(82).EQ.1) THEN
20013 XT2=1D0
20014 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20015 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20016 & VINT(317)/(VINT(318)*VINT(320))
20017 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20018 ELSEIF(MSTP(82).EQ.2) THEN
20019 XT2=1D0
20020 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20021 & VINT(149)*(1D0+VINT(149))
20022 ELSE
20023 XC2=4D0*CKIN(3)**2/VINT(2)
20024 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20025 ENDIF
20026
20027C...Select impact parameter for hardest interaction.
20028 IF(MSTP(82).LE.2) RETURN
20029 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20030C...Treatment in low b region.
20031 MINT(39)=1
20032 B=BDIV*SQRT(PYR(0))
20033 IF(MSTP(82).EQ.3) THEN
20034 OV=EXP(-B**2)/PARU(2)
20035 ELSEIF(MSTP(82).EQ.4) THEN
20036 OV=(P83A*EXP(-MIN(50D0,B**2))+
20037 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20038 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20039 ELSE
20040 OV=EXP(-B**POWIP)/PARU(2)
20041 ENDIF
20042 VINT(148)=OV/VNT147
20043 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20044 XT2=1D0
20045 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20046 & VINT(149)*(1D0+VINT(149))
20047 ELSE
20048C...Treatment in high b region.
20049 MINT(39)=2
20050 IF(MSTP(82).EQ.3) THEN
20051 B=SQRT(BDIV**2-LOG(PYR(0)))
20052 OV=EXP(-B**2)/PARU(2)
20053 ELSEIF(MSTP(82).EQ.4) THEN
20054 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20055 IF(S4RNDM.LT.S4A) THEN
20056 B=SQRT(BDIV**2-LOG(PYR(0)))
20057 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20058 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20059 ELSE
20060 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20061 ENDIF
20062 OV=(P83A*EXP(-MIN(50D0,B**2))+
20063 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20064 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20065 ELSEIF(PARP(83).GE.1.999D0) THEN
20066 144 B2RPW=B2RPDV-LOG(PYR(0))
20067 ACCIP=(B2RPW/B2RPDV)**RPWIP
20068 IF(ACCIP.LT.PYR(0)) GOTO 144
20069 OV=EXP(-B2RPW)/PARU(2)
20070 B=B2RPW**(1D0/POWIP)
20071 ELSE
20072 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20073 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20074 IF(ACCIP.LT.PYR(0)) GOTO 146
20075 OV=EXP(-B2RPW)/PARU(2)
20076 B=B2RPW**(1D0/POWIP)
20077 ENDIF
20078 VINT(148)=OV/VNT147
20079 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20080 ENDIF
20081 IF(PACC.LT.PYR(0)) GOTO 142
20082 VINT(139)=B/BAVG
20083
20084 ELSEIF(MMUL.EQ.3) THEN
20085C...Low-pT or multiple interactions (first semihard interaction):
20086C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20087C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20088 ISUB=MINT(1)
20089 VINT(145)=VNT145
20090 VINT(146)=VNT146
20091 VINT(147)=VNT147
20092 IF(MSTP(82).LE.0) THEN
20093 XT2=0D0
20094 ELSEIF(MSTP(82).EQ.1) THEN
20095 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20096C...Use with "Sudakov" for low b values when impact parameter dependence.
20097 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20098 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20099 & VINT(149)))).GT.PYR(0)) XT2=1D0
20100 IF(XT2.GE.1D0) THEN
20101 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20102 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20103 & VINT(149)
20104 ELSE
20105 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20106 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20107 & VINT(149)
20108 ENDIF
20109 XT2=MAX(0.01D0*VINT(149),XT2)
20110C...Use without "Sudakov" for high b values when impact parameter dep.
20111 ELSE
20112 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20113 & PYR(0)*(1D0-XC2))-VINT(149)
20114 XT2=MAX(0.01D0*VINT(149),XT2)
20115 ENDIF
20116 VINT(25)=XT2
20117
20118C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20119 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20120 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20121 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20122 ISUB=95
20123 MINT(1)=ISUB
20124 VINT(21)=1D-12*VINT(149)
20125 VINT(22)=0D0
20126 VINT(23)=0D0
20127 VINT(25)=1D-12*VINT(149)
20128
20129 ELSE
20130C...Multiple interactions (first semihard interaction).
20131C...Choose tau and y*. Calculate cos(theta-hat).
20132 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20133 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20134 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20135 ELSE
20136 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20137 ENDIF
20138 VINT(21)=TAU
20139 CALL PYKLIM(2)
20140 RYST=PYR(0)
20141 MYST=1
20142 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20143 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20144 CALL PYKMAP(2,MYST,PYR(0))
20145 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20146 ENDIF
20147 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20148
20149C...Store results of cross-section calculation.
20150 ELSEIF(MMUL.EQ.4) THEN
20151 ISUB=MINT(1)
20152 VINT(145)=VNT145
20153 VINT(146)=VNT146
20154 VINT(147)=VNT147
20155 XTS=VINT(25)
20156 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20157 IF(ISET(ISUB).EQ.2)
20158 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20159 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20160 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20161 & (XTS+VINT(149))))
20162 IRBIN=INT(1D0+20D0*RBIN)
20163 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20164 NMUL(IRBIN)=NMUL(IRBIN)+1
20165 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20166 ENDIF
20167
20168C...Choose impact parameter if not already done.
20169 ELSEIF(MMUL.EQ.5) THEN
20170 ISUB=MINT(1)
20171 VINT(145)=VNT145
20172 VINT(146)=VNT146
20173 VINT(147)=VNT147
20174 150 IF(MINT(39).GT.0) THEN
20175 ELSEIF(MSTP(82).EQ.3) THEN
20176 EXPB2=PYR(0)
20177 B2=-LOG(PYR(0))
20178 VINT(148)=EXPB2/(PARU(2)*VNT147)
20179 VINT(139)=SQRT(B2)/BAVG
20180 ELSEIF(MSTP(82).EQ.4) THEN
20181 RTYPE=PYR(0)
20182 IF(RTYPE.LT.P83A) THEN
20183 B2=-LOG(PYR(0))
20184 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20185 B2=-LOG(PYR(0))/CQ2R
20186 ELSE
20187 B2=-LOG(PYR(0))/CQ2I
20188 ENDIF
20189 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20190 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20191 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20192 VINT(139)=SQRT(B2)/BAVG
20193 ELSEIF(PARP(83).GE.1.999D0) THEN
20194 POWIP=MAX(2D0,PARP(83))
20195 RPWIP=2D0/POWIP-1D0
20196 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20197 160 IF(PYR(0).LT.PROB1) THEN
20198 B2RPW=PYR(0)**(0.5D0*POWIP)
20199 ACCIP=EXP(-B2RPW)
20200 ELSE
20201 B2RPW=1D0-LOG(PYR(0))
20202 ACCIP=B2RPW**RPWIP
20203 ENDIF
20204 IF(ACCIP.LT.PYR(0)) GOTO 160
20205 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20206 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20207 ELSE
20208 POWIP=MAX(0.4D0,PARP(83))
20209 RPWIP=2D0/POWIP-1D0
20210 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20211 170 IF(PYR(0).LT.PROB1) THEN
20212 B2RPW=2D0*RPWIP*PYR(0)
20213 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20214 ELSE
20215 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20216 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20217 ENDIF
20218 IF(ACCIP.LT .PYR(0)) GOTO 170
20219 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20220 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20221 ENDIF
20222
20223C...Multiple interactions (variable impact parameter) : reject with
20224C...probability exp(-overlap*cross-section above pT/normalization).
20225C...Does not apply to low-b region, where "Sudakov" already included.
20226 VINT(150)=1D0
20227 IF(MINT(39).NE.1) THEN
20228 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20229 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20230 DO 180 IBIN=IRBIN+1,20
20231 RNCOR=RNCOR+NMUL(IBIN)
20232 SIGCOR=SIGCOR+SIGM(IBIN)
20233 180 CONTINUE
20234 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20235 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20236 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20237 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20238 ENDIF
20239 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20240 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20241 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20242 IF(VINT(150).LT.PYR(0)) GOTO 150
20243 VINT(150)=1D0
20244 ENDIF
20245
20246C...Generate additional multiple semihard interactions.
20247 ELSEIF(MMUL.EQ.6) THEN
20248
20249C...Save data for hardest initeraction, to be restored.
20250 ISUBSV=MINT(1)
20251 VINT(145)=VNT145
20252 VINT(146)=VNT146
20253 VINT(147)=VNT147
20254 M13SV=MINT(13)
20255 M14SV=MINT(14)
20256 M15SV=MINT(15)
20257 M16SV=MINT(16)
20258 M21SV=MINT(21)
20259 M22SV=MINT(22)
20260 DO 190 J=11,80
20261 VINTSV(J)=VINT(J)
20262 190 CONTINUE
20263 V141SV=VINT(141)
20264 V142SV=VINT(142)
20265
20266C...Store data on hardest interaction.
20267 XMI(1,1)=VINT(141)
20268 XMI(2,1)=VINT(142)
20269 PT2MI(1)=VINT(54)
20270 IMISEP(0)=MINT(84)
20271 IMISEP(1)=N
20272
20273C...Change process to generate; sum of x values so far.
20274 ISUB=96
20275 MINT(1)=96
20276 VINT(143)=1D0-VINT(141)
20277 VINT(144)=1D0-VINT(142)
20278 VINT(151)=0D0
20279 VINT(152)=0D0
20280
20281C...Initialize factors for PDF reshaping.
20282 DO 230 JS=1,2
20283 KFBEAM=MINT(10+JS)
20284 KFABM=IABS(KFBEAM)
20285 KFSBM=ISIGN(1,KFBEAM)
20286
20287C...Zero flavour content of incoming beam particle.
20288 KFIVAL(JS,1)=0
20289 KFIVAL(JS,2)=0
20290 KFIVAL(JS,3)=0
20291C...Flavour content of baryon.
20292 IF(KFABM.GT.1000) THEN
20293 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20294 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20295 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20296C...Flavour content of pi+-, K+-.
20297 ELSEIF(KFABM.EQ.211) THEN
20298 KFIVAL(JS,1)=KFSBM*2
20299 KFIVAL(JS,2)=-KFSBM
20300 ELSEIF(KFABM.EQ.321) THEN
20301 KFIVAL(JS,1)=-KFSBM*3
20302 KFIVAL(JS,2)=KFSBM*2
20303C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20304 ENDIF
20305
20306C...Zero initial valence and companion content.
20307 DO 200 IFL=-6,6
20308 NVC(JS,IFL)=0
20309 200 CONTINUE
20310
20311C...Initiate listing of all incoming partons from two sides.
20312 NMI(JS)=0
20313 DO 210 I=MINT(84)+1,N
20314 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20315 IMI(JS,1,1)=I
20316 IMI(JS,1,2)=0
20317 ENDIF
20318 210 CONTINUE
20319
20320C...Decide whether quarks in hard scattering were valence or sea.
20321 IFL=K(IMI(JS,1,1),2)
20322 IF (IABS(IFL).GT.6) GOTO 230
20323
20324C...Get PDFs at X and Q2 of the parton shower initiator for the
20325C...hard scattering.
20326 X=VINT(140+JS)
20327 IF(MSTP(61).GE.1) THEN
20328 Q2=PARP(62)**2
20329 ELSE
20330 Q2=VINT(54)
20331 ENDIF
20332C...Note: XPSVC = x*pdf.
20333 MINT(30)=JS
20334 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20335 SEA=XPSVC(IFL,-1)
20336 VAL=XPSVC(IFL,0)
20337
20338C...Decide (Extra factor x cancels in the division).
20339 RVCS=PYR(0)*(SEA+VAL)
20340 IVNOW=1
20341 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20342C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20343 IVNOW=0
20344 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20345 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20346 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20347 IF(KFIVAL(JS,1).EQ.0) THEN
20348 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20349 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20350 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20351 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20352 ENDIF
20353 IF(IVNOW.EQ.0) GOTO 220
20354C...Mark valence.
20355 IMI(JS,1,2)=0
20356C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20357 IF(KFIVAL(JS,1).EQ.0) THEN
20358 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20359 KFIVAL(JS,1)=IFL
20360 KFIVAL(JS,2)=-IFL
20361 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20362 KFIVAL(JS,1)=IFL
20363 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20364 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20365 ENDIF
20366 ENDIF
20367
20368C...If sea, add opposite sign companion parton. Store X and I.
20369 ELSE
20370 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20371 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20372C...Set pointer to companion
20373 IMI(JS,1,2)=-NVC(JS,-IFL)
20374 ENDIF
20375 230 CONTINUE
20376
20377C...Update counter number of multiple interactions.
20378 NMI(1)=1
20379 NMI(2)=1
20380
20381C...Set up starting values for iteration in xT2.
20382 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
20383 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
20384 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
20385 & ISUBSV.NE.96)) THEN
20386 XT2=(1D0-VINT(141))*(1D0-VINT(142))
20387 ELSE
20388 XT2=VINT(25)
20389 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
20390 IF(ISET(ISUBSV).EQ.2)
20391 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20392 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
20393 ENDIF
20394 IF(MSTP(82).LE.1) THEN
20395 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20396 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20397 & VINT(317)/(VINT(318)*VINT(320))
20398 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20399 ELSE
20400 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20401 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20402 ENDIF
20403 VINT(63)=0D0
20404 VINT(64)=0D0
20405
20406C...Iterate downwards in xT2.
20407 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
20408 XT2=0D0
20409 GOTO 440
20410 ELSEIF(MSTP(82).LE.1) THEN
20411 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20412 IF(XT2.LT.VINT(149)) GOTO 440
20413 ELSE
20414 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
20415 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20416 & LOG(PYR(0)))-VINT(149)
20417 IF(XT2.LE.0D0) GOTO 440
20418 XT2=MAX(0.01D0*VINT(149),XT2)
20419 ENDIF
20420 VINT(25)=XT2
20421
20422C...Choose tau and y*. Calculate cos(theta-hat).
20423 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20424 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20425 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20426 ELSE
20427 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20428 ENDIF
20429 VINT(21)=TAU
20430C...New: require shat > 1.
20431 IF(TAU*VINT(2).LT.1D0) GOTO 240
20432 CALL PYKLIM(2)
20433 RYST=PYR(0)
20434 MYST=1
20435 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20436 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20437 CALL PYKMAP(2,MYST,PYR(0))
20438 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20439
20440C...Check that x not used up. Accept or reject kinematical variables.
20441 X1M=SQRT(TAU)*EXP(VINT(22))
20442 X2M=SQRT(TAU)*EXP(-VINT(22))
20443 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
20444 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20445 CALL PYSIGH(NCHN,SIGS)
20446 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20447 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
20448 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
20449
20450C...Reset K, P and V vectors.
20451 DO 260 I=N+1,N+4
20452 DO 250 J=1,5
20453 K(I,J)=0
20454 P(I,J)=0D0
20455 V(I,J)=0D0
20456 250 CONTINUE
20457 260 CONTINUE
20458 PT=0.5D0*VINT(1)*SQRT(XT2)
20459
20460C...Choose flavour of reacting partons (and subprocess).
20461 RSIGS=SIGS*PYR(0)
20462 DO 270 ICHN=1,NCHN
20463 KFL1=ISIG(ICHN,1)
20464 KFL2=ISIG(ICHN,2)
20465 ICONMI=ISIG(ICHN,3)
20466 RSIGS=RSIGS-SIGH(ICHN)
20467 IF(RSIGS.LE.0D0) GOTO 280
20468 270 CONTINUE
20469
20470C...Reassign to appropriate process codes.
20471 280 ISUBMI=ICONMI/10
20472 ICONMI=MOD(ICONMI,10)
20473
20474C...Choose new quark flavour for annihilation graphs
20475 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
20476 SH=TAU*VINT(2)
20477 CALL PYWIDT(21,SH,WDTP,WDTE)
20478 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
20479 DO 300 I=1,MDCY(21,3)
20480 KFLF=KFDP(I+MDCY(21,2)-1,1)
20481 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
20482 IF(RKFL.LE.0D0) GOTO 310
20483 300 CONTINUE
20484 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
20485 IF(KFLF.GE.4) GOTO 290
20486 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
20487 KFLF=4
20488 ICONMI=ICONMI-2
20489 ELSEIF(ISUBMI.EQ.53) THEN
20490 KFLF=5
20491 ICONMI=ICONMI-4
20492 ENDIF
20493 ENDIF
20494
20495C...Final state flavours and colour flow: default values
20496 JS=1
20497 KFL3=KFL1
20498 KFL4=KFL2
20499 KCC=20
20500 KCS=ISIGN(1,KFL1)
20501
20502 IF(ISUBMI.EQ.11) THEN
20503C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
20504 KCC=ICONMI
20505 IF(KFL1*KFL2.LT.0) KCC=KCC+2
20506
20507 ELSEIF(ISUBMI.EQ.12) THEN
20508C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
20509 KFL3=ISIGN(KFLF,KFL1)
20510 KFL4=-KFL3
20511 KCC=4
20512
20513 ELSEIF(ISUBMI.EQ.13) THEN
20514C...f + fbar -> g + g; th arbitrary
20515 KFL3=21
20516 KFL4=21
20517 KCC=ICONMI+4
20518
20519 ELSEIF(ISUBMI.EQ.28) THEN
20520C...f + g -> f + g; th = (p(f)-p(f))**2
20521 IF(KFL1.EQ.21) JS=2
20522 KCC=ICONMI+6
20523 IF(KFL1.EQ.21) KCC=KCC+2
20524 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
20525 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
20526
20527 ELSEIF(ISUBMI.EQ.53) THEN
20528C...g + g -> f + fbar; th arbitrary
20529 KCS=(-1)**INT(1.5D0+PYR(0))
20530 KFL3=ISIGN(KFLF,KCS)
20531 KFL4=-KFL3
20532 KCC=ICONMI+10
20533
20534 ELSEIF(ISUBMI.EQ.68) THEN
20535C...g + g -> g + g; th arbitrary
20536 KCC=ICONMI+12
20537 KCS=(-1)**INT(1.5D0+PYR(0))
20538 ENDIF
20539
20540C...Store flavours of scattering.
20541 MINT(13)=KFL1
20542 MINT(14)=KFL2
20543 MINT(15)=KFL1
20544 MINT(16)=KFL2
20545 MINT(21)=KFL3
20546 MINT(22)=KFL4
20547
20548C...Set flavours and mothers of scattering partons.
20549 K(N+1,1)=14
20550 K(N+2,1)=14
20551 K(N+3,1)=3
20552 K(N+4,1)=3
20553 K(N+1,2)=KFL1
20554 K(N+2,2)=KFL2
20555 K(N+3,2)=KFL3
20556 K(N+4,2)=KFL4
20557 K(N+1,3)=MINT(83)+1
20558 K(N+2,3)=MINT(83)+2
20559 K(N+3,3)=N+1
20560 K(N+4,3)=N+2
20561
20562C...Store colour connection indices.
20563 DO 320 J=1,2
20564 JC=J
20565 IF(KCS.EQ.-1) JC=3-J
20566 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
20567 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
20568 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
20569 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
20570 320 CONTINUE
20571
20572C...Store incoming and outgoing partons in their CM-frame.
20573 SHR=SQRT(TAU)*VINT(1)
20574 P(N+1,3)=0.5D0*SHR
20575 P(N+1,4)=0.5D0*SHR
20576 P(N+2,3)=-0.5D0*SHR
20577 P(N+2,4)=0.5D0*SHR
20578 P(N+3,5)=PYMASS(K(N+3,2))
20579 P(N+4,5)=PYMASS(K(N+4,2))
20580 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
20581 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
20582 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
20583 P(N+4,4)=SHR-P(N+3,4)
20584 P(N+4,3)=-P(N+3,3)
20585
20586C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
20587 PHI=PARU(2)*PYR(0)
20588 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
20589
20590C...Set up default values before showers.
20591 MINT(31)=MINT(31)+1
20592 IPU1=N+1
20593 IPU2=N+2
20594 IPU3=N+3
20595 IPU4=N+4
20596 VINT(141)=VINT(41)
20597 VINT(142)=VINT(42)
20598 N=N+4
20599
20600C...Showering of initial state partons (optional).
20601C...Note: no showering of final state partons here; it comes later.
20602 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20603 MINT(51)=0
20604 ALAMSV=PARJ(81)
20605 PARJ(81)=PARP(72)
20606 NSAV=N
20607 DO 340 I=1,4
20608 DO 330 J=1,5
20609 KSAV(I,J)=K(N-4+I,J)
20610 PSAV(I,J)=P(N-4+I,J)
20611 330 CONTINUE
20612 340 CONTINUE
20613 CALL PYSSPA(IPU1,IPU2)
20614 PARJ(81)=ALAMSV
20615C...If shower failed then restore to situation before shower.
20616 IF(MINT(51).GE.1) THEN
20617 N=NSAV
20618 DO 360 I=1,4
20619 DO 350 J=1,5
20620 K(N-4+I,J)=KSAV(I,J)
20621 P(N-4+I,J)=PSAV(I,J)
20622 350 CONTINUE
20623 360 CONTINUE
20624 IPU1=N-3
20625 IPU2=N-2
20626 VINT(141)=VINT(41)
20627 VINT(142)=VINT(42)
20628 ENDIF
20629 ENDIF
20630
20631C...Keep track of loose colour ends and information on scattering.
20632 370 IMI(1,MINT(31),1)=IPU1
20633 IMI(2,MINT(31),1)=IPU2
20634 IMI(1,MINT(31),2)=0
20635 IMI(2,MINT(31),2)=0
20636 XMI(1,MINT(31))=VINT(141)
20637 XMI(2,MINT(31))=VINT(142)
20638 PT2MI(MINT(31))=VINT(54)
20639 IMISEP(MINT(31))=N
20640
20641C...Decide whether quarks in last scattering were valence, companion or
20642C...sea.
20643 DO 430 JS=1,2
20644 KFBEAM=MINT(10+JS)
20645 KFSBM=ISIGN(1,MINT(10+JS))
20646 IFL=K(IMI(JS,MINT(31),1),2)
20647 IMI(JS,MINT(31),2)=0
20648 IF (IABS(IFL).GT.6) GOTO 430
20649
20650C...Get PDFs at X and Q2 of the parton shower initiator for the
20651C...last scattering. At this point VINT(143:144) do not yet
20652C...include the scattered x values VINT(141:142).
20653 X=VINT(140+JS)/VINT(142+JS)
20654 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
20655 Q2=PARP(62)**2
20656 ELSE
20657 Q2=VINT(54)
20658 ENDIF
20659C...Note: XPSVC = x*pdf.
20660 MINT(30)=JS
20661 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20662 SEA=XPSVC(IFL,-1)
20663 VAL=XPSVC(IFL,0)
20664 CMP=0D0
20665 DO 380 IVC=1,NVC(JS,IFL)
20666 CMP=CMP+XPSVC(IFL,IVC)
20667 380 CONTINUE
20668
20669C...Decide (Extra factor x cancels in the dvision).
20670 RVCS=PYR(0)*(SEA+VAL+CMP)
20671 IVNOW=1
20672 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20673C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20674 IVNOW=0
20675 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20676 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20677 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20678 IF(KFIVAL(JS,1).EQ.0) THEN
20679 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20680 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20681 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20682 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20683 ELSE
20684 DO 400 I1=1,NMI(JS)
20685 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
20686 & IVNOW=IVNOW-1
20687 400 CONTINUE
20688 ENDIF
20689 IF(IVNOW.EQ.0) GOTO 390
20690C...Mark valence.
20691 IMI(JS,MINT(31),2)=0
20692C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20693 IF(KFIVAL(JS,1).EQ.0) THEN
20694 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20695 KFIVAL(JS,1)=IFL
20696 KFIVAL(JS,2)=-IFL
20697 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20698 KFIVAL(JS,1)=IFL
20699 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
20700 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
20701 ENDIF
20702 ENDIF
20703
20704 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
20705C...If sea, add opposite sign companion parton. Store X and I.
20706 NVC(JS,-IFL)=NVC(JS,-IFL)+1
20707 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
20708C...Set pointer to companion
20709 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
20710 ELSE
20711C...If companion, decide which one.
20712 CMPSUM=VAL+SEA
20713 ISEL=0
20714 410 ISEL=ISEL+1
20715 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
20716 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
20717C...Find original sea (anti-)quark:
20718 IASSOC=0
20719 DO 420 I1=1,NMI(JS)
20720 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
20721 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
20722 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
20723 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
20724 ENDIF
20725 420 CONTINUE
20726C...Change X to what associated companion had, so that the correct
20727C...amount of momentum can be subtracted from the companion sum below.
20728 X=XASSOC(JS,IFL,ISEL)
20729C...Mark companion read.
20730 XASSOC(JS,IFL,ISEL)=0D0
20731 ENDIF
20732 430 CONTINUE
20733
20734C...Global statistics.
20735 MINT(351)=MINT(351)+1
20736 VINT(351)=VINT(351)+PT
20737 IF (MINT(351).EQ.1) VINT(356)=PT
20738
20739C...Update remaining energy and other counters.
20740 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20741 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
20742 MINT(51)=1
20743 RETURN
20744 ENDIF
20745 NMI(1)=NMI(1)+1
20746 NMI(2)=NMI(2)+1
20747 VINT(151)=VINT(151)+VINT(41)
20748 VINT(152)=VINT(152)+VINT(42)
20749 VINT(143)=VINT(143)-VINT(141)
20750 VINT(144)=VINT(144)-VINT(142)
20751
20752C...Iterate, with more interactions allowed.
20753 IF(MINT(31).LT.240) GOTO 240
20754 440 CONTINUE
20755
20756C...Restore saved quantities for hardest interaction.
20757 MINT(1)=ISUBSV
20758 MINT(13)=M13SV
20759 MINT(14)=M14SV
20760 MINT(15)=M15SV
20761 MINT(16)=M16SV
20762 MINT(21)=M21SV
20763 MINT(22)=M22SV
20764 DO 450 J=11,80
20765 VINT(J)=VINTSV(J)
20766 450 CONTINUE
20767 VINT(141)=V141SV
20768 VINT(142)=V142SV
20769
20770 ENDIF
20771
20772C...Format statements for printout.
20773 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
20774 &'actions for MSTP(82) =',I2,' ******')
20775 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20776 &D9.2,' mb: rejected')
20777 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20778 &D9.2,' mb: accepted')
20779
20780 RETURN
20781 END
20782
20783C*********************************************************************
20784
20785C...PYMIHK
20786C...Finds left-behind remnant flavour content and hooks up
20787C...the colour flow between the hard scattering and remnants
20788
20789 SUBROUTINE PYMIHK
20790
20791C...Double precision and integer declarations.
20792 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20793 IMPLICIT INTEGER(I-N)
20794 INTEGER PYK,PYCHGE,PYCOMP
20795C...The event record
20796 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20797C...Parameters
20798 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20799 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20800 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20801 COMMON/PYINT1/MINT(400),VINT(400)
20802C...The common block of dangling ends
20803 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20804 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20805 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20806 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
20807C...Local variables
20808 PARAMETER (NERSIZ=4000)
20809 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
20810 & ,MACCPT
20811 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
20812 SAVE /PYCBLS/,/PYCTAG/
20813 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
20814 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
20815 DATA NERRPR/0/
20816 SAVE NERRPR
20817 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)
20818
20819C...Set up error checkers
20820 IBOOST=0
20821
20822C...Initialize colour arrays: MCO (Original) and MCT (New)
20823 DO 110 I=MINT(84)+1,NERSIZ
20824 DO 100 JC=1,2
20825 MCT(I,JC)=0
20826 MCO(I,JC)=0
20827 100 CONTINUE
20828C...Also zero colour tracing information, if existed.
20829 IF (I.LE.N) THEN
20830 K(I,4)=MOD(K(I,4),MSTU(5)**2)
20831 K(I,5)=MOD(K(I,5),MSTU(5)**2)
20832 ENDIF
20833 110 CONTINUE
20834
20835C...Initialize colour tag collapse arrays:
20836C...JCCO (Original) and JCCN (New).
20837 DO 130 MG=MINT(84)+1,NERSIZ
20838 DO 120 JC=1,2
20839 JCCO(MG,JC)=0
20840 JCCN(MG,JC)=0
20841 120 CONTINUE
20842 130 CONTINUE
20843
20844C...Zero gluon insertion array
20845 DO 150 IM=1,1000
20846 DO 140 J=1,3
20847 INSR(IM,J)=0
20848 140 CONTINUE
20849 150 CONTINUE
20850
20851C...Compute hard scattering system rapidities
20852 IF (MSTP(89).EQ.1) THEN
20853 DO 160 IM=1,240
20854 IF (IM.LE.MINT(31)) THEN
20855 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
20856 ELSE
20857C...Set (unsigned) rapidity = 100 for beam remnant systems.
20858 YMI(IM)=100D0
20859 ENDIF
20860 160 CONTINUE
20861 ENDIF
20862
20863C...Treat each side separately
20864 DO 290 JS=1,2
20865
20866C...Initialize side.
20867 NG(JS)=0
20868 JV=0
20869 KFS=ISIGN(1,MINT(10+JS))
20870
20871C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
20872 IF(KFIVAL(JS,1).EQ.0) THEN
20873 IF(MINT(10+JS).EQ.111) THEN
20874 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
20875 KFIVAL(JS,2)=-KFIVAL(JS,1)
20876 ELSEIF(MINT(10+JS).EQ.22) THEN
20877 PYRKF=PYR(0)
20878 KFIVAL(JS,1)=1
20879 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
20880 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
20881 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
20882 KFIVAL(JS,2)=-KFIVAL(JS,1)
20883 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
20884 IF(PYR(0).GT.0.5D0) THEN
20885 KFIVAL(JS,1)=1
20886 KFIVAL(JS,2)=-3
20887 ELSE
20888 KFIVAL(JS,1)=3
20889 KFIVAL(JS,2)=-1
20890 ENDIF
20891 ENDIF
20892 ENDIF
20893
20894C...Initialize beam remnant sea and valence content flavour by flavour.
20895 NVSUM(JS)=0
20896 NBRTOT(JS)=0
20897 DO 210 JFA=1,6
20898C...Count up original number of JFA valence quarks and antiquarks.
20899 NVALQ=0
20900 NVALQB=0
20901 NSEA=0
20902 DO 170 J=1,3
20903 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
20904 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
20905 170 CONTINUE
20906 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
20907C...Subtract kicked out valence and determine sea from flavour cons.
20908 DO 180 IM=1,NMI(JS)
20909 IFL = K(IMI(JS,IM,1),2)
20910 IFA = IABS(IFL)
20911 IFS = ISIGN(1,IFL)
20912 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20913C...Subtract K.O. valence quark from remainder.
20914 NVALQ=NVALQ-1
20915 JV=NVSUM(JS)-NVALQ-NVALQB
20916 IV(JS,JV)=IMI(JS,IM,1)
20917 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
20918C...Subtract K.O. valence antiquark from remainder.
20919 NVALQB=NVALQB-1
20920 JV=NVSUM(JS)-NVALQ-NVALQB
20921 IV(JS,JV)=IMI(JS,IM,1)
20922 ELSEIF (IFA.EQ.JFA) THEN
20923C...Outside sea without companion: add opposite sea flavour inside.
20924 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
20925 ENDIF
20926 180 CONTINUE
20927C...Check if space left in PYJETS for additional BR flavours
20928 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
20929 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
20930 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
20931 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
20932 MINT(51)=1
20933 RETURN
20934 ENDIF
20935C...Add required val+sea content to beam remnant.
20936 IF (NFLSUM.GT.0) THEN
20937 DO 200 IA=1,NFLSUM
20938C...Insert beam remnant quark as p.t. symbolic parton in ER.
20939 N=N+1
20940 DO 190 IX=1,5
20941 K(N,IX)=0
20942 P(N,IX)=0D0
20943 V(N,IX)=0D0
20944 190 CONTINUE
20945 K(N,1)=3
20946 K(N,2)=ISIGN(JFA,NSEA)
20947 IF (IA.LE.NVALQ) K(N,2)=JFA
20948 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
20949 K(N,3)=MINT(83)+JS
20950C...Also update NMI, IMI, and IV arrays.
20951 NMI(JS)=NMI(JS)+1
20952 IMI(JS,NMI(JS),1)=N
20953 IMI(JS,NMI(JS),2)=-1
20954 IF (IA.LE.NVALQ+NVALQB) THEN
20955 IMI(JS,NMI(JS),2)=0
20956 JV=JV+1
20957 IV(JS,JV)=IMI(JS,NMI(JS),1)
20958 ENDIF
20959 200 CONTINUE
20960 ENDIF
20961 210 CONTINUE
20962
20963 IM=0
20964 220 IM=IM+1
20965 IF (IM.LE.NMI(JS)) THEN
20966 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
20967 NG(JS)=NG(JS)+1
20968C...Add fictitious parent gluons for companion pairs.
20969 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
20970C...Randomly assign companions to sea quarks which have none.
20971 IF (IMI(JS,IM,2).LT.0) THEN
20972 IMC=PYR(0)*NMI(JS)
20973 230 IMC=MOD(IMC,NMI(JS))+1
20974 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
20975 IF (IMI(JS,IMC,2).GE.0) GOTO 230
20976 IMI(JS, IM,2) = IMI(JS,IMC,1)
20977 IMI(JS,IMC,2) = IMI(JS, IM,1)
20978 ENDIF
20979C...Add fictitious parent gluon
20980 N=N+1
20981 DO 240 IX=1,5
20982 K(N,IX)=0
20983 P(N,IX)=0D0
20984 V(N,IX)=0D0
20985 240 CONTINUE
20986 K(N,1)=14
20987 K(N,2)=21
20988 K(N,3)=MINT(83)+JS
20989C...Set gluon (anti-)colour daughter pointers
20990 K(N,4)=IMI(JS, IM,1)
20991 K(N,5)=IMI(JS, IM,2)
20992C...Set quark (anti-)colour parent pointers
20993 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
20994 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
20995C...Add gluon to IMI
20996 NMI(JS)=NMI(JS)+1
20997 IMI(JS,NMI(JS),1)=N
20998 IMI(JS,NMI(JS),2)=0
20999 ENDIF
21000 GOTO 220
21001 ENDIF
21002
21003C...If incoming (anti-)baryon, insert inside (anti-)junction.
21004C...Set up initial v-v-j-v configuration. Otherwise set up
21005C...mesonic v-vbar configuration
21006 IF (IABS(MINT(10+JS)).GT.1000) THEN
21007C...Determine junction type (1: B=1 2: B=-1)
21008 ITJUNC(JS) = (3-KFS)/2
21009C...Insert junction.
21010 N=N+1
21011 DO 250 IX=1,5
21012 K(N,IX)=0
21013 P(N,IX)=0D0
21014 V(N,IX)=0D0
21015 250 CONTINUE
21016C...Set special junction codes:
21017 K(N,1)=42
21018 K(N,2)=88
21019C...Set parent to side.
21020 K(N,3)=MINT(83)+JS
21021 K(N,4)=ITJUNC(JS)*MSTU(5)
21022 K(N,5)=0
21023C...Connect valence quarks to junction.
21024 MOUT(JS)=0
21025 MANTI=ITJUNC(JS)-1
21026C...Set (anti)colour mother = junction.
21027 DO 260 JV=1,3
21028 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21029 & +MSTU(5)*N
21030C...Keep track of partons adjacent to junction:
21031 JST(JS,JV)=IV(JS,JV)
21032 260 CONTINUE
21033 ELSE
21034C...Mesons: set up initial q-qbar topology
21035 ITJUNC(JS)=0
21036 IF (K(IV(JS,1),2).GT.0) THEN
21037 IQ=IV(JS,1)
21038 IQBAR=IV(JS,2)
21039 ELSE
21040 IQ=IV(JS,2)
21041 IQBAR=IV(JS,1)
21042 ENDIF
21043 IV(JS,3)=0
21044 JST(JS,1)=IQ
21045 JST(JS,2)=IQBAR
21046 JST(JS,3)=0
21047 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21048 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21049C...Special for mesons. Insert gluon if BR empty.
21050 IF (NBRTOT(JS).EQ.0) THEN
21051 N=N+1
21052 DO 270 IX=1,5
21053 K(N,IX)=0
21054 P(N,IX)=0D0
21055 V(N,IX)=0D0
21056 270 CONTINUE
21057 K(N,1)=3
21058 K(N,2)=21
21059 K(N,3)=MINT(83)+JS
21060 K(N,4)=0
21061 K(N,5)=0
21062 NBRTOT(JS)=1
21063 NG(JS)=NG(JS)+1
21064C...Add gluon to IMI
21065 NMI(JS)=NMI(JS)+1
21066 IMI(JS,NMI(JS),1)=N
21067 IMI(JS,NMI(JS),2)=0
21068 ENDIF
21069 MOUT(JS)=0
21070 ENDIF
21071
21072C...Count up number of valence quarks outside BR.
21073 DO 280 JV=1,3
21074 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21075 & MOUT(JS)=MOUT(JS)+1
21076 280 CONTINUE
21077
21078 290 CONTINUE
21079
21080C...Now both sides have been prepared in an initial vvjv (baryonic) or
21081C...v(g)vbar (mesonic) configuration.
21082
21083C...Create colour line tags starting from initiators.
21084 NCT=0
21085 DO 320 IM=1,MINT(31)
21086C...Consider each side in turn.
21087 DO 310 JS=1,2
21088 I1=IMI(JS,IM,1)
21089 I2=IMI(3-JS,IM,1)
21090 DO 300 JCS=4,5
21091 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21092 & GOTO 300
21093 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21094
21095 KCS=JCS
21096 CALL PYCTTR(I1,KCS,I2)
21097 IF(MINT(51).NE.0) RETURN
21098
21099 300 CONTINUE
21100 310 CONTINUE
21101 320 CONTINUE
21102
21103 DO 340 JS=1,2
21104C...Create colour tags for beam remnant partons.
21105 DO 330 IM=MINT(31)+1,NMI(JS)
21106 IP=IMI(JS,IM,1)
21107 IF (K(IP,2).NE.21) THEN
21108 JC=(3-ISIGN(1,K(IP,2)))/2
21109 IF (MCT(IP,JC).EQ.0) THEN
21110 NCT=NCT+1
21111 MCT(IP,JC)=NCT
21112 ENDIF
21113 ELSE
21114C...Gluons
21115 ICD=K(IP,4)
21116 IAD=K(IP,5)
21117 IF (ICD.NE.0) THEN
21118C...Fictituous gluons just inherit from their quark daughters.
21119 ICC=MCT(ICD,1)
21120 IAC=MCT(IAD,2)
21121 ELSE
21122C...Real beam remnant gluons get their own colours
21123 ICC=NCT+1
21124 IAC=NCT+2
21125 NCT=NCT+2
21126 ENDIF
21127 MCT(IP,1)=ICC
21128 MCT(IP,2)=IAC
21129 ENDIF
21130 330 CONTINUE
21131 340 CONTINUE
21132
21133C...Create colour tags for colour lines which are detached from the
21134C...initial state.
21135
21136 DO 360 MQGST=1,2
21137 DO 350 I=MINT(84)+1,N
21138
21139C...Look for coloured string endpoint, or (later) leftover gluon.
21140 IF (K(I,1).NE.3) GOTO 350
21141 KC=PYCOMP(K(I,2))
21142 IF(KC.EQ.0) GOTO 350
21143 KQ=KCHG(KC,2)
21144 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21145
21146C...Pick up loose string end with no previous tag.
21147 KCS=4
21148 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21149 IF(MCT(I,KCS-3).NE.0) GOTO 350
21150
21151 CALL PYCTTR(I,KCS,I)
21152 IF(MINT(51).NE.0) RETURN
21153
21154 350 CONTINUE
21155 360 CONTINUE
21156
21157C...Store original colour tags
21158 DO 370 I=MINT(84)+1,N
21159 MCO(I,1)=MCT(I,1)
21160 MCO(I,2)=MCT(I,2)
21161 370 CONTINUE
21162
21163C...Iteratively add gluons to already existing string pieces, enforcing
21164C...various possible orderings, and rejecting insertions that would give
21165C...rise to singlet gluons.
21166C...<kappa tau> normalization.
21167 RM0=1.5D0
21168 MRETRY=0
21169 PARP80=PARP(80)
21170
21171C...Set up simplified kinematics.
21172C...Boost hard interaction systems.
21173 IBOOST=IBOOST+1
21174 DO 380 IM=1,MINT(31)
21175 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21176 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21177 380 CONTINUE
21178C...Assign preliminary beam remnant momenta.
21179 DO 390 I=MINT(53)+1,N
21180 JS=K(I,3)
21181 P(I,1)=0D0
21182 P(I,2)=0D0
21183 IF (K(I,2).NE.88) THEN
21184 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21185 P(I,3)=P(I,4)
21186 IF (JS.EQ.2) P(I,3)=-P(I,3)
21187 ELSE
21188C...Junctions are wildcards for the present.
21189 P(I,4)=0D0
21190 P(I,3)=0D0
21191 ENDIF
21192 390 CONTINUE
21193
21194C...Reset colour processing information.
21195 400 DO 410 I=MINT(84)+1,N
21196 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21197 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21198 410 CONTINUE
21199
21200 NCC=0
21201 DO 430 JS=1,2
21202C...If meson, without gluon in BR, collapse q-qbar colour tags:
21203 IF (ITJUNC(JS).EQ.0) THEN
21204 JC1=MCT(JST(JS,1),1)
21205 JC2=MCT(JST(JS,2),2)
21206 NCC=NCC+1
21207 JCCO(NCC,1)=MAX(JC1,JC2)
21208 JCCO(NCC,2)=MIN(JC1,JC2)
21209C...Collapse colour tags in event record
21210 DO 420 I=MINT(84)+1,N
21211 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21212 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21213 420 CONTINUE
21214 ENDIF
21215 430 CONTINUE
21216
21217 440 JS=1
21218 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21219 IF (NG(JS).GT.0) THEN
21220 NOPT=0
21221 RLOPT=1D9
21222C...Start at random gluon (optimizes speed for random attachments)
21223 NMGL=0
21224 IMGL=PYR(0)*NMI(JS)+1
21225 450 IMGL=MOD(IMGL,NMI(JS))+1
21226 NMGL=NMGL+1
21227C...Only loop through NMI once (with upper limit to save time)
21228 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21229 IGL = IMI(JS,IMGL,1)
21230C...If not gluon or if already connected, try next.
21231 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21232 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21233C...Now loop through all possible insertions of this gluon.
21234 NMP1=0
21235 IMP1=PYR(0)*NMI(JS)+1
21236 460 IMP1=MOD(IMP1,NMI(JS))+1
21237 NMP1=NMP1+1
21238 IF (IMP1.EQ.IMGL) GOTO 460
21239C...Only loop through NMI once (with upper limit to save time).
21240 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21241 IP1 = IMI(JS,IMP1,1)
21242C...Try both colour mother and colour anti-mother.
21243C...Randomly select which one to try first.
21244 NANTI=0
21245 MANTI=PYR(0)*2
21246 470 MANTI=MOD(MANTI+1,2)
21247 NANTI=NANTI+1
21248 IF (NANTI.LE.2) THEN
21249 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21250C...Reject if no appropriate mother (or if mother is fictitious
21251C...parent gluon.)
21252 IF (IP2.LE.0) GOTO 470
21253 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21254C...Also reject if this link has already been tried.
21255 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21256 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21257C...Set flag to indicate that this link has now been tried for this
21258C...gluon. IP2 may be junction, which has several mothers.
21259 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21260 IF (K(IP2,2).NE.88) THEN
21261 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21262 ENDIF
21263
21264C...JCG1: Original colour tag of gluon on IP1 side
21265C...JCG2: Original colour tag of gluon on IP2 side
21266C...JCP1: Original colour tag of IP1 on gluon side
21267C...JCP2: Original colour tag of IP2 on gluon side.
21268 JCG1=MCO(IGL,2-MANTI)
21269 JCG2=MCO(IGL,1+MANTI)
21270 JCP1=MCO(IP1,1+MANTI)
21271 JCP2=MCO(IP2,2-MANTI)
21272
21273 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21274C...Reject gluon attachments that give rise to singlet gluons.
21275 IF (MACCPT.EQ.0) GOTO 470
21276
21277C...Update colours
21278 JCG1=MCT(IGL,2-MANTI)
21279 JCG2=MCT(IGL,1+MANTI)
21280 JCP1=MCT(IP1,1+MANTI)
21281 JCP2=MCT(IP2,2-MANTI)
21282
21283C...Select whether to accept this insertion
21284 IF (MSTP(89).EQ.0) THEN
21285C...Random insertions: no measure.
21286 RL=1D0
21287C...For random ordering, we want to suppress beam remnant breakups
21288C...already at this point.
21289 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21290 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21291 NMP1=0
21292 NMGL=0
21293 GOTO 470
21294 ENDIF
21295 ELSEIF (MSTP(89).EQ.1) THEN
21296C...Rapidity ordering:
21297C...YGL = Rapidity of gluon.
21298 YGL=YMI(IMGL)
21299C...If fictitious gluon
21300 IF (YGL.EQ.100D0) THEN
21301 YGL=(3-2*JS)*100D0
21302 IDA1=MOD(K(IGL,4),MSTU(5))
21303 IDA2=MOD(K(IGL,5),MSTU(5))
21304 DO 480 IMT=1,NMI(JS)
21305C...Select (arbitrarily) the most central daughter.
21306 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21307 & THEN
21308 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21309 ENDIF
21310 480 CONTINUE
21311 ENDIF
21312C...YP1 = Rapidity IP1
21313 YP1=YMI(IMP1)
21314C...If fictitious gluon
21315 IF (YP1.EQ.100D0) THEN
21316 YP1=(3-2*JS)*YP1
21317 IDA1=MOD(K(IP1,4),MSTU(5))
21318 IDA2=MOD(K(IP1,5),MSTU(5))
21319 DO 490 IMT=1,NMI(JS)
21320C...Select (arbitrarily) the most central daughter.
21321 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21322 & THEN
21323 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21324 ENDIF
21325 490 CONTINUE
21326 ENDIF
21327C...YP2 = Rapidity of mother system
21328 IF (K(IP2,2).NE.88) THEN
21329 DO 500 IMT=1,NMI(JS)
21330 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21331 500 CONTINUE
21332C...If fictitious gluon
21333 IF (YP2.EQ.100D0) THEN
21334 YP2=(3-2*JS)*YP2
21335 IDA1=MOD(K(IP2,4),MSTU(5))
21336 IDA2=MOD(K(IP2,5),MSTU(5))
21337 DO 510 IMT=1,NMI(JS)
21338C...Select (arbitrarily) the most central daughter.
21339 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21340 & ) THEN
21341 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21342 ENDIF
21343 510 CONTINUE
21344 ENDIF
21345C...Assign (arbitrarily) 100D0 to junction also
21346 ELSE
21347 YP2=(3-2*JS)*100D0
21348 ENDIF
21349 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21350 ELSEIF (MSTP(89).EQ.2) THEN
21351C...Lambda ordering:
21352C...Compute lambda measure for this insertion.
21353 RL=1D0
21354 DO 520 IST=1,6
21355 ISTR(IST)=0
21356 520 CONTINUE
21357C...If IP2 is junction, not caught below.
21358 IF (JCP2.EQ.0) THEN
21359 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
21360C...Anti-junction is colour endpoint et vv., always on JCG2.
21361 ISTR(5-ITJU)=IP2
21362 ENDIF
21363 DO 530 I=MINT(84)+1,N
21364 IF (K(I,1).LT.10) THEN
21365C...The new string pieces
21366 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
21367 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
21368 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
21369 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
21370 ENDIF
21371 530 CONTINUE
21372C...Also identify junctions as string endpoints.
21373 DO 540 I=MINT(84)+1,N
21374 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
21375 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
21376C...Find partons adjacent to junctions.
21377 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
21378 & .EQ.0) ISTR(2) = ICMO
21379 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
21380 & .EQ.0) ISTR(1) = IAMO
21381 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
21382 & .EQ.0) ISTR(4) = ICMO
21383 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
21384 & .EQ.0) ISTR(3) = IAMO
21385 540 CONTINUE
21386C...The old string piece
21387 ISTR(5)=ISTR(1+2*MANTI)
21388 ISTR(6)=ISTR(4-2*MANTI)
21389 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
21390 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
21391 RL=LOG(RL)
21392 ENDIF
21393C...Allow some breadth to speed things up.
21394 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
21395 NOPT=NOPT+1
21396 ELSEIF (RL.GT.RLOPT) THEN
21397 GOTO 470
21398 ELSE
21399 NOPT=1
21400 RLOPT=RL
21401 ENDIF
21402C...INSR(NOPT,1)=Gluon colour mother
21403C...INSR(NOPT,2)=Gluon
21404C...INSR(NOPT,3)=Gluon anticolour mother
21405 IF (NOPT.GT.1000) GOTO 470
21406 INSR(NOPT,1+2*MANTI)=IP2
21407 INSR(NOPT,2)=IGL
21408 INSR(NOPT,3-2*MANTI)=IP1
21409 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
21410 ENDIF
21411 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
21412 ENDIF
21413C...Reset link test information.
21414 DO 550 I=MINT(84)+1,N
21415 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21416 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21417 550 CONTINUE
21418 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
21419 ENDIF
21420C...Now we have a list of best gluon insertions, none of which cause
21421C...singlets to arise. If list is empty, try again a few times. Note:
21422C...this should never happen if we have a meson with a gluon inserted
21423C...in the beam remnant, since that breaks up the colour line.
21424 IF (NOPT.EQ.0) THEN
21425C...Abandon BR-g-BR suppression for retries. This is not serious, it
21426C...just means we happened to start with trying a bad sequence.
21427 PARP80=1D0
21428 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
21429 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
21430 MRETRY=MRETRY+1
21431 DO 590 JS=1,2
21432 IF (ITJUNC(JS).NE.0) THEN
21433 JST(JS,1)=IV(JS,1)
21434 JST(JS,2)=IV(JS,2)
21435 JST(JS,3)=IV(JS,3)
21436C...Reset valence quark parent pointers
21437 DO 560 I=MINT(53)+1,N
21438 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
21439 560 CONTINUE
21440 MANTI=ITJUNC(JS)-1
21441C...Set (anti)colour mother = junction.
21442 DO 570 JV=1,3
21443 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21444 & +MSTU(5)*IJU
21445 570 CONTINUE
21446 ELSE
21447C...Same for mesons. JST unchanged, so needn't be restored.
21448 IQ=JST(JS,1)
21449 IQBAR=JST(JS,2)
21450 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21451 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21452 ENDIF
21453C...Also reset gluon parent pointers.
21454 NG(JS)=0
21455 DO 580 IM=1,NMI(JS)
21456 I=IMI(JS,IM,1)
21457 IF (K(I,2).EQ.21) THEN
21458 K(I,4)=MOD(K(I,4),MSTU(5))
21459 K(I,5)=MOD(K(I,5),MSTU(5))
21460 NG(JS)=NG(JS)+1
21461 ENDIF
21462 580 CONTINUE
21463 590 CONTINUE
21464C...Reset colour tags
21465 DO 600 I=MINT(84)+1,N
21466 MCT(I,1)=MCO(I,1)
21467 MCT(I,2)=MCO(I,2)
21468 600 CONTINUE
21469 GOTO 400
21470 ELSE
21471 IF(NERRPR.LT.5) THEN
21472 NERRPR=NERRPR+1
21473 CALL PYLIST(4)
21474 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
21475 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
21476 ENDIF
21477C...Kill event and start another.
21478 MINT(51)=1
21479 RETURN
21480 ENDIF
21481 ELSE
21482C...Select between insertions, suppressing insertions wholly in the BR.
21483 IIN=PYR(0)*NOPT+1
21484 610 IIN=MOD(IIN,NOPT)+1
21485 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
21486 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
21487 ENDIF
21488
21489C...Now we know which gluon to insert where. Colour tags in JCCO and
21490C...colour connection information should be updated, NG(JS) should be
21491C...counted down, and a new loop performed if there are still gluons
21492C...left on any side.
21493 ICM=INSR(IIN,1)
21494 IACM=INSR(IIN,3)
21495 IGL=INSR(IIN,2)
21496C...JCG : Original gluon colour tag
21497C...JCAG: Original gluon anticolour tag.
21498C...JCM : Original anticolour tag of gluon colour mother
21499C...JACM: Original colour tag of gluon anticolour mother
21500 JCG=MCO(IGL,1)
21501 JCM=MCO(ICM,2)
21502 JACG=MCO(IGL,2)
21503 JACM=MCO(IACM,1)
21504
21505 CALL PYMIHG(JACM,JACG,JCM,JCG)
21506 IF (MACCPT.EQ.0) THEN
21507 IF(NERRPR.LT.5) THEN
21508 NERRPR=NERRPR+1
21509 CALL PYLIST(4)
21510 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
21511 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
21512 ENDIF
21513C...Kill event and start another.
21514 MINT(51)=1
21515 RETURN
21516 ELSE
21517C...If everything went fine, store new JCCN in JCCO.
21518 NCC=NCC+1
21519 DO 620 ICC=1,NCC
21520 JCCO(ICC,1)=JCCN(ICC,1)
21521 JCCO(ICC,2)=JCCN(ICC,2)
21522 620 CONTINUE
21523 ENDIF
21524
21525C...One gluon attached is counted as equivalent to one end outside.
21526 MOUT(JS)=1
21527C...Set IGL colour mother = ICM.
21528 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
21529C...Set ICM anticolour mother = IGL colour.
21530 IF (K(ICM,2).NE.88) THEN
21531 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
21532 ELSE
21533C...If ICM is junction, just update JST array for now.
21534 DO 630 MSJ=1,3
21535 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
21536 630 CONTINUE
21537 ENDIF
21538C...Set IGL anticolour mother = IACM.
21539 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
21540C...Set IACM anticolour mother = IGL anticolour.
21541 IF (K(IACM,2).NE.88) THEN
21542 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
21543 ELSE
21544C...If IACM is junction, just update JST array for now.
21545 DO 640 MSJ=1,3
21546 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
21547 640 CONTINUE
21548 ENDIF
21549C...Count down # unconnected gluons.
21550 NG(JS)=NG(JS)-1
21551 ENDIF
21552 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
21553
21554 DO 840 JS=1,2
21555C...Collapse fictitious gluons.
21556 DO 670 IGL=MINT(53)+1,N
21557 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
21558 & K(IGL,1).EQ.14) THEN
21559 ICM=K(IGL,4)/MSTU(5)
21560 IAM=K(IGL,5)/MSTU(5)
21561 ICD=MOD(K(IGL,4),MSTU(5))
21562 IAD=MOD(K(IGL,5),MSTU(5))
21563C...Set gluon daughters pointing to gluon mothers
21564 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
21565 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
21566C...Set gluon mothers pointing to gluon daughters.
21567 IF (K(ICM,2).NE.88) THEN
21568 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
21569 ELSE
21570C...Special case: mother=junction. Just update JST array for now.
21571 DO 650 MSJ=1,3
21572 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
21573 650 CONTINUE
21574 ENDIF
21575 IF (K(IAM,2).NE.88) THEN
21576 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
21577 ELSE
21578 DO 660 MSJ=1,3
21579 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
21580 660 CONTINUE
21581 ENDIF
21582 ENDIF
21583 670 CONTINUE
21584
21585C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
21586 IM=NMI(JS)+1
21587 680 IM=IM-1
21588 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
21589 IF (IM.GT.MINT(31)) THEN
21590 NMI(JS)=NMI(JS)-1
21591 DO 690 IMR=IM,NMI(JS)
21592 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
21593 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
21594 690 CONTINUE
21595 GOTO 680
21596 ENDIF
21597
21598C...Finally, connect junction.
21599 IF (ITJUNC(JS).NE.0) THEN
21600 DO 700 I=MINT(53)+1,N
21601 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
21602 700 CONTINUE
21603C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
21604 NBRJQ =0
21605 NBRVQ =0
21606 DO 720 MSJ=1,3
21607 IDQ(MSJ)=0
21608C...Find jq with no glue inbetween inside beam remnant.
21609 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
21610 & THEN
21611 NBRJQ=NBRJQ+1
21612C...Set IDQ = -I if q non-valence and = +I if q valence.
21613 IDQ(NBRJQ)=-JST(JS,MSJ)
21614 DO 710 JV=1,3
21615 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
21616 IDQ(NBRJQ)=JST(JS,MSJ)
21617 NBRVQ=NBRVQ+1
21618 ENDIF
21619 710 CONTINUE
21620 ENDIF
21621 I12=MOD(MSJ+1,2)
21622 I45=5
21623 IF (MSJ.EQ.3) I45=4
21624 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
21625 720 CONTINUE
21626
21627C...Check if diquark can be formed.
21628 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
21629 & .GE.1)) THEN
21630C...If there is less than 2 valence quarks connected to junction
21631C...and MSTP(88)>1, use random non-valence quarks to fill up.
21632 IF (NBRVQ.LE.1) THEN
21633 NDIQ=NBRVQ
21634 730 JFLIP=NBRJQ*PYR(0)+1
21635 IF (IDQ(JFLIP).LT.0) THEN
21636 IDQ(JFLIP)=-IDQ(JFLIP)
21637 NDIQ=NDIQ+1
21638 ENDIF
21639 IF (NDIQ.LE.1) GOTO 730
21640 ENDIF
21641C...Place selected quarks first in IDQ, ordered in flavour.
21642 DO 740 JDQ=1,3
21643 IF (IDQ(JDQ).LE.0) THEN
21644 ITEMP1 = IDQ(JDQ)
21645 IDQ(JDQ)= IDQ(3)
21646 IDQ(3) = -ITEMP1
21647 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
21648 ITEMP1 = IDQ(1)
21649 IDQ(1) = IDQ(2)
21650 IDQ(2) = ITEMP1
21651 ENDIF
21652 ENDIF
21653 740 CONTINUE
21654C...Choose diquark spin.
21655 IF (NBRVQ.EQ.2) THEN
21656C...If the selected quarks are both valence, we may use SU(6) rules
21657C...to figure out which spin the diquark has, by a subdivision of the
21658C...original beam hadron into the selected diquark system plus a kicked
21659C...out quark, IKO.
21660 JKO=6
21661 DO 760 JDQ=1,2
21662 DO 750 JV=1,3
21663 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
21664 750 CONTINUE
21665 760 CONTINUE
21666 IKO=IV(JS,JKO)
21667 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
21668 ELSE
21669C...If one or more of the selected quarks are not valence, we cannot use
21670C...SU(6) subdivisions of the original beam hadron. Instead, with the
21671C...flavours of the diquark already selected, we assume for now
21672C...50:50 spin-1:spin-0 (where spin-0 possible).
21673 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
21674 IS=3
21675 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
21676 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
21677 KFDQ=KFDQ+ISIGN(IS,KFDQ)
21678 ENDIF
21679
21680C...Collapse diquark-j-quark system to baryon, if allowed and possible.
21681C...Note: third quark can per definition not also be valence,
21682C...therefore we can only do this if we are allowed to use sea quarks.
21683 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
21684 NTRY=0
21685 780 NTRY=NTRY+1
21686 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
21687 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
21688 GOTO 780
21689 ELSEIF(NTRY.GT.100) THEN
21690C...If no baryon can be found, give up and form diquark.
21691 IDQ(3)=0
21692 GOTO 770
21693 ELSE
21694C...Replace junction by baryon.
21695 K(IJU,1)=1
21696 K(IJU,2)=KFBAR
21697 K(IJU,3)=MINT(83)+JS
21698 K(IJU,4)=0
21699 K(IJU,5)=0
21700 P(IJU,5)=PYMASS(KFBAR)
21701 DO 790 MSJ=1,3
21702C...Prepare removal of participating quarks from ER.
21703 K(JST(JS,MSJ),1)=-1
21704 790 CONTINUE
21705 ENDIF
21706 ELSE
21707C...If collapse to baryon not possible or not allowed, replace junction
21708C...by diquark. This way, collapsed gluons that were pointing at the
21709C...junction will now point (correctly) at diquark.
21710 MANTI=ITJUNC(JS)-1
21711 K(IJU,1)=3
21712 K(IJU,2)=KFDQ
21713 K(IJU,3)=MINT(83)+JS
21714 K(IJU,4)=0
21715 K(IJU,5)=0
21716 DO 800 MSJ=1,3
21717 IP=JST(JS,MSJ)
21718 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
21719 K(IJU,4+MANTI)=0
21720 K(IJU,5-MANTI)=IP*MSTU(5)
21721 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
21722 & MSTU(5)*IJU
21723 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
21724 ELSE
21725C...Prepare removal of participating quarks from ER.
21726 K(IP,1)=-1
21727 ENDIF
21728 800 CONTINUE
21729 ENDIF
21730
21731C...Update so ER pointers to collapsed quarks
21732C...now go to collapsed object.
21733 DO 820 I=MINT(84)+1,N
21734 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
21735 & .K(I,1).GT.0) THEN
21736 DO 810 ISID=4,5
21737 IMO=K(I,ISID)/MSTU(5)
21738 IDA=MOD(K(I,ISID),MSTU(5))
21739 IF (IMO.GT.0) THEN
21740 IF (K(IMO,1).EQ.-1) IMO=IJU
21741 ENDIF
21742 IF (IDA.GT.0) THEN
21743 IF (K(IDA,1).EQ.-1) IDA=IJU
21744 ENDIF
21745 K(I,ISID)=IDA+MSTU(5)*IMO
21746 810 CONTINUE
21747 ENDIF
21748 820 CONTINUE
21749 ENDIF
21750 ENDIF
21751
21752C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
21753C...(this only happens for baryons, where we want to force the gluon
21754C...to sit next to the junction. Mesons handled above.)
21755 IF (NBRTOT(JS).EQ.0) THEN
21756 N=N+1
21757 DO 830 IX=1,5
21758 K(N,IX)=0
21759 P(N,IX)=0D0
21760 V(N,IX)=0D0
21761 830 CONTINUE
21762 IGL=N
21763 K(IGL,1)=3
21764 K(IGL,2)=21
21765 K(IGL,3)=MINT(83)+JS
21766 IF (ITJUNC(JS).NE.0) THEN
21767C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
21768 JLEG=PYR(0)*NVSUM(JS)+1
21769 I1=JST(JS,JLEG)
21770 JST(JS,JLEG)=IGL
21771 JCT=MCT(I1,ITJUNC(JS))
21772 MCT(IGL,3-ITJUNC(JS))=JCT
21773 NCT=NCT+1
21774 MCT(IGL,ITJUNC(JS))=NCT
21775 MANTI=ITJUNC(JS)-1
21776 ELSE
21777C...Meson. Should not happen.
21778 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
21779 IF(NERRPR.LT.5) THEN
21780 WRITE(MSTU(11),*) 'This should not have been possible!'
21781 CALL PYLIST(4)
21782 NERRPR=NERRPR+1
21783 ENDIF
21784 MINT(51)=1
21785 RETURN
21786 ENDIF
21787 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
21788 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
21789 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
21790 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
21791 IF (K(I2,2).NE.88) THEN
21792 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
21793 ELSE
21794 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
21795 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
21796 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
21797 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
21798 ELSE
21799 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
21800 ENDIF
21801 ENDIF
21802 ENDIF
21803 840 CONTINUE
21804
21805C...Remove collapsed quarks and junctions from ER and update IMI.
21806 CALL PYEDIT(11)
21807
21808C...Also update beam remnant part of IMI.
21809 NMI(1)=MINT(31)
21810 NMI(2)=MINT(31)
21811 DO 850 I=MINT(53)+1,N
21812 IF (K(I,1).LE.0) GOTO 850
21813C...Restore BR quark/diquark/baryon pointers in IMI.
21814 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
21815 JS=K(I,3)-MINT(83)
21816 NMI(JS)=NMI(JS)+1
21817 IMI(JS,NMI(JS),1)=I
21818 IMI(JS,NMI(JS),2)=0
21819 ENDIF
21820 850 CONTINUE
21821
21822C...Restore companion information from collapsed gluons.
21823 DO 870 I=MINT(53)+1,N
21824 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
21825 JS=K(I,3)-MINT(83)
21826 JCD=MOD(K(I,4),MSTU(5))
21827 JAD=MOD(K(I,5),MSTU(5))
21828 DO 860 IM=1,NMI(JS)
21829 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
21830 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
21831 860 CONTINUE
21832 IMI(JS,IMC,2)=IMI(JS,IMA,1)
21833 IMI(JS,IMA,2)=IMI(JS,IMC,1)
21834 ENDIF
21835 870 CONTINUE
21836
21837C...Renumber colour lines (since some have disappeared)
21838 JCT=0
21839 JCD=0
21840 880 JCT=JCT+1
21841 MFOUND=0
21842 I=MINT(84)
21843 890 I=I+1
21844 IF (I.EQ.N+1) THEN
21845 IF (MFOUND.EQ.0) JCD=JCD+1
21846 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
21847 MCT(I,1)=JCT-JCD
21848 MFOUND=1
21849 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
21850 MCT(I,2)=JCT-JCD
21851 MFOUND=1
21852 ENDIF
21853 IF (I.LE.N) GOTO 890
21854 IF (JCT.LT.NCT) GOTO 880
21855 NCT=JCT-JCD
21856
21857C...Reset hard interaction subsystems to their CM frames.
21858 IF (IBOOST.EQ.1) THEN
21859 DO 900 IM=1,MINT(31)
21860 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21861 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21862 900 CONTINUE
21863C...Zero beam remnant longitudinal momenta and energies
21864 DO 910 I=MINT(53)+1,N
21865 P(I,3)=0D0
21866 P(I,4)=0D0
21867 910 CONTINUE
21868 ELSE
21869 CALL PYERRM(9
21870 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
21871C...Kill event and start another.
21872 MINT(51)=1
21873 RETURN
21874 ENDIF
21875
21876 9999 RETURN
21877 END
21878C*********************************************************************
21879
21880C...PYCTTR
21881C...Adapted from PYPREP.
21882C...Assigns LHA1 colour tags to coloured partons based on
21883C...K(I,4) and K(I,5) colour connection record.
21884C...KCS negative signifies that a previous tracing should be continued.
21885C...(in case the tag to be continued is empty, the routine exits)
21886C...Starts at I and ends at I or IEND.
21887C...Special considerations for systems with junctions.
21888
21889 SUBROUTINE PYCTTR(I,KCS,IEND)
21890C...Double precision and integer declarations.
21891 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21892 INTEGER PYK,PYCHGE,PYCOMP
21893C...Commonblocks.
21894 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21895 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21896 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21897 COMMON/PYINT1/MINT(400),VINT(400)
21898C...The common block of colour tags.
21899 COMMON/PYCTAG/NCT,MCT(4000,2)
21900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
21901 DATA NERRPR/0/
21902 SAVE NERRPR
21903
21904C...Skip if parton not existing or does not have KCS
21905 IF (K(I,1).LE.0) GOTO 120
21906 KC=PYCOMP(K(I,2))
21907 IF (KC.EQ.0) GOTO 120
21908 KQ=KCHG(KC,2)
21909 IF (KQ.EQ.0) GOTO 120
21910 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
21911 & GOTO 120
21912
21913 IF (KCS.GT.0) THEN
21914 NCT=NCT+1
21915C...Set colour tag of first parton.
21916 MCT(I,KCS-3)=NCT
21917 NCS=NCT
21918 ELSE
21919 KCS=-KCS
21920 NCS=MCT(I,KCS-3)
21921 IF (NCS.EQ.0) GOTO 120
21922 ENDIF
21923
21924 IA=I
21925 NSTP=0
21926 100 NSTP=NSTP+1
21927 IF(NSTP.GT.4*N) THEN
21928 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
21929 GOTO 120
21930 ENDIF
21931
21932C...Finished if reached final-state triplet.
21933 IF(K(IA,1).EQ.3) THEN
21934 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
21935 ENDIF
21936
21937C...Also finished if reached junction.
21938 IF(K(IA,1).EQ.42) THEN
21939 GOTO 120
21940 ENDIF
21941
21942C...GOTO next parton in colour space.
21943 110 IB=IA
21944C...If IB's KCS daughter not traced and exists, goto KCS daughter.
21945 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
21946 & .NE.0) THEN
21947 IA=MOD(K(IB,KCS),MSTU(5))
21948 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
21949 MREV=0
21950 ELSE
21951C...If KCS mother traced or KCS mother nonexistent, switch colour.
21952 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
21953 & MSTU(5)).EQ.0) THEN
21954 KCS=9-KCS
21955 NCT=NCT+1
21956 NCS=NCT
21957C...Assign new colour tag on other side of old parton.
21958 MCT(IB,KCS-3)=NCT
21959 ENDIF
21960C...Goto (new) KCS mother, set mother traced tag
21961 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
21962 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
21963 MREV=1
21964 ENDIF
21965 IF(IA.LE.0.OR.IA.GT.N) THEN
21966 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
21967 IF(NERRPR.LT.5) THEN
21968 write(*,*) 'began at ',I
21969 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
21970 & ' NCS=',NCS,' MREV=',MREV
21971 CALL PYLIST(4)
21972 NERRPR=NERRPR+1
21973 ENDIF
21974 MINT(51)=1
21975 RETURN
21976 ENDIF
21977 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
21978 & MSTU(5)).EQ.IB) THEN
21979 IF(MREV.EQ.1) KCS=9-KCS
21980 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
21981C...Set KSC mother traced tag for IA
21982 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
21983 ELSE
21984 IF(MREV.EQ.0) KCS=9-KCS
21985 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
21986C...Set KCS daughter traced tag for IA
21987 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
21988 ENDIF
21989C...Assign new colour tag
21990 MCT(IA,KCS-3)=NCS
21991 IF(IA.NE.I.AND.IA.NE.IEND) GOTO 100
21992
21993 120 RETURN
21994 END
21995
21996*********************************************************************
21997
21998C...PYMIHG
21999C...Collapse JCP1 and connecting tags to JCG1.
22000C...Collapse JCP2 and connecting tags to JCG2.
22001
22002 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22003C...Double precision and integer declarations.
22004 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22005 IMPLICIT INTEGER(I-N)
22006 INTEGER PYK,PYCHGE,PYCOMP
22007C...The event record
22008 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22009C...Parameters
22010 COMMON/PYINT1/MINT(400),VINT(400)
22011 SAVE /PYJETS/,/PYINT1/
22012C...Local variables
22013 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22014 COMMON /PYCTAG/NCT,MCT(4000,2)
22015 SAVE /PYCBLS/,/PYCTAG/
22016
22017C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22018C...in temporary tag collapse array JCCN. Only break up one connection.
22019 MACCPT=1
22020 MCLPS=0
22021 DO 100 ICC=1,NCC
22022 JCCN(ICC,1)=JCCO(ICC,1)
22023 JCCN(ICC,2)=JCCO(ICC,2)
22024C...If there was a mother, it was previously connected to JCP1.
22025C...Should be changed to JCP2.
22026 IF (MCLPS.EQ.0) THEN
22027 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22028 & ,JCP2)) THEN
22029 JCCN(ICC,1)=MAX(JCG2,JCP2)
22030 JCCN(ICC,2)=MIN(JCG2,JCP2)
22031 MCLPS=1
22032 ENDIF
22033 ENDIF
22034 100 CONTINUE
22035C...Also collapse colours on JCP1 side of JCG1
22036 IF (JCP1.NE.0) THEN
22037 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22038 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22039 ELSE
22040 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22041 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22042 ENDIF
22043
22044C...Initialize event record colour tag array MCT array to MCO.
22045 DO 110 I=MINT(84)+1,N
22046 MCT(I,1)=MCO(I,1)
22047 MCT(I,2)=MCO(I,2)
22048 110 CONTINUE
22049
22050C...Collapse tags:
22051C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22052C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22053C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22054C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22055 DO 160 IS=1,4
22056C...Skip if junction.
22057 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22058C...Define starting point in tag space.
22059C...JCA = previous tag
22060C...JCO = present tag
22061C...JCN = new tag
22062 IF (MOD(IS,2).EQ.1) THEN
22063 JCO=JCP1
22064 JCN=JCG1
22065 JCALL=JCG1
22066 ELSEIF (MOD(IS,2).EQ.0) THEN
22067 JCO=JCP2
22068 JCN=JCG2
22069 JCALL=JCG2
22070 ENDIF
22071 ITRACE=0
22072 120 ITRACE=ITRACE+1
22073 IF (ITRACE.GT.1000) THEN
22074C...NB: Proper error message should be defined here.
22075 CALL PYERRM(14
22076 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22077 MINT(57)=MINT(57)+1
22078 MINT(51)=1
22079 RETURN
22080 ENDIF
22081C...Collapse all JCN tags to JCALL
22082 DO 130 I=MINT(84)+1,N
22083 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22084 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22085 130 CONTINUE
22086C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22087 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22088 JCA=JCN
22089 JCN=JCO
22090 ELSE
22091 JCA=JCO
22092 JCO=JCN
22093 ENDIF
22094C...If possible, step from JCO to new tag JCN not equal to JCA.
22095 DO 140 ICC=1,NCC+1
22096 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22097 & JCCN(ICC,2)
22098 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22099 & JCCN(ICC,1)
22100 140 CONTINUE
22101C...Iterate if new colour was arrived at, but don't go in circles.
22102 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22103C...Change all JCN tags in MCO to JCALL in MCT.
22104 DO 150 I=MINT(84)+1,N
22105 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22106 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22107C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22108 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22109 & .NE.0) MACCPT=0
22110 150 CONTINUE
22111 160 CONTINUE
22112
22113 DO 200 JCL=NCT,1,-1
22114 JCA=0
22115 JCN=JCL
22116 170 JCO=JCN
22117 DO 180 ICC=1,NCC+1
22118 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22119 & =JCCN(ICC,2)
22120 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22121 & =JCCN(ICC,1)
22122 180 CONTINUE
22123C...Overpaint all JCN with JCL
22124 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22125 DO 190 I=MINT(84)+1,N
22126 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22127 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22128C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22129 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22130 & .NE.0) MACCPT=0
22131 190 CONTINUE
22132 JCA=JCO
22133 GOTO 170
22134 ENDIF
22135 200 CONTINUE
22136
22137 RETURN
22138 END
22139
22140C*********************************************************************
22141
22142C...PYMIRM
22143C...Picks primordial kT and shares longitudinal momentum among
22144C...beam remnants.
22145
22146 SUBROUTINE PYMIRM
22147
22148C...Double precision and integer declarations.
22149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22150 IMPLICIT INTEGER(I-N)
22151 INTEGER PYK,PYCHGE,PYCOMP
22152C...The event record
22153 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22154C...Parameters
22155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22156 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22157 COMMON/PYINT1/MINT(400),VINT(400)
22158C...The common block of colour tags.
22159 COMMON/PYCTAG/NCT,MCT(4000,2)
22160C...The common block of dangling ends
22161 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22162 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22163 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22164 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22165C...Local variables
22166 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22167C...W(I,J)| J=0 | 1 | 2 |
22168C... I=0 | Wrem**2 | W+ | W- |
22169C... 1 | W1**2 | W1+ | W1- |
22170C... 2 | W2**2 | W2+ | W2- |
22171C...4-product
22172 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)
22173C...Tentative parametrization of <kT> as a function of Q.
22174 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22175C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22176C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22177 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22178C...Lambda kinematic function.
22179 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22180
22181C...Beginning and end of beam remnant partons
22182 NOUT=MINT(53)
22183 ISUB=MINT(1)
22184
22185C...Loopback point if kinematic choices gives impossible configuration.
22186 NTRY=0
22187 100 NTRY=NTRY+1
22188
22189C...Assign kT values on each side separately.
22190 DO 180 JS=1,2
22191
22192C...First zero all kT on this side. Skip if no kT to generate.
22193 DO 110 IM=1,NMI(JS)
22194 P(IMI(JS,IM,1),1)=0D0
22195 P(IMI(JS,IM,1),2)=0D0
22196 110 CONTINUE
22197 IF(MSTP(91).LE.0) GOTO 180
22198
22199C...Now assign kT to each (non-collapsed) parton in IMI.
22200 DO 170 IM=1,NMI(JS)
22201 I=IMI(JS,IM,1)
22202C...Select kT according to truncated gaussian or 1/kt6 tails.
22203C...For first interaction, either use rms width = PARP(91) or fitted.
22204 IF (IM.EQ.1) THEN
22205 SIGMA=PARP(91)
22206 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22207 Q=SQRT(PT2MI(IM))
22208 SIGMA=SIGPT(Q)
22209 ENDIF
22210 ELSE
22211C...For subsequent interactions and BR partons use fragmentation width.
22212 SIGMA=PARJ(21)
22213 ENDIF
22214 PHI=PARU(2)*PYR(0)
22215 PT=0D0
22216 IF(NTRY.LE.100) THEN
22217 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22218 PT=GETPT(Q,SIGMA)
22219 PTX=PT*COS(PHI)
22220 PTY=PT*SIN(PHI)
22221 ELSEIF (MSTP(91).EQ.2) THEN
22222 CALL PYERRM(11,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22223 & 'available, using MSTP(91)=1.')
22224 CALL PYGIVE('MSTP(91)=1')
22225 GOTO 111
22226 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22227C...Use distribution with kt**6 tails, rms width = PARP(91).
22228 EPS=SQRT(3D0/2D0)*SIGMA
22229C...Generate PTX and PTY separately, each propto 1/KT**6
22230 DO 119 IXY=1,2
22231C...Decide which interval to try
22232 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22233 IF (PYR(0).LT.P12) THEN
22234C...Use flat approx with accept/reject up to EPS.
22235 PT=PYR(0)*EPS
22236 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22237 IF (PYR(0).GT.WT) GOTO 112
22238 ELSE
22239C...Above EPS, use 1/kt**6 approx with accept/reject.
22240 PT=EPS/(PYR(0)**(1D0/5D0))
22241 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22242 IF (PYR(0).GT.WT) GOTO 112
22243 ENDIF
22244 MSIGN=1
22245 IF (PYR(0).GT.0.5D0) MSIGN=-1
22246 IF (IXY.EQ.1) PTX=MSIGN*PT
22247 IF (IXY.EQ.2) PTY=MSIGN*PT
22248 119 CONTINUE
22249 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22250 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22251 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22252 ENDIF
22253C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22254 PT=SQRT(PTX**2+PTY**2)
22255 WT=1D0
22256 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22257 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22258 PTX=PTX*WT
22259 PTY=PTY*WT
22260 PT=SQRT(PTX**2+PTY**2)
22261 ENDIF
22262
22263 P(I,1)=P(I,1)+PTX
22264 P(I,2)=P(I,2)+PTY
22265
22266C...Compensation kicks, with varying degree of local anticorrelations.
22267 MCORR=MSTP(90)
22268 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22269 PTCX=-PTX/(NMI(JS)-1)
22270 PTCY=-PTY/(NMI(JS)-1)
22271 IF(ISUB.EQ.95) THEN
22272 PTCX=-PTX/(NMI(JS)-2)
22273 PTCY=-PTY/(NMI(JS)-2)
22274 ENDIF
22275 DO 120 IMC=1,NMI(JS)
22276 IF (IMC.EQ.IM) GOTO 120
22277 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22278 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22279 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22280 120 CONTINUE
22281 ELSEIF (MCORR.GE.1) THEN
22282 DO 140 MSID=4,5
22283 NNXT(MSID-3)=0
22284C...Count up # of neighbours on either side
22285 IMO=I
22286 130 IMO=K(IMO,MSID)/MSTU(5)
22287 IF (IMO.EQ.0) GOTO 140
22288 NNXT(MSID-3)=NNXT(MSID-3)+1
22289C...Stop at quarks and junctions
22290 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22291 140 CONTINUE
22292C...How should compensation be shared when unequal numbers on the
22293C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22294 NSUM=NNXT(1)+NNXT(2)
22295 T1=0
22296 DO 160 MSID=4,5
22297C...Total momentum to be compensated on this side
22298 IF (NNXT(MSID-3).EQ.0) GOTO 160
22299 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22300 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22301C...RS: compensation supression factor as we go out from parton I.
22302C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22303C...since (for now) MSTP(90) provides enough variability.
22304 RS=0.5D0
22305 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22306 IMO=I
22307 150 IDA=IMO
22308 IMO=K(IMO,MSID)/MSTU(5)
22309 IF (IMO.EQ.0) GOTO 160
22310 FAC=FAC*RS
22311 IF (K(IMO,2).NE.88) THEN
22312 P(IMO,1)=P(IMO,1)+FAC*PTCX
22313 P(IMO,2)=P(IMO,2)+FAC*PTCY
22314 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22315C...If we reach junction, divide out the kT that would have been
22316C...assigned to the junction on each of its other legs.
22317 ELSE
22318 L1=MOD(K(IMO,4),MSTU(5))
22319 L2=K(IMO,5)/MSTU(5)
22320 L3=MOD(K(IMO,5),MSTU(5))
22321 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22322 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22323 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22324 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22325 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22326 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22327 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22328 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22329 ENDIF
22330
22331 160 CONTINUE
22332 ENDIF
22333 170 CONTINUE
22334C...End assignment of kT values to initiators and remnants.
22335 180 CONTINUE
22336
22337C...Check kinematics constraints for non-BR partons.
22338 DO 190 IM=1,MINT(31)
22339 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
22340 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
22341 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
22342 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
22343 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
22344 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
22345 IF(NTRY.GE.100) THEN
22346C...Kill this event and start another.
22347 CALL PYERRM(11,
22348 & '(PYMIRM:) No consistent (x,kT) sets found')
22349 MINT(51)=1
22350 RETURN
22351 ENDIF
22352 GOTO 100
22353 ENDIF
22354 190 CONTINUE
22355
22356C...Calculate W+ and W- available for combined remnant system.
22357 W(0,1)=VINT(1)
22358 W(0,2)=VINT(1)
22359 DO 200 IM=1,MINT(31)
22360 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
22361 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
22362 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
22363 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
22364 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
22365 200 CONTINUE
22366C...Also store Wrem**2 = W+ * W-
22367 W(0,0)=W(0,1)*W(0,2)
22368
22369 IF (W(0,0).LT.0D0.AND.NTRY.LE.100) THEN
22370 IF(NTRY.GE.100) THEN
22371C...Kill this event and start another.
22372 CALL PYERRM(11,
22373 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
22374 MINT(51)=1
22375 RETURN
22376 ENDIF
22377 GOTO 100
22378 ENDIF
22379
22380C...Assign unscaled x values to partons/hadrons in each of the
22381C...beam remnants and calculate unscaled W+ and W- from them.
22382 NTRYX=0
22383 210 NTRYX=NTRYX+1
22384 DO 280 JS=1,2
22385 W(JS,1)=0D0
22386 W(JS,2)=0D0
22387 DO 270 IM=MINT(31)+1,NMI(JS)
22388 I=IMI(JS,IM,1)
22389 KF=K(I,2)
22390 KFA=IABS(KF)
22391 ICOMP=IMI(JS,IM,2)
22392
22393C...Skip collapsed gluons and junctions. Reset.
22394 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
22395 IF (KFA.EQ.88) GOTO 270
22396 X=0D0
22397 IVALQ(1)=0
22398 IVALQ(2)=0
22399 ICOMQ(1)=0
22400 ICOMQ(2)=0
22401
22402C...If gluon then only beam remnant, so takes all.
22403 IF(KFA.EQ.21) THEN
22404 X=1D0
22405C...If valence quark then use parametrized valence distribution.
22406 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
22407 IVALQ(1)=KF
22408C...If companion quark then derive from companion x.
22409 ELSEIF(KFA.LE.6) THEN
22410 ICOMQ(1)=ICOMP
22411C...If valence diquark then use two parametrized valence distributions.
22412 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22413 & ICOMP.EQ.0) THEN
22414 IVALQ(1)=ISIGN(KFA/1000,KF)
22415 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
22416C...If valence+sea diquark then combine valence + companion choices.
22417 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
22418 & ICOMP.LT.MSTU(5)) THEN
22419 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
22420 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
22421 ELSE
22422 IVALQ(1)=ISIGN(KFA/1000,KF)
22423 ENDIF
22424 ICOMQ(1)=ICOMP
22425C...Extra code: workaround for diquark made out of two sea
22426C...quarks, but where not (yet) ICOMP > MSTU(5).
22427 DO 220 IM1=1,MINT(31)
22428 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
22429 ICOMQ(2)=IMI(JS,IM1,1)
22430 IVALQ(1)=0
22431 ENDIF
22432 220 CONTINUE
22433C...If sea diquark then sum of two derived from companion x.
22434 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
22435 ICOMQ(1)=MOD(ICOMP,MSTU(5))
22436 ICOMQ(2)=ICOMP/MSTU(5)
22437C...If meson or baryon then use fragmentation function.
22438C...Somewhat arbitrary split into old and new flavour, but OK normally.
22439 ELSE
22440 KFL3=MOD(KFA/10,10)
22441 IF(MOD(KFA/1000,10).EQ.0) THEN
22442 KFL1=MOD(KFA/100,10)
22443 ELSE
22444 KFL1=MOD(KFA,10000)-10*KFL3-1
22445 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
22446 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
22447 ENDIF
22448 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
22449 CALL PYZDIS(KFL1,KFL3,PR,X)
22450 ENDIF
22451
22452 DO 260 IQ=1,2
22453C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
22454C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
22455C...In other baryons combine u and d from proton appropriately.
22456 IF(IVALQ(IQ).NE.0) THEN
22457 NVAL=0
22458 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
22459 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
22460 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
22461C...Meson.
22462 IF(KFIVAL(JS,3).EQ.0) THEN
22463 MDU=0
22464C...Baryon with three identical quarks: mix u and d forms.
22465 ELSEIF(NVAL.EQ.3) THEN
22466 MDU=INT(PYR(0)+5D0/3D0)
22467C...Baryon, one of two identical quarks: u form.
22468 ELSEIF(NVAL.EQ.2) THEN
22469 MDU=2
22470C...Baryon with two identical quarks, but not the one picked: d form.
22471 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
22472 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
22473 MDU=1
22474C...Baryon with three nonidentical quarks: mix u and d forms.
22475 ELSE
22476 MDU=INT(PYR(0)+5D0/3D0)
22477 ENDIF
22478 XPOW=0.8D0
22479 IF(MDU.EQ.1) XPOW=3.5D0
22480 IF(MDU.EQ.2) XPOW=2D0
22481 230 XX=PYR(0)**2
22482 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
22483 X=X+XX
22484 ENDIF
22485
22486C...Calculation of x of companion quark.
22487 IF(ICOMQ(IQ).NE.0) THEN
22488 XCOMP=1D-4
22489 DO 240 IM1=1,MINT(31)
22490 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
22491 240 CONTINUE
22492 NPOW=MAX(0,MIN(4,MSTP(87)))
22493 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
22494 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
22495 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
22496 IF(CORR.LT.PYR(0)) GOTO 250
22497 X=X+XX
22498 ENDIF
22499 260 CONTINUE
22500
22501C...Optionally enchance x of composite systems (e.g. diquarks)
22502 IF (KFA.GT.100) X=PARP(79)*X
22503
22504C...Store x. Also calculate light cone energies of each system.
22505 XMI(JS,IM)=X
22506 W(JS,JS)=W(JS,JS)+X
22507 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
22508 270 CONTINUE
22509 W(JS,JS)=W(JS,JS)*W(0,JS)
22510 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
22511 W(JS,0)=W(JS,1)*W(JS,2)
22512 280 CONTINUE
22513
22514C...Check W1 W2 < Wrem (can be done before rescaling, since W
22515C...insensitive to global rescalings of the BR x values).
22516 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
22517 & THEN
22518 GOTO 210
22519 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
22520 GOTO 100
22521 ELSEIF (NTRYX.GT.100) THEN
22522 CALL PYERRM(11,'(PYMIRM:) No consistent (x,kT) sets found')
22523 MINT(57)=MINT(57)+1
22524 MINT(51)=1
22525 RETURN
22526 ENDIF
22527
22528C...Compute x rescaling factors
22529 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
22530 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
22531 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
22532
22533 IF (R1.LT.0.OR.R2.LT.0) THEN
22534 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
22535 MINT(57)=MINT(57)+1
22536 MINT(51)=1
22537 ENDIF
22538
22539C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
22540 W(1,1)=W(1,1)*R1
22541 W(1,2)=W(1,2)/R1
22542 W(2,1)=W(2,1)/R2
22543 W(2,2)=W(2,2)*R2
22544
22545C...Rescale BR x values.
22546 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
22547 XMI(1,IM)=XMI(1,IM)*R1
22548 XMI(2,IM)=XMI(2,IM)*R2
22549 290 CONTINUE
22550
22551C...Now we have a consistent set of x and kT values.
22552C...First set up the initiators and their daughters correctly.
22553 DO 300 IM=1,MINT(31)
22554 I1=IMI(1,IM,1)
22555 I2=IMI(2,IM,1)
22556 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
22557 & (P(I1,2)+P(I2,2))**2
22558 PT12=P(I1,1)**2+P(I1,2)**2
22559 PT22=P(I2,1)**2+P(I2,2)**2
22560C...p_z
22561 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
22562 P(I2,3)=-P(I1,3)
22563C...Energies (masses should be zero at this stage)
22564 P(I1,4)=SQRT(PT12+P(I1,3)**2)
22565 P(I2,4)=SQRT(PT22+P(I2,3)**2)
22566
22567C...Transverse 12 system initiator velocity:
22568 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
22569 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
22570C...Boost to overall initiator system rest frame
22571 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
22572 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
22573
22574C...Compute phi,theta coordinates of I1 and rotate z axis.
22575 PHI=PYANGL(P(I1,1),P(I1,2))
22576 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
22577 IMIN=IMISEP(IM-1)+1
22578C...(include documentation lines if MI = 1)
22579 IF (IM.EQ.1) IMIN=MINT(83)+5
22580 IMAX=IMISEP(IM)
22581C...Rotate entire system in phi
22582 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
22583C...Only rotate 12 system in theta
22584 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
22585 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
22586
22587C...Now boost entire system back to LAB
22588 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22589 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
22590 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
22591
22592 300 CONTINUE
22593
22594
22595C...For the beam remnant partons/hadrons, we only need to set pz and E.
22596 DO 320 JS=1,2
22597 DO 310 IM=MINT(31)+1,NMI(JS)
22598 I=IMI(JS,IM,1)
22599C...Skip collapsed gluons and junctions.
22600 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
22601 IF (KFA.EQ.88) GOTO 310
22602 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
22603 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
22604 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
22605 IF (JS.EQ.2) P(I,3)=-P(I,3)
22606 310 CONTINUE
22607 320 CONTINUE
22608
22609
22610C...Documentation lines
22611 DO 340 JS=1,2
22612 IN=MINT(83)+JS+2
22613 IO=IMI(JS,1,1)
22614 K(IN,1)=21
22615 K(IN,2)=K(IO,2)
22616 K(IN,3)=MINT(83)+JS
22617 K(IN,4)=0
22618 K(IN,5)=0
22619 DO 330 J=1,5
22620 P(IN,J)=P(IO,J)
22621 V(IN,J)=V(IO,J)
22622 330 CONTINUE
22623 MCT(IN,1)=MCT(IO,1)
22624 MCT(IN,2)=MCT(IO,2)
22625 340 CONTINUE
22626
22627C...Final state colour reconnections.
22628 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
22629
22630C...Number of colour tags for which a recoupling will be tried.
22631 NTOT=NCT
22632C...Number of recouplings to try
22633 MINT(34)=0
22634 NRECP=0
22635 NITER=0
22636 350 NRECP=MINT(34)
22637 NITER=NITER+1
22638 IITER=0
22639 360 IITER=IITER+1
22640 IF (IITER.LE.PARP(78)*NTOT) THEN
22641C...Select two colour tags at random
22642C...NB: jj strings do not have colour tags assigned to them,
22643C...thus they are as yet not affected by anything done here.
22644 JCT=PYR(0)*NCT+1
22645 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
22646 IJ1=0
22647 IJ2=0
22648 IK1=0
22649 IK2=0
22650C...Find final state partons with this (anti)colour
22651 DO 370 I=MINT(84)+1,N
22652 IF (K(I,1).EQ.3) THEN
22653 IF (MCT(I,1).EQ.JCT) IJ1=I
22654 IF (MCT(I,2).EQ.JCT) IJ2=I
22655 IF (MCT(I,1).EQ.KCT) IK1=I
22656 IF (MCT(I,2).EQ.KCT) IK2=I
22657 ENDIF
22658 370 CONTINUE
22659C...Only consider recouplings not involving junctions for now.
22660 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
22661
22662 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
22663 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
22664 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
22665 MCT(IJ2,2)=KCT
22666 MCT(IK2,2)=JCT
22667C...Count up number of reconnections
22668 MINT(34)=MINT(34)+1
22669 ENDIF
22670 IF (MINT(34).LE.1000) THEN
22671 GOTO 360
22672 ELSE
22673 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
22674 GOTO 380
22675 ENDIF
22676 ENDIF
22677 IF (NRECP.LT.MINT(34)) GOTO 350
22678
22679C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
22680 380 MINT(33)=1
22681
22682 RETURN
22683 END
22684
22685C*********************************************************************
22686
22687C...PYFSCR
22688C...Performs colour annealing.
22689C...MSTP(95) : CR Type
22690C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
22691C... = 2 : Type I(no gg loops); hadron-hadron only
22692C... = 3 : Type I(no gg loops); all beams
22693C... = 4 : Type II(gg loops) ; hadron-hadron only
22694C... = 5 : Type II(gg loops) ; all beams
22695C... = 6 : Type S ; hadron-hadron only
22696C... = 7 : Type S ; all beams
22697C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
22698C...Type S is driven by starting only from free triplets, not octets.
22699C...A string piece remains unchanged with probability
22700C... PKEEP = (1-PARP(78))**N
22701C...This scaling corresponds to each string piece having to go through
22702C...N other ones, each with probability PARP(78) for reconnection, where
22703C...N is here chosen simply as the number of multiple interactions,
22704C...for a rough scaling with the general level of activity.
22705
22706 SUBROUTINE PYFSCR(IP)
22707C...Double precision and integer declarations.
22708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22709 INTEGER PYK,PYCHGE,PYCOMP
22710C...Commonblocks.
22711 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22712 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22713 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22714 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22715 COMMON/PYINT1/MINT(400),VINT(400)
22716C...The common block of colour tags.
22717 COMMON/PYCTAG/NCT,MCT(4000,2)
22718 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
22719 &/PYPARS/
22720C...MCN: Temporary storage of new colour tags
22721 DOUBLE PRECISION MCN(4000,2)
22722
22723C...Function to give four-product.
22724 FOUR(I,J)=P(I,4)*P(J,4)
22725 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
22726
22727C...Check valid range of MSTP(95), local copy
22728 IF (MSTP(95).LE.1.OR.MSTP(95).GE.8) RETURN
22729 MSTP95=MOD(MSTP(95),10)
22730C...Set whether CR allowed inside resonance systems or not
22731C...(not implemented yet)
22732C MRESCR=1
22733C IF (MSTP(95).GE.10) MRESCR=0
22734
22735C...Check whether colour tags already defined
22736 IF (MINT(33).EQ.0) THEN
22737C...Erase any existing colour tags for this event
22738 DO 100 I=1,N
22739 MCT(I,1)=0
22740 MCT(I,2)=0
22741 100 CONTINUE
22742C...Create colour tags for this event
22743 DO 120 I=1,N
22744 IF (K(I,1).EQ.3) THEN
22745 DO 110 KCS=4,5
22746 KCSIN=KCS
22747 IF (MCT(I,KCSIN-3).EQ.0) THEN
22748 CALL PYCTTR(I,KCSIN,I)
22749 ENDIF
22750 110 CONTINUE
22751 ENDIF
22752 120 CONTINUE
22753C...Instruct PYPREP to use colour tags
22754 MINT(33)=1
22755 ENDIF
22756
22757C...For MSTP(95) even, only apply to hadron-hadron
22758 IF (MOD(MSTP(95),2).EQ.0) THEN
22759 KA1=IABS(MINT(11))
22760 KA2=IABS(MINT(12))
22761 IF (KA1.LT.100.OR.KA2.LT.100) GOTO 9999
22762 ENDIF
22763
22764C...Initialize new tag array (but do not delete old yet)
22765 LCT=NCT
22766 DO 130 I=MAX(1,IP),N
22767 MCN(I,1)=0
22768 MCN(I,2)=0
22769 130 CONTINUE
22770
22771C...For each final-state dipole, check whether string should be
22772C...preserved.
22773 DO 150 ICT=1,NCT
22774 IC=0
22775 IA=0
22776 DO 140 I=MAX(1,IP),N
22777 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
22778 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
22779 140 CONTINUE
22780 IF (IC.NE.0.AND.IA.NE.0) THEN
22781C...Chiefly consider large strings.
22782 PKEEP=(1D0-PARP(78))**MINT(31)
22783 IF (PYR(0).LE.PKEEP) THEN
22784 LCT=LCT+1
22785 MCN(IC,1)=LCT
22786 MCN(IA,2)=LCT
22787 ENDIF
22788 ENDIF
22789 150 CONTINUE
22790
22791C...Loop over event record, starting from IP
22792C...(Ignore junctions for now.)
22793 NLOOP=0
22794 160 NLOOP=NLOOP+1
22795 MCIMAX=0
22796 MCJMAX=0
22797 RLMAX=0D0
22798 ILMAX=0
22799 JLMAX=0
22800 DO 230 I=MAX(1,IP),N
22801 IF (K(I,1).NE.3) GOTO 230
22802C...Check colour charge
22803 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22804 IF (MCI.EQ.0) GOTO 230
22805C...For Seattle algorithm, only start from partons with one dangling
22806C...colour tag
22807 IF (MSTP(95).EQ.6.OR.MSTP(95).EQ.7) THEN
22808 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
22809 ENDIF
22810C... Find optimal partner
22811 JLOPT=0
22812 MCJOPT=0
22813 MBROPT=0
22814 MGGOPT=0
22815 RLOPT=1D19
22816C...Loop over I colour/anticolour, check whether already connected
22817 170 DO 220 ICL=1,2
22818 IF (MCN(I,ICL).NE.0) GOTO 220
22819 IF (ICL.EQ.1.AND.MCI.EQ.-1) GOTO 220
22820 IF (ICL.EQ.2.AND.MCI.EQ.1) GOTO 220
22821C...Check whether this is a dangling colour tag (ie to junction!)
22822 IFOUND=0
22823 DO 180 J=MAX(1,IP),N
22824 IF (K(J,1).EQ.3.AND.MCT(J,3-ICL).EQ.MCT(I,ICL)) IFOUND=1
22825 180 CONTINUE
22826 IF (IFOUND.EQ.0) GOTO 220
22827 DO 210 J=MAX(1,IP),N
22828 IF (K(J,1).NE.3.OR.I.EQ.J) GOTO 210
22829C...Do not make direct connections between partons in same Beam Remnant
22830 MBRSTR=0
22831 IF (K(I,3).LE.2.AND.K(J,3).LE.2.AND.K(I,3).EQ.K(J,3))
22832 & MBRSTR=1
22833C...Check colour charge
22834 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
22835 IF (MCJ.EQ.0.OR.(MCJ.EQ.MCI.AND.MCI.NE.2)) GOTO 210
22836C...Check for gluon loops
22837 MGGSTR=0
22838 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
22839 ICLA=3-ICL
22840 IF (MCN(I,ICLA).EQ.MCN(J,ICL).AND.MSTP(95).LE.3.AND.
22841 & MCN(I,ICLA).NE.0) MGGSTR=1
22842 ENDIF
22843C...Loop over J colour/anticolour, check whether already connected
22844 DO 200 JCL=1,2
22845 IF (MCN(J,JCL).NE.0) GOTO 200
22846 IF (JCL.EQ.ICL) GOTO 200
22847 IF (JCL.EQ.1.AND.MCJ.EQ.-1) GOTO 200
22848 IF (JCL.EQ.2.AND.MCJ.EQ.1) GOTO 200
22849C...Check whether this is a dangling colour tag (ie to junction!)
22850 IFOUND=0
22851 DO 190 J2=MAX(1,IP),N
22852 IF (K(J2,1).EQ.3.AND.MCT(J2,3-JCL).EQ.MCT(J,JCL))
22853 & IFOUND=1
22854 190 CONTINUE
22855 IF (IFOUND.EQ.0) GOTO 200
22856C...Save connection with smallest lambda measure
22857C...If best so far was a BR string and this is not, also save.
22858C...If best so far was a gg string and this is not, also save.
22859 RL=FOUR(I,J)
22860 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
22861 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
22862 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
22863 RLOPT=RL
22864 JLOPT=J
22865 ICOPT=ICL
22866 JCOPT=JCL
22867 MCJOPT=MCJ
22868 MBROPT=MBRSTR
22869 MGGOPT=MGGSTR
22870 ENDIF
22871 200 CONTINUE
22872 210 CONTINUE
22873 220 CONTINUE
22874 IF (JLOPT.NE.0) THEN
22875C...Save pair with largest RLOPT so far
22876 IF (RLOPT.GE.RLMAX) THEN
22877 RLMAX=RLOPT
22878 ILMAX=I
22879 JLMAX=JLOPT
22880 ICMAX=ICOPT
22881 JCMAX=JCOPT
22882 MCJMAX=MCJOPT
22883 MCIMAX=MCI
22884 ENDIF
22885 ENDIF
22886 230 CONTINUE
22887C...Save and iterate
22888 IF (ILMAX.GT.0) THEN
22889 LCT=LCT+1
22890 MCN(ILMAX,ICMAX)=LCT
22891 MCN(JLMAX,JCMAX)=LCT
22892 IF (NLOOP.LE.2*(N-IP)) THEN
22893 GOTO 160
22894 ELSE
22895 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
22896 CALL PYSTOP(11)
22897 ENDIF
22898 ELSE
22899C...Save and exit. First check for leftover gluon(s)
22900 DO 260 I=MAX(1,IP),N
22901C...Check colour charge
22902 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22903 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
22904 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
22905C...Decide where to put left-over gluon (minimal insertion)
22906 ILMAX=0
22907 RLMAX=1D19
22908 DO 250 KCT=NCT+1,LCT
22909 DO 240 IT=MAX(1,IP),N
22910 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
22911 IF (MCN(IT,1).EQ.KCT) IC=IT
22912 IF (MCN(IT,2).EQ.KCT) IA=IT
22913 240 CONTINUE
22914 RL=FOUR(IC,I)*FOUR(IA,I)
22915 IF (RL.LT.RLMAX) THEN
22916 RLMAX=RL
22917 ICMAX=IC
22918 IAMAX=IA
22919 ENDIF
22920 250 CONTINUE
22921 LCT=LCT+1
22922 MCN(I,1)=MCN(ICMAX,1)
22923 MCN(I,2)=LCT
22924 MCN(ICMAX,1)=LCT
22925 ENDIF
22926 260 CONTINUE
22927 DO 270 I=MAX(1,IP),N
22928C...Do not erase parton shower colour history
22929 IF (K(I,1).NE.3) GOTO 270
22930C...Check colour charge
22931 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
22932 IF (MCI.EQ.0) GOTO 270
22933 IF (MCN(I,1).NE.0) MCT(I,1)=MCN(I,1)
22934 IF (MCN(I,2).NE.0) MCT(I,2)=MCN(I,2)
22935 270 CONTINUE
22936 ENDIF
22937
22938 9999 RETURN
22939 END
22940
22941C*********************************************************************
22942
22943C...PYDIFF
22944C...Handles diffractive and elastic scattering.
22945
22946 SUBROUTINE PYDIFF
22947
22948C...Double precision and integer declarations.
22949 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22950 IMPLICIT INTEGER(I-N)
22951 INTEGER PYK,PYCHGE,PYCOMP
22952C...Commonblocks.
22953 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22955 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22956 COMMON/PYINT1/MINT(400),VINT(400)
22957 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
22958
22959C...Reset K, P and V vectors. Store incoming particles.
22960 DO 110 JT=1,MSTP(126)+10
22961 I=MINT(83)+JT
22962 DO 100 J=1,5
22963 K(I,J)=0
22964 P(I,J)=0D0
22965 V(I,J)=0D0
22966 100 CONTINUE
22967 110 CONTINUE
22968 N=MINT(84)
22969 MINT(3)=0
22970 MINT(21)=0
22971 MINT(22)=0
22972 MINT(23)=0
22973 MINT(24)=0
22974 MINT(4)=4
22975 DO 130 JT=1,2
22976 I=MINT(83)+JT
22977 K(I,1)=21
22978 K(I,2)=MINT(10+JT)
22979 DO 120 J=1,5
22980 P(I,J)=VINT(285+5*JT+J)
22981 120 CONTINUE
22982 130 CONTINUE
22983 MINT(6)=2
22984
22985C...Subprocess; kinematics.
22986 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
22987 PZ=SQRT(SQLAM)/(2D0*VINT(1))
22988 DO 200 JT=1,2
22989 I=MINT(83)+JT
22990 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
22991 KFH=MINT(102+JT)
22992
22993C...Elastically scattered particle. (Except elastic GVMD states.)
22994 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
22995 & MINT(106+JT).NE.3)) THEN
22996 N=N+1
22997 K(N,1)=1
22998 K(N,2)=KFH
22999 K(N,3)=I+2
23000 P(N,3)=PZ*(-1)**(JT+1)
23001 P(N,4)=PE
23002 P(N,5)=SQRT(VINT(62+JT))
23003
23004C...Decay rho from elastic scattering of gamma with sin**2(theta)
23005C...distribution of decay products (in rho rest frame).
23006 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23007 NSAV=N
23008 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23009 P(N,3)=0D0
23010 P(N,4)=P(N,5)
23011 CALL PYDECY(NSAV)
23012 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23013 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23014 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23015 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23016 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23017 140 CTHE=2D0*PYR(0)-1D0
23018 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23019 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23020 ENDIF
23021 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23022 ENDIF
23023
23024C...Diffracted particle: low-mass system to two particles.
23025 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23026 N=N+2
23027 K(N-1,1)=1
23028 K(N,1)=1
23029 K(N-1,3)=I+2
23030 K(N,3)=I+2
23031 PMMAS=SQRT(VINT(62+JT))
23032 NTRY=0
23033 150 NTRY=NTRY+1
23034 IF(NTRY.LT.20) THEN
23035 MINT(105)=MINT(102+JT)
23036 MINT(109)=MINT(106+JT)
23037 CALL PYSPLI(KFH,21,KFL1,KFL2)
23038 CALL PYKFDI(KFL1,0,KFL3,KF1)
23039 IF(KF1.EQ.0) GOTO 150
23040 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23041 IF(KF2.EQ.0) GOTO 150
23042 ELSE
23043 KF1=KFH
23044 KF2=111
23045 ENDIF
23046 PM1=PYMASS(KF1)
23047 PM2=PYMASS(KF2)
23048 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23049 K(N-1,2)=KF1
23050 K(N,2)=KF2
23051 P(N-1,5)=PM1
23052 P(N,5)=PM2
23053 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23054 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23055 P(N-1,3)=PZP
23056 P(N,3)=-PZP
23057 P(N-1,4)=SQRT(PM1**2+PZP**2)
23058 P(N,4)=SQRT(PM2**2+PZP**2)
23059 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23060 & 0D0,0D0,0D0)
23061 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23062 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23063
23064C...Diffracted particle: valence quark kicked out.
23065 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23066 & PARP(101))) THEN
23067 N=N+2
23068 K(N-1,1)=2
23069 K(N,1)=1
23070 K(N-1,3)=I+2
23071 K(N,3)=I+2
23072 MINT(105)=MINT(102+JT)
23073 MINT(109)=MINT(106+JT)
23074 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23075 P(N-1,5)=PYMASS(K(N-1,2))
23076 P(N,5)=PYMASS(K(N,2))
23077 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23078 & 4D0*P(N-1,5)**2*P(N,5)**2
23079 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23080 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23081 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23082 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23083 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23084
23085C...Diffracted particle: gluon kicked out.
23086 ELSE
23087 N=N+3
23088 K(N-2,1)=2
23089 K(N-1,1)=2
23090 K(N,1)=1
23091 K(N-2,3)=I+2
23092 K(N-1,3)=I+2
23093 K(N,3)=I+2
23094 MINT(105)=MINT(102+JT)
23095 MINT(109)=MINT(106+JT)
23096 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23097 K(N-1,2)=21
23098 P(N-2,5)=PYMASS(K(N-2,2))
23099 P(N-1,5)=0D0
23100 P(N,5)=PYMASS(K(N,2))
23101C...Energy distribution for particle into two jets.
23102 160 IMB=1
23103 IF(MOD(KFH/1000,10).NE.0) IMB=2
23104 CHIK=PARP(92+2*IMB)
23105 IF(MSTP(92).LE.1) THEN
23106 IF(IMB.EQ.1) CHI=PYR(0)
23107 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23108 ELSEIF(MSTP(92).EQ.2) THEN
23109 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23110 ELSEIF(MSTP(92).EQ.3) THEN
23111 CUT=2D0*0.3D0/VINT(1)
23112 170 CHI=PYR(0)**2
23113 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23114 & PYR(0)) GOTO 170
23115 ELSEIF(MSTP(92).EQ.4) THEN
23116 CUT=2D0*0.3D0/VINT(1)
23117 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23118 180 CHIR=CUT*CUTR**PYR(0)
23119 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23120 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23121 ELSE
23122 CUT=2D0*0.3D0/VINT(1)
23123 CUTA=CUT**(1D0-PARP(98))
23124 CUTB=(1D0+CUT)**(1D0-PARP(98))
23125 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23126 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23127 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23128 ENDIF
23129 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23130 & VINT(62+JT)) GOTO 160
23131 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23132 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23133 & (2D0*VINT(62+JT))
23134 PEI=SQRT(PZI**2+SQM)
23135 PQQP=(1D0-CHI)*(PEI+PZI)
23136 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23137 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23138 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23139 P(N-1,3)=P(N-1,4)*(-1)**JT
23140 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23141 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23142 ENDIF
23143
23144C...Documentation lines.
23145 K(I+2,1)=21
23146 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23147 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23148 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23149 K(I+2,3)=I
23150 P(I+2,3)=PZ*(-1)**(JT+1)
23151 P(I+2,4)=PE
23152 P(I+2,5)=SQRT(VINT(62+JT))
23153 200 CONTINUE
23154
23155C...Rotate outgoing partons/particles using cos(theta).
23156 IF(VINT(23).LT.0.9D0) THEN
23157 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23158 ELSE
23159 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23160 ENDIF
23161
23162 RETURN
23163 END
23164
23165C*********************************************************************
23166
23167C...PYDISG
23168C...Set up a DIS process as gamma* + f -> f, with beam remnant
23169C...and showering added consecutively. Photon flux by the PYGAGA
23170C...routine (if at all).
23171
23172 SUBROUTINE PYDISG
23173
23174C...Double precision and integer declarations.
23175 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23176 IMPLICIT INTEGER(I-N)
23177 INTEGER PYK,PYCHGE,PYCOMP
23178C...Parameter statement to help give large particle numbers.
23179 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23180 &KEXCIT=4000000,KDIMEN=5000000)
23181C...Commonblocks.
23182 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23184 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23185 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23186 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23187 COMMON/PYINT1/MINT(400),VINT(400)
23188 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23189C...Local arrays.
23190 DIMENSION PMS(4)
23191
23192C...Choice of subprocess, number of documentation lines
23193 IDOC=7
23194 MINT(3)=IDOC-6
23195 MINT(4)=IDOC
23196 IPU1=MINT(84)+1
23197 IPU2=MINT(84)+2
23198 IPU3=MINT(84)+3
23199 ISIDE=1
23200 IF(MINT(107).EQ.4) ISIDE=2
23201
23202C...Reset K, P and V vectors. Store incoming particles
23203 DO 110 JT=1,MSTP(126)+20
23204 I=MINT(83)+JT
23205 DO 100 J=1,5
23206 K(I,J)=0
23207 P(I,J)=0D0
23208 V(I,J)=0D0
23209 100 CONTINUE
23210 110 CONTINUE
23211 DO 130 JT=1,2
23212 I=MINT(83)+JT
23213 K(I,1)=21
23214 K(I,2)=MINT(10+JT)
23215 DO 120 J=1,5
23216 P(I,J)=VINT(285+5*JT+J)
23217 120 CONTINUE
23218 130 CONTINUE
23219 MINT(6)=2
23220
23221C...Store incoming partons in hadronic CM-frame
23222 DO 140 JT=1,2
23223 I=MINT(84)+JT
23224 K(I,1)=14
23225 K(I,2)=MINT(14+JT)
23226 K(I,3)=MINT(83)+2+JT
23227 140 CONTINUE
23228 IF(MINT(15).EQ.22) THEN
23229 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23230 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23231 P(MINT(84)+1,5)=-SQRT(VINT(307))
23232 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23233 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23234 KFRES=MINT(16)
23235 ISIDE=2
23236 ELSE
23237 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23238 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23239 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23240 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23241 P(MINT(84)+1,5)=-SQRT(VINT(308))
23242 KFRES=MINT(15)
23243 ISIDE=1
23244 ENDIF
23245 SIDESG=(-1D0)**(ISIDE-1)
23246
23247C...Copy incoming partons to documentation lines.
23248 DO 170 JT=1,2
23249 I1=MINT(83)+4+JT
23250 I2=MINT(84)+JT
23251 K(I1,1)=21
23252 K(I1,2)=K(I2,2)
23253 K(I1,3)=I1-2
23254 DO 150 J=1,5
23255 P(I1,J)=P(I2,J)
23256 150 CONTINUE
23257
23258C...Second copy for partons before ISR shower, since no such.
23259 I1=MINT(83)+2+JT
23260 K(I1,1)=21
23261 K(I1,2)=K(I2,2)
23262 K(I1,3)=I1-2
23263 DO 160 J=1,5
23264 P(I1,J)=P(I2,J)
23265 160 CONTINUE
23266 170 CONTINUE
23267
23268C...Define initial partons.
23269 NTRY=0
23270 180 NTRY=NTRY+1
23271 IF(NTRY.GT.100) THEN
23272 MINT(51)=1
23273 RETURN
23274 ENDIF
23275
23276C...Scattered quark in hadronic CM frame.
23277 I=MINT(83)+7
23278 K(IPU3,1)=3
23279 K(IPU3,2)=KFRES
23280 K(IPU3,3)=I
23281 P(IPU3,5)=PYMASS(KFRES)
23282 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
23283 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
23284 P(IPU3,5)=0D0
23285 K(I,1)=21
23286 K(I,2)=KFRES
23287 K(I,3)=MINT(83)+4+ISIDE
23288 P(I,3)=P(IPU3,3)
23289 P(I,4)=P(IPU3,4)
23290 P(I,5)=P(IPU3,5)
23291 N=IPU3
23292 MINT(21)=KFRES
23293 MINT(22)=0
23294
23295C...No primordial kT, or chosen according to truncated Gaussian or
23296C...exponential, or (for photon) predetermined or power law.
23297 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
23298 IF(MSTP(91).LE.0) THEN
23299 PT=0D0
23300 ELSEIF(MSTP(91).EQ.1) THEN
23301 PT=PARP(91)*SQRT(-LOG(PYR(0)))
23302 ELSE
23303 RPT1=PYR(0)
23304 RPT2=PYR(0)
23305 PT=-PARP(92)*LOG(RPT1*RPT2)
23306 ENDIF
23307 IF(PT.GT.PARP(93)) GOTO 190
23308 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
23309 PTA=SQRT(VINT(282+ISIDE))
23310 PTB=0D0
23311 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
23312 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
23313 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
23314 RPT1=PYR(0)
23315 RPT2=PYR(0)
23316 PTB=-PARP(99)*LOG(RPT1*RPT2)
23317 ENDIF
23318 IF(PTB.GT.PARP(100)) GOTO 190
23319 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
23320 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
23321 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
23322 IF(MSTP(93).LE.0) THEN
23323 PT=0D0
23324 ELSEIF(MSTP(93).EQ.1) THEN
23325 PT=PARP(99)*SQRT(-LOG(PYR(0)))
23326 ELSEIF(MSTP(93).EQ.2) THEN
23327 RPT1=PYR(0)
23328 RPT2=PYR(0)
23329 PT=-PARP(99)*LOG(RPT1*RPT2)
23330 ELSEIF(MSTP(93).EQ.3) THEN
23331 HA=PARP(99)**2
23332 HB=PARP(100)**2
23333 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
23334 ELSE
23335 HA=PARP(99)**2
23336 HB=PARP(100)**2
23337 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
23338 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
23339 ENDIF
23340 IF(PT.GT.PARP(100)) GOTO 190
23341 ELSE
23342 PT=0D0
23343 ENDIF
23344 VINT(156+ISIDE)=PT
23345 PHI=PARU(2)*PYR(0)
23346 P(IPU3,1)=PT*COS(PHI)
23347 P(IPU3,2)=PT*SIN(PHI)
23348 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
23349 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
23350 PCP=P(IPU3,4)+ABS(P(IPU3,3))
23351
23352C...Find one or two beam remnants.
23353 MINT(105)=MINT(102+ISIDE)
23354 MINT(109)=MINT(106+ISIDE)
23355 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
23356 IF(MINT(51).NE.0) THEN
23357 MINT(51)=0
23358 GOTO 180
23359 ENDIF
23360
23361C...Store first remnant parton, with colour info and kinematics.
23362 I=N+1
23363 K(I,1)=1
23364 K(I,2)=KFLSP
23365 K(I,3)=MINT(83)+ISIDE
23366 P(I,5)=PYMASS(K(I,2))
23367 KCOL=KCHG(PYCOMP(KFLSP),2)
23368 IF(KCOL.NE.0) THEN
23369 K(I,1)=3
23370 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
23371 K(I,KFLS+3)=MSTU(5)*IPU3
23372 K(IPU3,6-KFLS)=MSTU(5)*I
23373 ICOLR=I
23374 ENDIF
23375 IF(KFLCH.EQ.0) THEN
23376 P(I,1)=-P(IPU3,1)
23377 P(I,2)=-P(IPU3,2)
23378 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23379 P(I,3)=-P(IPU3,3)
23380 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
23381 PRP=P(I,4)+ABS(P(I,3))
23382
23383C...When extra remnant parton or hadron: store extra remnant.
23384 ELSE
23385 I=I+1
23386 K(I,1)=1
23387 K(I,2)=KFLCH
23388 K(I,3)=MINT(83)+ISIDE
23389 P(I,5)=PYMASS(K(I,2))
23390 KCOL=KCHG(PYCOMP(KFLCH),2)
23391 IF(KCOL.NE.0) THEN
23392 K(I,1)=3
23393 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
23394 K(I,KFLS+3)=MSTU(5)*IPU3
23395 K(IPU3,6-KFLS)=MSTU(5)*I
23396 ICOLR=I
23397 ENDIF
23398
23399C...Relative transverse momentum when two remnants.
23400 LOOP=0
23401 200 LOOP=LOOP+1
23402 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
23403 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
23404 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
23405 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
23406 P(I,1)=-P(IPU3,1)-P(I-1,1)
23407 P(I,2)=-P(IPU3,2)-P(I-1,2)
23408 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
23409
23410C...Relative distribution of energy for particle into jet plus particle.
23411 IMB=1
23412 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
23413 IF(MSTP(94).LE.1) THEN
23414 IF(IMB.EQ.1) CHI=PYR(0)
23415 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23416 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23417 ELSEIF(MSTP(94).EQ.2) THEN
23418 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
23419 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
23420 ELSEIF(MSTP(94).EQ.3) THEN
23421 CALL PYZDIS(1,0,PMS(4),ZZ)
23422 CHI=ZZ
23423 ELSE
23424 CALL PYZDIS(1000,0,PMS(4),ZZ)
23425 CHI=ZZ
23426 ENDIF
23427
23428C...Construct total transverse mass; reject if too large.
23429 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
23430 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
23431 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
23432 IF(LOOP.LT.10) GOTO 200
23433 GOTO 180
23434 ENDIF
23435 VINT(158+ISIDE)=CHI
23436
23437C...Subdivide longitudinal momentum according to value selected above.
23438 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
23439 PW1=(1D0-CHI)*PRP
23440 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
23441 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
23442 PW2=CHI*PRP
23443 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
23444 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
23445 ENDIF
23446 N=I
23447
23448C...Boost current and remnant systems to correct frame.
23449 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
23450 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
23451 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
23452 &(2D0*VINT(1)*PCP)
23453 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
23454 &(2D0*VINT(1)*PRP)
23455 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
23456 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
23457 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
23458 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
23459
23460C...Let current quark shower; recoil but no showering by colour partner.
23461 QMAX=2D0*SQRT(VINT(309-ISIDE))
23462 MSTJ48=MSTJ(48)
23463 MSTJ(48)=1
23464 PARJ86=PARJ(86)
23465 PARJ(86)=0D0
23466 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
23467 MSTJ(48)=MSTJ48
23468 PARJ(86)=PARJ86
23469
23470 RETURN
23471 END
23472
23473C*********************************************************************
23474
23475C...PYDOCU
23476C...Handles the documentation of the process in MSTI and PARI,
23477C...and also computes cross-sections based on accumulated statistics.
23478
23479 SUBROUTINE PYDOCU
23480
23481C...Double precision and integer declarations.
23482 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23483 IMPLICIT INTEGER(I-N)
23484 INTEGER PYK,PYCHGE,PYCOMP
23485C...Commonblocks.
23486 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23487 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23488 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23489 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23490 COMMON/PYINT1/MINT(400),VINT(400)
23491 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
23492 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
23493 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
23494 &/PYINT5/
23495
23496C...Calculate Monte Carlo estimates of cross-sections.
23497 ISUB=MINT(1)
23498 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
23499 NGEN(0,3)=NGEN(0,3)+1
23500 XSEC(0,3)=0D0
23501 DO 100 I=1,500
23502 IF(I.EQ.96.OR.I.EQ.97) THEN
23503 XSEC(I,3)=0D0
23504 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
23505 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
23506 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23507 & DBLE(NGEN(96,2)))
23508 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
23509 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
23510 & DBLE(NGEN(96,2)))
23511 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
23512 XSEC(I,3)=0D0
23513 ELSEIF(NGEN(I,2).EQ.0) THEN
23514 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
23515 & DBLE(NGEN(0,2)))
23516 ELSE
23517 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
23518 & DBLE(NGEN(I,2)))
23519 ENDIF
23520 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
23521 100 CONTINUE
23522
23523C...Rescale to known low-pT cross-section for standard QCD processes.
23524 IF(MSUB(95).EQ.1) THEN
23525 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
23526 & XSEC(68,3)+XSEC(95,3)
23527 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
23528 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
23529 FAC=XSECW/XSECH
23530 XSEC(11,3)=FAC*XSEC(11,3)
23531 XSEC(12,3)=FAC*XSEC(12,3)
23532 XSEC(13,3)=FAC*XSEC(13,3)
23533 XSEC(28,3)=FAC*XSEC(28,3)
23534 XSEC(53,3)=FAC*XSEC(53,3)
23535 XSEC(68,3)=FAC*XSEC(68,3)
23536 XSEC(95,3)=FAC*XSEC(95,3)
23537 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
23538 ENDIF
23539 ENDIF
23540
23541C...Save information for gamma-p and gamma-gamma.
23542 IF(MINT(121).GT.1) THEN
23543 IGA=MINT(122)
23544 CALL PYSAVE(2,IGA)
23545 CALL PYSAVE(5,0)
23546 ENDIF
23547
23548C...Reset information on hard interaction.
23549 DO 110 J=1,200
23550 MSTI(J)=0
23551 PARI(J)=0D0
23552 110 CONTINUE
23553
23554C...Copy integer valued information from MINT into MSTI.
23555 DO 120 J=1,32
23556 MSTI(J)=MINT(J)
23557 120 CONTINUE
23558 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
23559
23560C...Store cross-section variables in PARI.
23561 PARI(1)=XSEC(0,3)
23562 PARI(2)=XSEC(0,3)/MINT(5)
23563 PARI(7)=VINT(97)
23564 PARI(9)=VINT(99)
23565 PARI(10)=VINT(100)
23566 VINT(98)=VINT(98)+VINT(100)
23567 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
23568
23569C...Store kinematics variables in PARI.
23570 PARI(11)=VINT(1)
23571 PARI(12)=VINT(2)
23572 IF(ISUB.NE.95) THEN
23573 DO 130 J=13,26
23574 PARI(J)=VINT(30+J)
23575 130 CONTINUE
23576 PARI(29)=VINT(39)
23577 PARI(30)=VINT(40)
23578 PARI(31)=VINT(141)
23579 PARI(32)=VINT(142)
23580 PARI(33)=VINT(41)
23581 PARI(34)=VINT(42)
23582 PARI(35)=PARI(33)-PARI(34)
23583 PARI(36)=VINT(21)
23584 PARI(37)=VINT(22)
23585 PARI(38)=VINT(26)
23586 PARI(39)=VINT(157)
23587 PARI(40)=VINT(158)
23588 PARI(41)=VINT(23)
23589 PARI(42)=2D0*VINT(47)/VINT(1)
23590 ENDIF
23591
23592C...Store information on scattered partons in PARI.
23593 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
23594 DO 140 IS=7,8
23595 I=MINT(IS)
23596 PARI(36+IS)=P(I,3)/VINT(1)
23597 PARI(38+IS)=P(I,4)/VINT(1)
23598 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
23599 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23600 & SQRT(PR),1D20)),P(I,3))
23601 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
23602 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
23603 & SQRT(PR),1D20)),P(I,3))
23604 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
23605 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
23606 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
23607 140 CONTINUE
23608 ENDIF
23609
23610C...Store sum up transverse and longitudinal momenta.
23611 PARI(65)=2D0*PARI(17)
23612 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
23613 DO 150 I=MSTP(126)+1,N
23614 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
23615 PT=SQRT(P(I,1)**2+P(I,2)**2)
23616 PARI(69)=PARI(69)+PT
23617 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
23618 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
23619 150 CONTINUE
23620 PARI(67)=PARI(68)
23621 PARI(71)=VINT(151)
23622 PARI(72)=VINT(152)
23623 PARI(73)=VINT(151)
23624 PARI(74)=VINT(152)
23625 ELSE
23626 PARI(66)=PARI(65)
23627 PARI(69)=PARI(65)
23628 ENDIF
23629
23630C...Store various other pieces of information into PARI.
23631 PARI(61)=VINT(148)
23632 PARI(75)=VINT(155)
23633 PARI(76)=VINT(156)
23634 PARI(77)=VINT(159)
23635 PARI(78)=VINT(160)
23636 PARI(81)=VINT(138)
23637
23638C...Store information on lepton -> lepton + gamma in PYGAGA.
23639 MSTI(71)=MINT(141)
23640 MSTI(72)=MINT(142)
23641 PARI(101)=VINT(301)
23642 PARI(102)=VINT(302)
23643 DO 160 I=103,114
23644 PARI(I)=VINT(I+202)
23645 160 CONTINUE
23646
23647C...Set information for PYTABU.
23648 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
23649 MSTU(161)=MINT(21)
23650 MSTU(162)=0
23651 ELSEIF(ISET(ISUB).EQ.5) THEN
23652 MSTU(161)=MINT(23)
23653 MSTU(162)=0
23654 ELSE
23655 MSTU(161)=MINT(21)
23656 MSTU(162)=MINT(22)
23657 ENDIF
23658
23659 RETURN
23660 END
23661
23662C*********************************************************************
23663
23664C...PYFRAM
23665C...Performs transformations between different coordinate frames.
23666
23667 SUBROUTINE PYFRAM(IFRAME)
23668
23669C...Double precision and integer declarations.
23670 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23671 IMPLICIT INTEGER(I-N)
23672 INTEGER PYK,PYCHGE,PYCOMP
23673C...Commonblocks.
23674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23675 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23676 COMMON/PYINT1/MINT(400),VINT(400)
23677 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
23678
23679C...Check that transformation can and should be done.
23680 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
23681 &MINT(91).EQ.1)) THEN
23682 IF(IFRAME.EQ.MINT(6)) RETURN
23683 ELSE
23684 WRITE(MSTU(11),5000) IFRAME,MINT(6)
23685 RETURN
23686 ENDIF
23687
23688 IF(MINT(6).EQ.1) THEN
23689C...Transform from fixed target or user specified frame to
23690C...overall CM frame.
23691 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
23692 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
23693 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
23694 ELSEIF(MINT(6).EQ.3) THEN
23695C...Transform from hadronic CM frame in DIS to overall CM frame.
23696 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
23697 & -VINT(225))
23698 ENDIF
23699
23700 IF(IFRAME.EQ.1) THEN
23701C...Transform from overall CM frame to fixed target or user specified
23702C...frame.
23703 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
23704 ELSEIF(IFRAME.EQ.3) THEN
23705C...Transform from overall CM frame to hadronic CM frame in DIS.
23706 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
23707 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
23708 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
23709 ENDIF
23710
23711C...Set information about new frame.
23712 MINT(6)=IFRAME
23713 MSTI(6)=IFRAME
23714
23715 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
23716 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
23717 &1X,I5)
23718
23719 RETURN
23720 END
23721
23722C*********************************************************************
23723
23724C...PYWIDT
23725C...Calculates full and partial widths of resonances.
23726
23727 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
23728
23729C...Double precision and integer declarations.
23730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23731 IMPLICIT INTEGER(I-N)
23732 INTEGER PYK,PYCHGE,PYCOMP
23733C...Parameter statement to help give large particle numbers.
23734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23735 &KEXCIT=4000000,KDIMEN=5000000)
23736C...Commonblocks.
23737 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23738 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23739 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
23740 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23741 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23742 COMMON/PYINT1/MINT(400),VINT(400)
23743 COMMON/PYINT4/MWID(500),WIDS(500,5)
23744 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
23745 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
23746 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
23747 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
23748 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
23749 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/
23750C...Local arrays and saved variables.
23751 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
23752 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
23753 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
23754 SAVE MOFSV,WIDWSV,WID2SV
23755 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
23756
23757C...Compressed code and sign; mass.
23758 KFLA=IABS(KFLR)
23759 KFLS=ISIGN(1,KFLR)
23760 KC=PYCOMP(KFLA)
23761 SHR=SQRT(SH)
23762 PMR=PMAS(KC,1)
23763
23764C...Reset width information.
23765 DO 110 I=0,MDCY(KC,3)
23766 WDTP(I)=0D0
23767 DO 100 J=0,5
23768 WDTE(I,J)=0D0
23769 100 CONTINUE
23770 110 CONTINUE
23771
23772C...Allow for fudge factor to rescale resonance width.
23773 FUDGE=1D0
23774 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
23775 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
23776 IF(MSTP(110).EQ.KFLA) THEN
23777 FUDGE=PARP(110)
23778 ELSEIF(MSTP(110).EQ.-1) THEN
23779 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
23780 ELSEIF(MSTP(110).EQ.-2) THEN
23781 FUDGE=PARP(110)
23782 ENDIF
23783 ENDIF
23784
23785C...Not to be treated as a resonance: return.
23786 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
23787 &KFLA.NE.22) THEN
23788 WDTP(0)=1D0
23789 WDTE(0,0)=1D0
23790 MINT(61)=0
23791 MINT(62)=0
23792 MINT(63)=0
23793 RETURN
23794
23795C...Treatment as a resonance based on tabulated branching ratios.
23796 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
23797C...Loop over possible decay channels; skip irrelevant ones.
23798 DO 120 I=1,MDCY(KC,3)
23799 IDC=I+MDCY(KC,2)-1
23800 IF(MDME(IDC,1).LT.0) GOTO 120
23801
23802C...Read out decay products and nominal masses.
23803 KFD1=KFDP(IDC,1)
23804 KFC1=PYCOMP(KFD1)
23805 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
23806 PM1=PMAS(KFC1,1)
23807 KFD2=KFDP(IDC,2)
23808 KFC2=PYCOMP(KFD2)
23809 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
23810 PM2=PMAS(KFC2,1)
23811 KFD3=KFDP(IDC,3)
23812 PM3=0D0
23813 IF(KFD3.NE.0) THEN
23814 KFC3=PYCOMP(KFD3)
23815 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
23816 PM3=PMAS(KFC3,1)
23817 ENDIF
23818
23819C...Naive partial width and alternative threshold factors.
23820 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
23821 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
23822 & PM1+PM2+PM3.GE.SHR) THEN
23823 WDTP(I)=0D0
23824 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
23825 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
23826 & 4D0*PM1**2*PM2**2))/SH
23827 ELSEIF(MDME(IDC,2).EQ.52) THEN
23828 PMA=MAX(PM1,PM2,PM3)
23829 PMC=MIN(PM1,PM2,PM3)
23830 PMB=PM1+PM2+PM3-PMA-PMC
23831 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
23832 PMAN=PMA**2/SH
23833 PMBN=PMB**2/SH
23834 PMCN=PMC**2/SH
23835 PMBCN=PMBC**2/SH
23836 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
23837 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23838 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23839 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23840 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23841 & ((1D0-PMBCN)*PMBCN*SH)
23842 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
23843 WDTP(I)=WDTP(I)*SQRT(
23844 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
23845 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
23846 ELSEIF(MDME(IDC,2).EQ.53) THEN
23847 PMA=MAX(PM1,PM2,PM3)
23848 PMC=MIN(PM1,PM2,PM3)
23849 PMB=PM1+PM2+PM3-PMA-PMC
23850 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
23851 PMAN=PMA**2/SH
23852 PMBN=PMB**2/SH
23853 PMCN=PMC**2/SH
23854 PMBCN=PMBC**2/SH
23855 FACACT=SQRT(MAX(0D0,
23856 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23857 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23858 & ((SHR-PMA)**2-(PMB+PMC)**2)*
23859 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
23860 & ((1D0-PMBCN)*PMBCN*SH)
23861 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
23862 PMAN=PMA**2/PMR**2
23863 PMBN=PMB**2/PMR**2
23864 PMCN=PMC**2/PMR**2
23865 PMBCN=PMBC**2/PMR**2
23866 FACNOM=SQRT(MAX(0D0,
23867 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
23868 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
23869 & ((PMR-PMA)**2-(PMB+PMC)**2)*
23870 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
23871 & ((1D0-PMBCN)*PMBCN*PMR**2)
23872 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
23873 ENDIF
23874 WDTP(I)=FUDGE*WDTP(I)
23875 WDTP(0)=WDTP(0)+WDTP(I)
23876
23877C...Calculate secondary width (at most two identical/opposite).
23878 WID2=1D0
23879 IF(MDME(IDC,1).GT.0) THEN
23880 IF(KFD2.EQ.KFD1) THEN
23881 IF(KCHG(KFC1,3).EQ.0) THEN
23882 WID2=WIDS(KFC1,1)
23883 ELSEIF(KFD1.GT.0) THEN
23884 WID2=WIDS(KFC1,4)
23885 ELSE
23886 WID2=WIDS(KFC1,5)
23887 ENDIF
23888 IF(KFD3.GT.0) THEN
23889 WID2=WID2*WIDS(KFC3,2)
23890 ELSEIF(KFD3.LT.0) THEN
23891 WID2=WID2*WIDS(KFC3,3)
23892 ENDIF
23893 ELSEIF(KFD2.EQ.-KFD1) THEN
23894 WID2=WIDS(KFC1,1)
23895 IF(KFD3.GT.0) THEN
23896 WID2=WID2*WIDS(KFC3,2)
23897 ELSEIF(KFD3.LT.0) THEN
23898 WID2=WID2*WIDS(KFC3,3)
23899 ENDIF
23900 ELSEIF(KFD3.EQ.KFD1) THEN
23901 IF(KCHG(KFC1,3).EQ.0) THEN
23902 WID2=WIDS(KFC1,1)
23903 ELSEIF(KFD1.GT.0) THEN
23904 WID2=WIDS(KFC1,4)
23905 ELSE
23906 WID2=WIDS(KFC1,5)
23907 ENDIF
23908 IF(KFD2.GT.0) THEN
23909 WID2=WID2*WIDS(KFC2,2)
23910 ELSEIF(KFD2.LT.0) THEN
23911 WID2=WID2*WIDS(KFC2,3)
23912 ENDIF
23913 ELSEIF(KFD3.EQ.-KFD1) THEN
23914 WID2=WIDS(KFC1,1)
23915 IF(KFD2.GT.0) THEN
23916 WID2=WID2*WIDS(KFC2,2)
23917 ELSEIF(KFD2.LT.0) THEN
23918 WID2=WID2*WIDS(KFC2,3)
23919 ENDIF
23920 ELSEIF(KFD3.EQ.KFD2) THEN
23921 IF(KCHG(KFC2,3).EQ.0) THEN
23922 WID2=WIDS(KFC2,1)
23923 ELSEIF(KFD2.GT.0) THEN
23924 WID2=WIDS(KFC2,4)
23925 ELSE
23926 WID2=WIDS(KFC2,5)
23927 ENDIF
23928 IF(KFD1.GT.0) THEN
23929 WID2=WID2*WIDS(KFC1,2)
23930 ELSEIF(KFD1.LT.0) THEN
23931 WID2=WID2*WIDS(KFC1,3)
23932 ENDIF
23933 ELSEIF(KFD3.EQ.-KFD2) THEN
23934 WID2=WIDS(KFC2,1)
23935 IF(KFD1.GT.0) THEN
23936 WID2=WID2*WIDS(KFC1,2)
23937 ELSEIF(KFD1.LT.0) THEN
23938 WID2=WID2*WIDS(KFC1,3)
23939 ENDIF
23940 ELSE
23941 IF(KFD1.GT.0) THEN
23942 WID2=WIDS(KFC1,2)
23943 ELSE
23944 WID2=WIDS(KFC1,3)
23945 ENDIF
23946 IF(KFD2.GT.0) THEN
23947 WID2=WID2*WIDS(KFC2,2)
23948 ELSE
23949 WID2=WID2*WIDS(KFC2,3)
23950 ENDIF
23951 IF(KFD3.GT.0) THEN
23952 WID2=WID2*WIDS(KFC3,2)
23953 ELSEIF(KFD3.LT.0) THEN
23954 WID2=WID2*WIDS(KFC3,3)
23955 ENDIF
23956 ENDIF
23957
23958C...Store effective widths according to case.
23959 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
23960 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
23961 WDTE(I,0)=WDTE(I,MDME(IDC,1))
23962 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
23963 ENDIF
23964 120 CONTINUE
23965C...Return.
23966 MINT(61)=0
23967 MINT(62)=0
23968 MINT(63)=0
23969 RETURN
23970 ENDIF
23971
23972C...Here begins detailed dynamical calculation of resonance widths.
23973C...Shared treatment of Higgs states.
23974 KFHIGG=25
23975 IHIGG=1
23976 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
23977 KFHIGG=KFLA
23978 IHIGG=KFLA-33
23979 ENDIF
23980
23981C...Common electroweak and strong constants.
23982 XW=PARU(102)
23983 XWV=XW
23984 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
23985 XW1=1D0-XW
23986 AEM=PYALEM(SH)
23987 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
23988 AS=PYALPS(SH)
23989 RADC=1D0+AS/PARU(1)
23990
23991 IF(KFLA.EQ.6) THEN
23992C...t quark.
23993 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
23994 RADCT=1D0-2.5D0*AS/PARU(1)
23995 DO 140 I=1,MDCY(KC,3)
23996 IDC=I+MDCY(KC,2)-1
23997 IF(MDME(IDC,1).LT.0) GOTO 140
23998 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
23999 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24000 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24001 WID2=1D0
24002 IF(I.GE.4.AND.I.LE.7) THEN
24003C...t -> W + q; including approximate QCD correction factor.
24004 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24005 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24006 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24007 IF(KFLR.GT.0) THEN
24008 WID2=WIDS(24,2)
24009 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24010 ELSE
24011 WID2=WIDS(24,3)
24012 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24013 ENDIF
24014 ELSEIF(I.EQ.9) THEN
24015C...t -> H + b.
24016 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24017 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24018 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24019 & 4D0*SQRT(RM2R*RM2))
24020 WID2=WIDS(37,2)
24021 IF(KFLR.LT.0) WID2=WIDS(37,3)
24022CMRENNA++
24023 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24024C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24025 BETA=ATAN(RMSS(5))
24026 SINB=SIN(BETA)
24027 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24028 ET=KCHG(6,1)/3D0
24029 T3L=SIGN(0.5D0,ET)
24030 KFC1=PYCOMP(KFDP(IDC,1))
24031 KFC2=PYCOMP(KFDP(IDC,2))
24032 PMNCHI=PMAS(KFC1,1)
24033 PMSTOP=PMAS(KFC2,1)
24034 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24035 IZ=I-9
24036 DO 130 IK=1,4
24037 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24038 130 CONTINUE
24039 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24040 AR=-ET*ZMIXC(IZ,1)*TANW
24041 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24042 BR=AL
24043 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24044 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24045 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24046 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24047 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24048 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24049 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24050 IF(KFLR.GT.0) THEN
24051 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24052 ELSE
24053 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24054 ENDIF
24055 ENDIF
24056 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24057C...t -> ~g + ~t
24058 KFC1=PYCOMP(KFDP(IDC,1))
24059 KFC2=PYCOMP(KFDP(IDC,2))
24060 PMNCHI=PMAS(KFC1,1)
24061 PMSTOP=PMAS(KFC2,1)
24062 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24063 RL=SFMIX(6,1)
24064 RR=-SFMIX(6,2)
24065 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24066 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24067 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24068 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24069 IF(KFLR.GT.0) THEN
24070 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24071 ELSE
24072 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24073 ENDIF
24074 ENDIF
24075 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24076C...t -> ~gravitino + ~t
24077 XMP2=RMSS(29)**2
24078 KFC1=PYCOMP(KFDP(IDC,1))
24079 XMGR2=PMAS(KFC1,1)**2
24080 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24081 KFC2=PYCOMP(KFDP(IDC,2))
24082 WID2=WIDS(KFC2,2)
24083 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24084CMRENNA--
24085 ENDIF
24086 WDTP(I)=FUDGE*WDTP(I)
24087 WDTP(0)=WDTP(0)+WDTP(I)
24088 IF(MDME(IDC,1).GT.0) THEN
24089 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24090 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24091 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24092 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24093 ENDIF
24094 140 CONTINUE
24095
24096 ELSEIF(KFLA.EQ.7) THEN
24097C...b' quark.
24098 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24099 DO 150 I=1,MDCY(KC,3)
24100 IDC=I+MDCY(KC,2)-1
24101 IF(MDME(IDC,1).LT.0) GOTO 150
24102 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24103 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24104 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24105 WID2=1D0
24106 IF(I.GE.4.AND.I.LE.7) THEN
24107C...b' -> W + q.
24108 WDTP(I)=FAC*VCKM(I-3,4)*
24109 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24110 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24111 IF(KFLR.GT.0) THEN
24112 WID2=WIDS(24,3)
24113 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24114 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24115 ELSE
24116 WID2=WIDS(24,2)
24117 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24118 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24119 ENDIF
24120 WID2=WIDS(24,3)
24121 IF(KFLR.LT.0) WID2=WIDS(24,2)
24122 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24123C...b' -> H + q.
24124 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24125 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24126 IF(KFLR.GT.0) THEN
24127 WID2=WIDS(37,3)
24128 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24129 ELSE
24130 WID2=WIDS(37,2)
24131 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24132 ENDIF
24133 ENDIF
24134 WDTP(I)=FUDGE*WDTP(I)
24135 WDTP(0)=WDTP(0)+WDTP(I)
24136 IF(MDME(IDC,1).GT.0) THEN
24137 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24138 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24139 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24140 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24141 ENDIF
24142 150 CONTINUE
24143
24144 ELSEIF(KFLA.EQ.8) THEN
24145C...t' quark.
24146 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24147 DO 160 I=1,MDCY(KC,3)
24148 IDC=I+MDCY(KC,2)-1
24149 IF(MDME(IDC,1).LT.0) GOTO 160
24150 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24151 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24152 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24153 WID2=1D0
24154 IF(I.GE.4.AND.I.LE.7) THEN
24155C...t' -> W + q.
24156 WDTP(I)=FAC*VCKM(4,I-3)*
24157 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24158 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24159 IF(KFLR.GT.0) THEN
24160 WID2=WIDS(24,2)
24161 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24162 ELSE
24163 WID2=WIDS(24,3)
24164 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24165 ENDIF
24166 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24167C...t' -> H + q.
24168 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24169 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24170 IF(KFLR.GT.0) THEN
24171 WID2=WIDS(37,2)
24172 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24173 ELSE
24174 WID2=WIDS(37,3)
24175 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24176 ENDIF
24177 ENDIF
24178 WDTP(I)=FUDGE*WDTP(I)
24179 WDTP(0)=WDTP(0)+WDTP(I)
24180 IF(MDME(IDC,1).GT.0) THEN
24181 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24182 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24183 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24184 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24185 ENDIF
24186 160 CONTINUE
24187
24188 ELSEIF(KFLA.EQ.17) THEN
24189C...tau' lepton.
24190 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24191 DO 170 I=1,MDCY(KC,3)
24192 IDC=I+MDCY(KC,2)-1
24193 IF(MDME(IDC,1).LT.0) GOTO 170
24194 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24195 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24196 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24197 WID2=1D0
24198 IF(I.EQ.3) THEN
24199C...tau' -> W + nu'_tau.
24200 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24201 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24202 IF(KFLR.GT.0) THEN
24203 WID2=WIDS(24,3)
24204 WID2=WID2*WIDS(18,2)
24205 ELSE
24206 WID2=WIDS(24,2)
24207 WID2=WID2*WIDS(18,3)
24208 ENDIF
24209 ELSEIF(I.EQ.5) THEN
24210C...tau' -> H + nu'_tau.
24211 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24212 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24213 IF(KFLR.GT.0) THEN
24214 WID2=WIDS(37,3)
24215 WID2=WID2*WIDS(18,2)
24216 ELSE
24217 WID2=WIDS(37,2)
24218 WID2=WID2*WIDS(18,3)
24219 ENDIF
24220 ENDIF
24221 WDTP(I)=FUDGE*WDTP(I)
24222 WDTP(0)=WDTP(0)+WDTP(I)
24223 IF(MDME(IDC,1).GT.0) THEN
24224 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24225 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24226 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24227 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24228 ENDIF
24229 170 CONTINUE
24230
24231 ELSEIF(KFLA.EQ.18) THEN
24232C...nu'_tau neutrino.
24233 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24234 DO 180 I=1,MDCY(KC,3)
24235 IDC=I+MDCY(KC,2)-1
24236 IF(MDME(IDC,1).LT.0) GOTO 180
24237 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24238 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24239 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24240 WID2=1D0
24241 IF(I.EQ.2) THEN
24242C...nu'_tau -> W + tau'.
24243 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24244 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24245 IF(KFLR.GT.0) THEN
24246 WID2=WIDS(24,2)
24247 WID2=WID2*WIDS(17,2)
24248 ELSE
24249 WID2=WIDS(24,3)
24250 WID2=WID2*WIDS(17,3)
24251 ENDIF
24252 ELSEIF(I.EQ.3) THEN
24253C...nu'_tau -> H + tau'.
24254 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24255 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24256 IF(KFLR.GT.0) THEN
24257 WID2=WIDS(37,2)
24258 WID2=WID2*WIDS(17,2)
24259 ELSE
24260 WID2=WIDS(37,3)
24261 WID2=WID2*WIDS(17,3)
24262 ENDIF
24263 ENDIF
24264 WDTP(I)=FUDGE*WDTP(I)
24265 WDTP(0)=WDTP(0)+WDTP(I)
24266 IF(MDME(IDC,1).GT.0) THEN
24267 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24268 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24269 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24270 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24271 ENDIF
24272 180 CONTINUE
24273
24274 ELSEIF(KFLA.EQ.21) THEN
24275C...QCD:
24276C***Note that widths are not given in dimensional quantities here.
24277 DO 190 I=1,MDCY(KC,3)
24278 IDC=I+MDCY(KC,2)-1
24279 IF(MDME(IDC,1).LT.0) GOTO 190
24280 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24281 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24282 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
24283 WID2=1D0
24284 IF(I.LE.8) THEN
24285C...QCD -> q + qbar
24286 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24287 IF(I.EQ.6) WID2=WIDS(6,1)
24288 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24289 ENDIF
24290 WDTP(I)=FUDGE*WDTP(I)
24291 WDTP(0)=WDTP(0)+WDTP(I)
24292 IF(MDME(IDC,1).GT.0) THEN
24293 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24294 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24295 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24296 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24297 ENDIF
24298 190 CONTINUE
24299
24300 ELSEIF(KFLA.EQ.22) THEN
24301C...QED photon.
24302C***Note that widths are not given in dimensional quantities here.
24303 DO 200 I=1,MDCY(KC,3)
24304 IDC=I+MDCY(KC,2)-1
24305 IF(MDME(IDC,1).LT.0) GOTO 200
24306 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24307 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24308 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
24309 WID2=1D0
24310 IF(I.LE.8) THEN
24311C...QED -> q + qbar.
24312 EF=KCHG(I,1)/3D0
24313 FCOF=3D0*RADC
24314 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24315 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24316 IF(I.EQ.6) WID2=WIDS(6,1)
24317 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24318 ELSEIF(I.LE.12) THEN
24319C...QED -> l+ + l-.
24320 EF=KCHG(9+2*(I-8),1)/3D0
24321 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24322 IF(I.EQ.12) WID2=WIDS(17,1)
24323 ENDIF
24324 WDTP(I)=FUDGE*WDTP(I)
24325 WDTP(0)=WDTP(0)+WDTP(I)
24326 IF(MDME(IDC,1).GT.0) THEN
24327 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24328 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24329 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24330 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24331 ENDIF
24332 200 CONTINUE
24333
24334 ELSEIF(KFLA.EQ.23) THEN
24335C...Z0:
24336 ICASE=1
24337 XWC=1D0/(16D0*XW*XW1)
24338 FAC=(AEM*XWC/3D0)*SHR
24339 210 CONTINUE
24340 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24341 VINT(111)=0D0
24342 VINT(112)=0D0
24343 VINT(114)=0D0
24344 ENDIF
24345 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24346 KFI=IABS(MINT(15))
24347 IF(KFI.GT.20) KFI=IABS(MINT(16))
24348 EI=KCHG(KFI,1)/3D0
24349 AI=SIGN(1D0,EI)
24350 VI=AI-4D0*EI*XWV
24351 SQMZ=PMAS(23,1)**2
24352 HZ=SHR*WDTP(0)
24353 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
24354 IF(MSTP(43).EQ.3) VINT(112)=
24355 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24356 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24357 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24358 ENDIF
24359 DO 220 I=1,MDCY(KC,3)
24360 IDC=I+MDCY(KC,2)-1
24361 IF(MDME(IDC,1).LT.0) GOTO 220
24362 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24363 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24364 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
24365 WID2=1D0
24366 IF(I.LE.8) THEN
24367C...Z0 -> q + qbar
24368 EF=KCHG(I,1)/3D0
24369 AF=SIGN(1D0,EF+0.1D0)
24370 VF=AF-4D0*EF*XWV
24371 FCOF=3D0*RADC
24372 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
24373 IF(I.EQ.6) WID2=WIDS(6,1)
24374 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24375 ELSEIF(I.LE.16) THEN
24376C...Z0 -> l+ + l-, nu + nubar
24377 EF=KCHG(I+2,1)/3D0
24378 AF=SIGN(1D0,EF+0.1D0)
24379 VF=AF-4D0*EF*XWV
24380 FCOF=1D0
24381 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24382 ENDIF
24383 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24384 IF(ICASE.EQ.1) THEN
24385 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
24386 & BE34
24387 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24388 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24389 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
24390 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
24391 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24392 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24393 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24394 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24395 ENDIF
24396 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
24397 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
24398 IF(MDME(IDC,1).GT.0) THEN
24399 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
24400 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
24401 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24402 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
24403 & WDTE(I,MDME(IDC,1))
24404 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24405 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24406 ENDIF
24407 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
24408 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
24409 & VINT(111)+FGGF*WID2
24410 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
24411 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
24412 & VINT(114)+FZZF*WID2
24413 ENDIF
24414 ENDIF
24415 220 CONTINUE
24416 IF(MINT(61).GE.1) ICASE=3-ICASE
24417 IF(ICASE.EQ.2) GOTO 210
24418
24419 ELSEIF(KFLA.EQ.24) THEN
24420C...W+/-:
24421 FAC=(AEM/(24D0*XW))*SHR
24422 DO 230 I=1,MDCY(KC,3)
24423 IDC=I+MDCY(KC,2)-1
24424 IF(MDME(IDC,1).LT.0) GOTO 230
24425 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
24426 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
24427 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
24428 WID2=1D0
24429 IF(I.LE.16) THEN
24430C...W+/- -> q + qbar'
24431 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
24432 IF(KFLR.GT.0) THEN
24433 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
24434 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
24435 IF(I.GE.13) WID2=WID2*WIDS(7,3)
24436 ELSE
24437 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
24438 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
24439 IF(I.GE.13) WID2=WID2*WIDS(7,2)
24440 ENDIF
24441 ELSEIF(I.LE.20) THEN
24442C...W+/- -> l+/- + nu
24443 FCOF=1D0
24444 IF(KFLR.GT.0) THEN
24445 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
24446 ELSE
24447 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
24448 ENDIF
24449 ENDIF
24450 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
24451 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
24452 WDTP(I)=FUDGE*WDTP(I)
24453 WDTP(0)=WDTP(0)+WDTP(I)
24454 IF(MDME(IDC,1).GT.0) THEN
24455 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24456 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24457 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24458 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24459 ENDIF
24460 230 CONTINUE
24461
24462 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24463C...h0 (or H0, or A0):
24464 SHFS=SH
24465 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
24466 DO 270 I=1,MDCY(KFHIGG,3)
24467 IDC=I+MDCY(KFHIGG,2)-1
24468 IF(MDME(IDC,1).LT.0) GOTO 270
24469 KFC1=PYCOMP(KFDP(IDC,1))
24470 KFC2=PYCOMP(KFDP(IDC,2))
24471 RM1=PMAS(KFC1,1)**2/SH
24472 RM2=PMAS(KFC2,1)**2/SH
24473 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
24474 & GOTO 270
24475 WID2=1D0
24476
24477 IF(I.LE.8) THEN
24478C...h0 -> q + qbar
24479 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
24480 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
24481C...A0 behaves like beta, ho and H0 like beta**3.
24482 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24483 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24484 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
24485 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
24486 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
24487 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
24488 IF(IHIGG.NE.3) THEN
24489 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
24490 & PARU(151+10*IHIGG))**2
24491 ENDIF
24492 ENDIF
24493 ENDIF
24494 IF(I.EQ.6) WID2=WIDS(6,1)
24495 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24496 ELSEIF(I.LE.12) THEN
24497C...h0 -> l+ + l-
24498 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
24499C...A0 behaves like beta, ho and H0 like beta**3.
24500 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
24501 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24502 & PARU(153+10*IHIGG)**2
24503 IF(I.EQ.12) WID2=WIDS(17,1)
24504
24505 ELSEIF(I.EQ.13) THEN
24506C...h0 -> g + g; quark loop contribution only
24507 ETARE=0D0
24508 ETAIM=0D0
24509 DO 240 J=1,2*MSTP(1)
24510 EPS=(2D0*PMAS(J,1))**2/SH
24511C...Loop integral; function of eps=4m^2/shat; different for A0.
24512 IF(EPS.LE.1D0) THEN
24513 IF(EPS.GT.1D-4) THEN
24514 ROOT=SQRT(1D0-EPS)
24515 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24516 ELSE
24517 RLN=LOG(4D0/EPS-2D0)
24518 ENDIF
24519 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24520 PHIIM=0.5D0*PARU(1)*RLN
24521 ELSE
24522 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24523 PHIIM=0D0
24524 ENDIF
24525 IF(IHIGG.LE.2) THEN
24526 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24527 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
24528 ELSE
24529 ETAREJ=-0.5D0*EPS*PHIRE
24530 ETAIMJ=-0.5D0*EPS*PHIIM
24531 ENDIF
24532C...Couplings (=1 for standard model Higgs).
24533 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24534 IF(MOD(J,2).EQ.1) THEN
24535 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
24536 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
24537 ELSE
24538 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
24539 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
24540 ENDIF
24541 ENDIF
24542 ETARE=ETARE+ETAREJ
24543 ETAIM=ETAIM+ETAIMJ
24544 240 CONTINUE
24545 ETA2=ETARE**2+ETAIM**2
24546 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
24547
24548 ELSEIF(I.EQ.14) THEN
24549C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
24550 ETARE=0D0
24551 ETAIM=0D0
24552 JMAX=3*MSTP(1)+1
24553 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24554 DO 250 J=1,JMAX
24555 IF(J.LE.2*MSTP(1)) THEN
24556 EJ=KCHG(J,1)/3D0
24557 EPS=(2D0*PMAS(J,1))**2/SH
24558 ELSEIF(J.LE.3*MSTP(1)) THEN
24559 JL=2*(J-2*MSTP(1))-1
24560 EJ=KCHG(10+JL,1)/3D0
24561 EPS=(2D0*PMAS(10+JL,1))**2/SH
24562 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24563 EPS=(2D0*PMAS(24,1))**2/SH
24564 ELSE
24565 EPS=(2D0*PMAS(37,1))**2/SH
24566 ENDIF
24567C...Loop integral; function of eps=4m^2/shat.
24568 IF(EPS.LE.1D0) THEN
24569 IF(EPS.GT.1D-4) THEN
24570 ROOT=SQRT(1D0-EPS)
24571 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24572 ELSE
24573 RLN=LOG(4D0/EPS-2D0)
24574 ENDIF
24575 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24576 PHIIM=0.5D0*PARU(1)*RLN
24577 ELSE
24578 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24579 PHIIM=0D0
24580 ENDIF
24581 IF(J.LE.3*MSTP(1)) THEN
24582C...Fermion loops: loop integral different for A0; charges.
24583 IF(IHIGG.LE.2) THEN
24584 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
24585 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
24586 ELSE
24587 PHIPRE=-0.5D0*EPS*PHIRE
24588 PHIPIM=-0.5D0*EPS*PHIIM
24589 ENDIF
24590 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24591 EJC=3D0*EJ**2
24592 EJH=PARU(151+10*IHIGG)
24593 ELSEIF(J.LE.2*MSTP(1)) THEN
24594 EJC=3D0*EJ**2
24595 EJH=PARU(152+10*IHIGG)
24596 ELSE
24597 EJC=EJ**2
24598 EJH=PARU(153+10*IHIGG)
24599 ENDIF
24600 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24601 ETAREJ=EJC*EJH*PHIPRE
24602 ETAIMJ=EJC*EJH*PHIPIM
24603 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24604C...W loops: loop integral and charges.
24605 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
24606 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
24607 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24608 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24609 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24610 ENDIF
24611 ELSE
24612C...Charged H loops: loop integral and charges.
24613 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
24614 & PARU(158+10*IHIGG+2*(IHIGG/3))
24615 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
24616 ETAIMJ=-EPS**2*PHIIM*FACHHH
24617 ENDIF
24618 ETARE=ETARE+ETAREJ
24619 ETAIM=ETAIM+ETAIMJ
24620 250 CONTINUE
24621 ETA2=ETARE**2+ETAIM**2
24622 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
24623
24624 ELSEIF(I.EQ.15) THEN
24625C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
24626 ETARE=0D0
24627 ETAIM=0D0
24628 JMAX=3*MSTP(1)+1
24629 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
24630 DO 260 J=1,JMAX
24631 IF(J.LE.2*MSTP(1)) THEN
24632 EJ=KCHG(J,1)/3D0
24633 AJ=SIGN(1D0,EJ+0.1D0)
24634 VJ=AJ-4D0*EJ*XWV
24635 EPS=(2D0*PMAS(J,1))**2/SH
24636 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
24637 ELSEIF(J.LE.3*MSTP(1)) THEN
24638 JL=2*(J-2*MSTP(1))-1
24639 EJ=KCHG(10+JL,1)/3D0
24640 AJ=SIGN(1D0,EJ+0.1D0)
24641 VJ=AJ-4D0*EJ*XWV
24642 EPS=(2D0*PMAS(10+JL,1))**2/SH
24643 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
24644 ELSE
24645 EPS=(2D0*PMAS(24,1))**2/SH
24646 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
24647 ENDIF
24648C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
24649 IF(EPS.LE.1D0) THEN
24650 ROOT=SQRT(1D0-EPS)
24651 IF(EPS.GT.1D-4) THEN
24652 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24653 ELSE
24654 RLN=LOG(4D0/EPS-2D0)
24655 ENDIF
24656 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
24657 PHIIM=0.5D0*PARU(1)*RLN
24658 PSIRE=0.5D0*ROOT*RLN
24659 PSIIM=-0.5D0*ROOT*PARU(1)
24660 ELSE
24661 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
24662 PHIIM=0D0
24663 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
24664 PSIIM=0D0
24665 ENDIF
24666 IF(EPSP.LE.1D0) THEN
24667 ROOT=SQRT(1D0-EPSP)
24668 IF(EPSP.GT.1D-4) THEN
24669 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
24670 ELSE
24671 RLN=LOG(4D0/EPSP-2D0)
24672 ENDIF
24673 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
24674 PHIIMP=0.5D0*PARU(1)*RLN
24675 PSIREP=0.5D0*ROOT*RLN
24676 PSIIMP=-0.5D0*ROOT*PARU(1)
24677 ELSE
24678 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
24679 PHIIMP=0D0
24680 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
24681 PSIIMP=0D0
24682 ENDIF
24683 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
24684 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
24685 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
24686 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
24687 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
24688 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
24689 IF(J.LE.3*MSTP(1)) THEN
24690C...Fermion loops: loop integral different for A0; charges.
24691 IF(IHIGG.EQ.3) FXYRE=0D0
24692 IF(IHIGG.EQ.3) FXYIM=0D0
24693 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
24694 EJC=-3D0*EJ*VJ
24695 EJH=PARU(151+10*IHIGG)
24696 ELSEIF(J.LE.2*MSTP(1)) THEN
24697 EJC=-3D0*EJ*VJ
24698 EJH=PARU(152+10*IHIGG)
24699 ELSE
24700 EJC=-EJ*VJ
24701 EJH=PARU(153+10*IHIGG)
24702 ENDIF
24703 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
24704 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
24705 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
24706 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
24707C...W loops: loop integral and charges.
24708 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
24709 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
24710 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
24711 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
24712 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
24713 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
24714 ENDIF
24715 ELSE
24716C...Charged H loops: loop integral and charges.
24717 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
24718 & PARU(158+10*IHIGG+2*(IHIGG/3))
24719 ETAREJ=FACHHH*FXYRE
24720 ETAIMJ=FACHHH*FXYIM
24721 ENDIF
24722 ETARE=ETARE+ETAREJ
24723 ETAIM=ETAIM+ETAIMJ
24724 260 CONTINUE
24725 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
24726 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
24727 WID2=WIDS(23,2)
24728
24729 ELSEIF(I.LE.17) THEN
24730C...h0 -> Z0 + Z0, W+ + W-
24731 PM1=PMAS(IABS(KFDP(IDC,1)),1)
24732 PG1=PMAS(IABS(KFDP(IDC,1)),2)
24733 IF(MINT(62).GE.1) THEN
24734 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
24735 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
24736 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
24737 MOFSV(IHIGG,I-15)=0
24738 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24739 & 1D0-4D0*RM1))
24740 WID2=1D0
24741 ELSE
24742 MOFSV(IHIGG,I-15)=1
24743 RMAS=SQRT(MAX(0D0,SH))
24744 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
24745 & WID2)
24746 WIDWSV(IHIGG,I-15)=WIDW
24747 WID2SV(IHIGG,I-15)=WID2
24748 ENDIF
24749 ELSE
24750 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
24751 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
24752 & 1D0-4D0*RM1))
24753 WID2=1D0
24754 ELSE
24755 WIDW=WIDWSV(IHIGG,I-15)
24756 WID2=WID2SV(IHIGG,I-15)
24757 ENDIF
24758 ENDIF
24759 WDTP(I)=FAC*WIDW/(2D0*(18-I))
24760 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
24761 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
24762 & PARU(138+I+10*IHIGG)**2
24763 WID2=WID2*WIDS(7+I,1)
24764
24765 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
24766C...H0 -> Z0 + h0, A0-> Z0 + h0
24767 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24768 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24769 IF(IHIGG.EQ.2) THEN
24770 WDTP(I)=WDTP(I)*PARU(179)**2
24771 ELSEIF(IHIGG.EQ.3) THEN
24772 WDTP(I)=WDTP(I)*PARU(186)**2
24773 ENDIF
24774 WID2=WIDS(23,2)*WIDS(25,2)
24775
24776 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
24777C...H0 -> h0 + h0, A0-> h0 + h0
24778 WDTP(I)=FAC*0.25D0*
24779 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24780 IF(IHIGG.EQ.2) THEN
24781 WDTP(I)=WDTP(I)*PARU(176)**2
24782 ELSEIF(IHIGG.EQ.3) THEN
24783 WDTP(I)=WDTP(I)*PARU(169)**2
24784 ENDIF
24785 WID2=WIDS(25,1)
24786 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
24787C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
24788 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
24789 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24790 & *PARU(195+IHIGG)**2
24791 IF(I.EQ.20) THEN
24792 WID2=WIDS(24,2)*WIDS(37,3)
24793 ELSEIF(I.EQ.21) THEN
24794 WID2=WIDS(24,3)*WIDS(37,2)
24795 ENDIF
24796
24797 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
24798C...H0 -> Z0 + A0.
24799 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
24800 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
24801 WID2=WIDS(36,2)*WIDS(23,2)
24802
24803 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
24804C...H0 -> h0 + A0.
24805 WDTP(I)=FAC*0.5D0*PARU(180)**2*
24806 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24807 WID2=WIDS(25,2)*WIDS(36,2)
24808
24809 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
24810C...H0 -> A0 + A0
24811 WDTP(I)=FAC*0.25D0*PARU(177)**2*
24812 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
24813 WID2=WIDS(36,1)
24814
24815CMRENNA++
24816 ELSE
24817C...Add in SUSY decays (two-body) by rescaling by phase space factor.
24818 RM10=RM1*SH/PMR**2
24819 RM20=RM2*SH/PMR**2
24820 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
24821 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
24822 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
24823 WFAC=0D0
24824 ELSE
24825 WFAC=WFAC/WFAC0
24826 ENDIF
24827 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
24828CMRENNA--
24829 IF(KFC2.EQ.KFC1) THEN
24830 WID2=WIDS(KFC1,1)
24831 ELSE
24832 KSGN1=2
24833 IF(KFDP(IDC,1).LT.0) KSGN1=3
24834 KSGN2=2
24835 IF(KFDP(IDC,2).LT.0) KSGN2=3
24836 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
24837 ENDIF
24838 ENDIF
24839 WDTP(I)=FUDGE*WDTP(I)
24840 WDTP(0)=WDTP(0)+WDTP(I)
24841 IF(MDME(IDC,1).GT.0) THEN
24842 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24843 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24844 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24845 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24846 ENDIF
24847 270 CONTINUE
24848
24849 ELSEIF(KFLA.EQ.32) THEN
24850C...Z'0:
24851 ICASE=1
24852 XWC=1D0/(16D0*XW*XW1)
24853 FAC=(AEM*XWC/3D0)*SHR
24854 VINT(117)=0D0
24855 280 CONTINUE
24856 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
24857 VINT(111)=0D0
24858 VINT(112)=0D0
24859 VINT(113)=0D0
24860 VINT(114)=0D0
24861 VINT(115)=0D0
24862 VINT(116)=0D0
24863 ENDIF
24864 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24865 KFAI=IABS(MINT(15))
24866 EI=KCHG(KFAI,1)/3D0
24867 AI=SIGN(1D0,EI+0.1D0)
24868 VI=AI-4D0*EI*XWV
24869 KFAIC=1
24870 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
24871 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
24872 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
24873 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
24874 VPI=PARU(119+2*KFAIC)
24875 API=PARU(120+2*KFAIC)
24876 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
24877 VPI=PARJ(178+2*KFAIC)
24878 API=PARJ(179+2*KFAIC)
24879 ELSE
24880 VPI=PARJ(186+2*KFAIC)
24881 API=PARJ(187+2*KFAIC)
24882 ENDIF
24883 SQMZ=PMAS(23,1)**2
24884 HZ=SHR*VINT(117)
24885 SQMZP=PMAS(32,1)**2
24886 HZP=SHR*WDTP(0)
24887 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
24888 & MSTP(44).EQ.7) VINT(111)=1D0
24889 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
24890 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
24891 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
24892 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
24893 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
24894 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
24895 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
24896 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
24897 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
24898 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
24899 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
24900 ENDIF
24901 DO 290 I=1,MDCY(KC,3)
24902 IDC=I+MDCY(KC,2)-1
24903 IF(MDME(IDC,1).LT.0) GOTO 290
24904 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24905 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24906 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
24907 WID2=1D0
24908 IF(I.LE.16) THEN
24909 IF(I.LE.8) THEN
24910C...Z'0 -> q + qbar
24911 EF=KCHG(I,1)/3D0
24912 AF=SIGN(1D0,EF+0.1D0)
24913 VF=AF-4D0*EF*XWV
24914 IF(I.LE.2) THEN
24915 VPF=PARU(123-2*MOD(I,2))
24916 APF=PARU(124-2*MOD(I,2))
24917 ELSEIF(I.LE.4) THEN
24918 VPF=PARJ(182-2*MOD(I,2))
24919 APF=PARJ(183-2*MOD(I,2))
24920 ELSE
24921 VPF=PARJ(190-2*MOD(I,2))
24922 APF=PARJ(191-2*MOD(I,2))
24923 ENDIF
24924 FCOF=3D0*RADC
24925 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
24926 & PYHFTH(SH,SH*RM1,1D0)
24927 IF(I.EQ.6) WID2=WIDS(6,1)
24928 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
24929 ELSEIF(I.LE.16) THEN
24930C...Z'0 -> l+ + l-, nu + nubar
24931 EF=KCHG(I+2,1)/3D0
24932 AF=SIGN(1D0,EF+0.1D0)
24933 VF=AF-4D0*EF*XWV
24934 IF(I.LE.10) THEN
24935 VPF=PARU(127-2*MOD(I,2))
24936 APF=PARU(128-2*MOD(I,2))
24937 ELSEIF(I.LE.12) THEN
24938 VPF=PARJ(186-2*MOD(I,2))
24939 APF=PARJ(187-2*MOD(I,2))
24940 ELSE
24941 VPF=PARJ(194-2*MOD(I,2))
24942 APF=PARJ(195-2*MOD(I,2))
24943 ENDIF
24944 FCOF=1D0
24945 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
24946 ENDIF
24947 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
24948 IF(ICASE.EQ.1) THEN
24949 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24950 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
24951 & APF**2*(1D0-4D0*RM1))*BE34
24952 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24953 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
24954 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
24955 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
24956 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
24957 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
24958 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
24959 ELSEIF(MINT(61).EQ.2) THEN
24960 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
24961 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
24962 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
24963 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
24964 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
24965 & BE34
24966 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
24967 & BE34
24968 ENDIF
24969 ELSEIF(I.EQ.17) THEN
24970C...Z'0 -> W+ + W-
24971 WDTPZP=PARU(129)**2*XW1**2*
24972 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
24973 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
24974 IF(ICASE.EQ.1) THEN
24975 WDTPZ=0D0
24976 WDTP(I)=FAC*WDTPZP
24977 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24978 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
24979 ELSEIF(MINT(61).EQ.2) THEN
24980 FGGF=0D0
24981 FGZF=0D0
24982 FGZPF=0D0
24983 FZZF=0D0
24984 FZZPF=0D0
24985 FZPZPF=WDTPZP
24986 ENDIF
24987 WID2=WIDS(24,1)
24988 ELSEIF(I.EQ.18) THEN
24989C...Z'0 -> H+ + H-
24990 CZC=2D0*(1D0-2D0*XW)
24991 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
24992 IF(ICASE.EQ.1) THEN
24993 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
24994 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
24995 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
24996 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
24997 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
24998 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
24999 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25000 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25001 ELSEIF(MINT(61).EQ.2) THEN
25002 FGGF=0.25D0*BE34C
25003 FGZF=0.25D0*PARU(142)*CZC*BE34C
25004 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25005 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25006 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25007 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25008 ENDIF
25009 WID2=WIDS(37,1)
25010 ELSEIF(I.EQ.19) THEN
25011C...Z'0 -> Z0 + gamma.
25012 ELSEIF(I.EQ.20) THEN
25013C...Z'0 -> Z0 + h0
25014 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25015 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25016 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25017 IF(ICASE.EQ.1) THEN
25018 WDTPZ=0D0
25019 WDTP(I)=FAC*WDTPZP
25020 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25021 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25022 ELSEIF(MINT(61).EQ.2) THEN
25023 FGGF=0D0
25024 FGZF=0D0
25025 FGZPF=0D0
25026 FZZF=0D0
25027 FZZPF=0D0
25028 FZPZPF=WDTPZP
25029 ENDIF
25030 WID2=WIDS(23,2)*WIDS(25,2)
25031 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25032C...Z' -> h0 + A0 or H0 + A0.
25033 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25034 IF(I.EQ.21) THEN
25035 CZAH=PARU(186)
25036 CZPAH=PARU(188)
25037 ELSE
25038 CZAH=PARU(187)
25039 CZPAH=PARU(189)
25040 ENDIF
25041 IF(ICASE.EQ.1) THEN
25042 WDTPZ=CZAH**2*BE34C
25043 WDTP(I)=FAC*CZPAH**2*BE34C
25044 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25045 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25046 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25047 & VINT(116))*BE34C
25048 ELSEIF(MINT(61).EQ.2) THEN
25049 FGGF=0D0
25050 FGZF=0D0
25051 FGZPF=0D0
25052 FZZF=CZAH**2*BE34C
25053 FZZPF=CZAH*CZPAH*BE34C
25054 FZPZPF=CZPAH**2*BE34C
25055 ENDIF
25056 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25057 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25058 ENDIF
25059 IF(ICASE.EQ.1) THEN
25060 VINT(117)=VINT(117)+FAC*WDTPZ
25061 WDTP(I)=FUDGE*WDTP(I)
25062 WDTP(0)=WDTP(0)+WDTP(I)
25063 ENDIF
25064 IF(MDME(IDC,1).GT.0) THEN
25065 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25066 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25067 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25068 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25069 & WDTE(I,MDME(IDC,1))
25070 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25071 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25072 ENDIF
25073 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25074 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25075 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25076 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25077 & FGZF*WID2
25078 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25079 & FGZPF*WID2
25080 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25081 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25082 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25083 & FZZPF*WID2
25084 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25085 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25086 ENDIF
25087 ENDIF
25088 290 CONTINUE
25089 IF(MINT(61).GE.1) ICASE=3-ICASE
25090 IF(ICASE.EQ.2) GOTO 280
25091
25092 ELSEIF(KFLA.EQ.34) THEN
25093C...W'+/-:
25094 FAC=(AEM/(24D0*XW))*SHR
25095 DO 300 I=1,MDCY(KC,3)
25096 IDC=I+MDCY(KC,2)-1
25097 IF(MDME(IDC,1).LT.0) GOTO 300
25098 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25099 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25100 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25101 WID2=1D0
25102 IF(I.LE.20) THEN
25103 IF(I.LE.16) THEN
25104C...W'+/- -> q + qbar'
25105 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25106 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25107 IF(KFLR.GT.0) THEN
25108 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25109 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25110 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25111 ELSE
25112 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25113 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25114 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25115 ENDIF
25116 ELSEIF(I.LE.20) THEN
25117C...W'+/- -> l+/- + nu
25118 FCOF=PARU(133)**2+PARU(134)**2
25119 IF(KFLR.GT.0) THEN
25120 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25121 ELSE
25122 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25123 ENDIF
25124 ENDIF
25125 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25126 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25127 ELSEIF(I.EQ.21) THEN
25128C...W'+/- -> W+/- + Z0
25129 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25130 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25131 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25132 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25133 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25134 ELSEIF(I.EQ.23) THEN
25135C...W'+/- -> W+/- + h0
25136 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25137 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25138 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25139 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25140 ENDIF
25141 WDTP(I)=FUDGE*WDTP(I)
25142 WDTP(0)=WDTP(0)+WDTP(I)
25143 IF(MDME(IDC,1).GT.0) THEN
25144 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25145 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25146 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25147 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25148 ENDIF
25149 300 CONTINUE
25150
25151 ELSEIF(KFLA.EQ.37) THEN
25152C...H+/-:
25153C IF(MSTP(49).EQ.0) THEN
25154 SHFS=SH
25155C ELSE
25156C SHFS=PMAS(37,1)**2
25157C ENDIF
25158 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25159 DO 310 I=1,MDCY(KC,3)
25160 IDC=I+MDCY(KC,2)-1
25161 IF(MDME(IDC,1).LT.0) GOTO 310
25162 KFC1=PYCOMP(KFDP(IDC,1))
25163 KFC2=PYCOMP(KFDP(IDC,2))
25164 RM1=PMAS(KFC1,1)**2/SH
25165 RM2=PMAS(KFC2,1)**2/SH
25166 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25167 WID2=1D0
25168 IF(I.LE.4) THEN
25169C...H+/- -> q + qbar'
25170 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25171 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25172 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25173 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25174 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25175 IF(KFLR.GT.0) THEN
25176 IF(I.EQ.3) WID2=WIDS(6,2)
25177 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25178 ELSE
25179 IF(I.EQ.3) WID2=WIDS(6,3)
25180 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25181 ENDIF
25182 ELSEIF(I.LE.8) THEN
25183C...H+/- -> l+/- + nu
25184 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25185 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25186 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25187 IF(KFLR.GT.0) THEN
25188 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25189 ELSE
25190 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25191 ENDIF
25192 ELSEIF(I.EQ.9) THEN
25193C...H+/- -> W+/- + h0.
25194 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25195 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25196 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25197 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25198
25199CMRENNA++
25200 ELSE
25201C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25202 RM10=RM1*SH/PMR**2
25203 RM20=RM2*SH/PMR**2
25204 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25205 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25206 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25207 WFAC=0D0
25208 ELSE
25209 WFAC=WFAC/WFAC0
25210 ENDIF
25211 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25212CMRENNA--
25213 KSGN1=2
25214 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25215 KSGN2=2
25216 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25217 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25218 ENDIF
25219 WDTP(I)=FUDGE*WDTP(I)
25220 WDTP(0)=WDTP(0)+WDTP(I)
25221 IF(MDME(IDC,1).GT.0) THEN
25222 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25223 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25224 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25225 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25226 ENDIF
25227 310 CONTINUE
25228
25229 ELSEIF(KFLA.EQ.41) THEN
25230C...R:
25231 FAC=(AEM/(12D0*XW))*SHR
25232 DO 320 I=1,MDCY(KC,3)
25233 IDC=I+MDCY(KC,2)-1
25234 IF(MDME(IDC,1).LT.0) GOTO 320
25235 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25236 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25237 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25238 WID2=1D0
25239 IF(I.LE.6) THEN
25240C...R -> q + qbar'
25241 FCOF=3D0*RADC
25242 ELSEIF(I.LE.9) THEN
25243C...R -> l+ + l'-
25244 FCOF=1D0
25245 ENDIF
25246 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25247 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25248 IF(KFLR.GT.0) THEN
25249 IF(I.EQ.4) WID2=WIDS(6,3)
25250 IF(I.EQ.5) WID2=WIDS(7,3)
25251 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
25252 IF(I.EQ.9) WID2=WIDS(17,3)
25253 ELSE
25254 IF(I.EQ.4) WID2=WIDS(6,2)
25255 IF(I.EQ.5) WID2=WIDS(7,2)
25256 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
25257 IF(I.EQ.9) WID2=WIDS(17,2)
25258 ENDIF
25259 WDTP(I)=FUDGE*WDTP(I)
25260 WDTP(0)=WDTP(0)+WDTP(I)
25261 IF(MDME(IDC,1).GT.0) THEN
25262 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25263 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25264 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25265 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25266 ENDIF
25267 320 CONTINUE
25268
25269 ELSEIF(KFLA.EQ.42) THEN
25270C...LQ (leptoquark).
25271 FAC=(AEM/4D0)*PARU(151)*SHR
25272 DO 330 I=1,MDCY(KC,3)
25273 IDC=I+MDCY(KC,2)-1
25274 IF(MDME(IDC,1).LT.0) GOTO 330
25275 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25276 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25277 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
25278 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25279 WID2=1D0
25280 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
25281 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
25282 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
25283 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
25284 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
25285 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
25286 WDTP(I)=FUDGE*WDTP(I)
25287 WDTP(0)=WDTP(0)+WDTP(I)
25288 IF(MDME(IDC,1).GT.0) THEN
25289 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25290 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25291 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25292 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25293 ENDIF
25294 330 CONTINUE
25295
25296 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
25297C...Techni-pi0 and techni-pi0':
25298 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25299 DO 340 I=1,MDCY(KC,3)
25300 IDC=I+MDCY(KC,2)-1
25301 IF(MDME(IDC,1).LT.0) GOTO 340
25302 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25303 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25304 RM1=PM1**2/SH
25305 RM2=PM2**2/SH
25306 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
25307 WID2=1D0
25308C...pi_tc -> g + g
25309 IF(I.EQ.8) THEN
25310 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
25311 & /(8D0*PARU(1))*SH*SHR
25312 IF(KFLA.EQ.KTECHN+111) THEN
25313 FACP=FACP*RTCM(9)
25314 ELSE
25315 FACP=FACP*RTCM(10)
25316 ENDIF
25317 WDTP(I)=FACP
25318 ELSE
25319C...pi_tc -> f + fbar.
25320 FCOF=1D0
25321 IKA=IABS(KFDP(IDC,1))
25322 IF(IKA.LT.10) FCOF=3D0*RADC
25323 HM1=PM1
25324 HM2=PM2
25325 IF(IKA.GE.4.AND.IKA.LE.6) THEN
25326 FCOF=FCOF*RTCM(1+IKA)**2
25327 HM1=PYMRUN(KFDP(IDC,1),SH)
25328 HM2=PYMRUN(KFDP(IDC,2),SH)
25329 ELSEIF(IKA.EQ.15) THEN
25330 FCOF=FCOF*RTCM(8)**2
25331 ENDIF
25332 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25333 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25334 ENDIF
25335 WDTP(I)=FUDGE*WDTP(I)
25336 WDTP(0)=WDTP(0)+WDTP(I)
25337 IF(MDME(IDC,1).GT.0) THEN
25338 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25339 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25340 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25341 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25342 ENDIF
25343 340 CONTINUE
25344
25345 ELSEIF(KFLA.EQ.KTECHN+211) THEN
25346C...pi+_tc
25347 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
25348 DO 350 I=1,MDCY(KC,3)
25349 IDC=I+MDCY(KC,2)-1
25350 IF(MDME(IDC,1).LT.0) GOTO 350
25351 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25352 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
25353 PM3=0D0
25354 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
25355 RM1=PM1**2/SH
25356 RM2=PM2**2/SH
25357 RM3=PM3**2/SH
25358 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
25359 WID2=1D0
25360C...pi_tc -> f + f'.
25361 FCOF=1D0
25362 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
25363C...pi_tc+ -> W b b~
25364 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
25365 FCOF=3D0*RADC
25366 XMT2=PMAS(6,1)**2/SH
25367 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
25368 KFC3=PYCOMP(KFDP(IDC,3))
25369 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
25370 CHECK = SQRT(RM1)
25371 T0 = (1D0-CHECK**2)*
25372 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
25373 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
25374 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
25375 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
25376 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
25377 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
25378 & +T3*LOG(CHECK))
25379 IF(KFLR.GT.0) THEN
25380 WID2=WIDS(24,2)
25381 ELSE
25382 WID2=WIDS(24,3)
25383 ENDIF
25384 ELSE
25385 FCOF=1D0
25386 IKA=IABS(KFDP(IDC,1))
25387 IF(IKA.LT.10) FCOF=3D0*RADC
25388 HM1=PM1
25389 HM2=PM2
25390 IF(I.GE.1.AND.I.LE.5) THEN
25391 IF(I.LE.2) THEN
25392 FCOF=FCOF*RTCM(5)**2
25393 ELSEIF(I.LE.4) THEN
25394 FCOF=FCOF*RTCM(6)**2
25395 ELSEIF(I.EQ.5) THEN
25396 FCOF=FCOF*RTCM(7)**2
25397 ENDIF
25398 HM1=PYMRUN(KFDP(IDC,1),SH)
25399 HM2=PYMRUN(KFDP(IDC,2),SH)
25400 ELSEIF(I.EQ.8) THEN
25401 FCOF=FCOF*RTCM(8)**2
25402 ENDIF
25403 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
25404 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25405 ENDIF
25406 WDTP(I)=FUDGE*WDTP(I)
25407 WDTP(0)=WDTP(0)+WDTP(I)
25408 IF(MDME(IDC,1).GT.0) THEN
25409 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25410 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25411 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25412 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25413 ENDIF
25414 350 CONTINUE
25415
25416 ELSEIF(KFLA.EQ.KTECHN+331) THEN
25417C...Techni-eta.
25418 FAC=(SH/PARP(46)**2)*SHR
25419 DO 360 I=1,MDCY(KC,3)
25420 IDC=I+MDCY(KC,2)-1
25421 IF(MDME(IDC,1).LT.0) GOTO 360
25422 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25423 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25424 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
25425 WID2=1D0
25426 IF(I.LE.2) THEN
25427 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
25428 IF(I.EQ.2) WID2=WIDS(6,1)
25429 ELSE
25430 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
25431 ENDIF
25432 WDTP(I)=FUDGE*WDTP(I)
25433 WDTP(0)=WDTP(0)+WDTP(I)
25434 IF(MDME(IDC,1).GT.0) THEN
25435 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25436 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25437 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25438 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25439 ENDIF
25440 360 CONTINUE
25441
25442 ELSEIF(KFLA.EQ.KTECHN+113) THEN
25443C...Techni-rho0:
25444 ALPRHT=2.16D0*(3D0/ITCM(1))
25445 FAC=(ALPRHT/12D0)*SHR
25446 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
25447 SQMZ=PMAS(23,1)**2
25448 SQMW=PMAS(24,1)**2
25449 SHP=SH
25450 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25451 GMMZ=SHR*WDTPP(0)
25452 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
25453 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25454 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25455 DO 370 I=1,MDCY(KC,3)
25456 IDC=I+MDCY(KC,2)-1
25457 IF(MDME(IDC,1).LT.0) GOTO 370
25458 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25459 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25460 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
25461 WID2=1D0
25462 IF(I.EQ.1) THEN
25463C...rho_tc0 -> W+ + W-.
25464C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25465 WDTP(I)=FAC*RTCM(3)**4*
25466 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25467 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25468 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25469 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
25470 WID2=WIDS(24,1)
25471 ELSEIF(I.EQ.2) THEN
25472C...rho_tc0 -> W+ + pi_tc-.
25473C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
25474 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25475 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25476 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25477 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
25478 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25479 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25480 ELSEIF(I.EQ.3) THEN
25481C...rho_tc0 -> pi_tc+ + W-.
25482 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25483 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25484 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25485 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
25486 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25487 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
25488 ELSEIF(I.EQ.4) THEN
25489C...rho_tc0 -> pi_tc+ + pi_tc-.
25490 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25491 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25492 WID2=WIDS(PYCOMP(KTECHN+211),1)
25493 ELSEIF(I.EQ.5) THEN
25494C...rho_tc0 -> gamma + pi_tc0
25495 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25496 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25497 & SHR**3
25498 WID2=WIDS(PYCOMP(KTECHN+111),2)
25499 ELSEIF(I.EQ.6) THEN
25500C...rho_tc0 -> gamma + pi_tc0'
25501 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25502 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
25503 WID2=WIDS(PYCOMP(KTECHN+221),2)
25504 ELSEIF(I.EQ.7) THEN
25505C...rho_tc0 -> Z0 + pi_tc0
25506 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25507 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25508 & XW/XW1*SHR**3
25509 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25510 ELSEIF(I.EQ.8) THEN
25511C...rho_tc0 -> Z0 + pi_tc0'
25512 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25513 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25514 & XW/XW1*SHR**3
25515 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25516 ELSEIF(I.EQ.9) THEN
25517C...rho_tc0 -> gamma + Z0
25518 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25519 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25520 WID2=WIDS(23,2)
25521 ELSEIF(I.EQ.10) THEN
25522C...rho_tc0 -> Z0 + Z0
25523 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25524 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
25525 & SHR**3
25526 WID2=WIDS(23,1)
25527 ELSE
25528C...rho_tc0 -> f + fbar.
25529 WID2=1D0
25530 IF(I.LE.18) THEN
25531 IA=I-10
25532 FCOF=3D0*RADC
25533 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25534 ELSE
25535 IA=I-6
25536 FCOF=1D0
25537 IF(IA.GE.17) WID2=WIDS(IA,1)
25538 ENDIF
25539 EI=KCHG(IA,1)/3D0
25540 AI=SIGN(1D0,EI+0.1D0)
25541 VI=AI-4D0*EI*XWV
25542 VALI=0.5D0*(VI+AI)
25543 VARI=0.5D0*(VI-AI)
25544 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25545 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25546 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25547 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25548 ENDIF
25549 WDTP(I)=FUDGE*WDTP(I)
25550 WDTP(0)=WDTP(0)+WDTP(I)
25551 IF(MDME(IDC,1).GT.0) THEN
25552 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25553 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25554 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25555 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25556 ENDIF
25557 370 CONTINUE
25558
25559 ELSEIF(KFLA.EQ.KTECHN+213) THEN
25560C...Techni-rho+/-:
25561 ALPRHT=2.16D0*(3D0/ITCM(1))
25562 FAC=(ALPRHT/12D0)*SHR
25563 SQMZ=PMAS(23,1)**2
25564 SQMW=PMAS(24,1)**2
25565 SHP=SH
25566 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
25567 GMMW=SHR*WDTPP(0)
25568 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
25569 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
25570 DO 380 I=1,MDCY(KC,3)
25571 IDC=I+MDCY(KC,2)-1
25572 IF(MDME(IDC,1).LT.0) GOTO 380
25573 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25574 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25575 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
25576 WID2=1D0
25577 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25578c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25579c & /3D0*SHR**3
25580 IF(I.EQ.1) THEN
25581C...rho_tc+ -> W+ + Z0.
25582C......Goldstone
25583 WDTP(I)=FAC*RTCM(3)**4*
25584 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25585 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
25586 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
25587C......W_L Z_T
25588 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
25589 & /3D0*SHR**3
25590 VA2=0D0
25591 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
25592C......W_T Z_L
25593 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
25594 & /3D0*SHR**3
25595 IF(KFLR.GT.0) THEN
25596 WID2=WIDS(24,2)*WIDS(23,2)
25597 ELSE
25598 WID2=WIDS(24,3)*WIDS(23,2)
25599 ENDIF
25600 ELSEIF(I.EQ.2) THEN
25601C...rho_tc+ -> W+ + pi_tc0.
25602 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25603 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25604 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25605 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
25606 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
25607 IF(KFLR.GT.0) THEN
25608 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
25609 ELSE
25610 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
25611 ENDIF
25612 ELSEIF(I.EQ.3) THEN
25613C...rho_tc+ -> pi_tc+ + Z0.
25614 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
25615 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25616 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25617 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
25618 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
25619 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25620 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25621 & SHR**3*XW/XW1
25622 IF(KFLR.GT.0) THEN
25623 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
25624 ELSE
25625 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
25626 ENDIF
25627 ELSEIF(I.EQ.4) THEN
25628C...rho_tc+ -> pi_tc+ + pi_tc0.
25629 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
25630 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25631 IF(KFLR.GT.0) THEN
25632 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
25633 ELSE
25634 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
25635 ENDIF
25636 ELSEIF(I.EQ.5) THEN
25637C...rho_tc+ -> pi_tc+ + gamma
25638 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25639 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
25640 & SHR**3
25641 IF(KFLR.GT.0) THEN
25642 WID2=WIDS(PYCOMP(KTECHN+211),2)
25643 ELSE
25644 WID2=WIDS(PYCOMP(KTECHN+211),3)
25645 ENDIF
25646 ELSEIF(I.EQ.6) THEN
25647C...rho_tc+ -> W+ + pi_tc0'
25648 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25649 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
25650 IF(KFLR.GT.0) THEN
25651 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
25652 ELSE
25653 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
25654 ENDIF
25655 ELSEIF(I.EQ.7) THEN
25656C...rho_tc+ -> W+ + gamma
25657 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25658 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25659 IF(KFLR.GT.0) THEN
25660 WID2=WIDS(24,2)
25661 ELSE
25662 WID2=WIDS(24,3)
25663 ENDIF
25664 ELSE
25665C...rho_tc+ -> f + fbar'.
25666 IA=I-7
25667 WID2=1D0
25668 IF(IA.LE.16) THEN
25669 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
25670 IF(KFLR.GT.0) THEN
25671 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
25672 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
25673 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
25674 ELSE
25675 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
25676 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
25677 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
25678 ENDIF
25679 ELSE
25680 FCOF=1D0
25681 IF(KFLR.GT.0) THEN
25682 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25683 ELSE
25684 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25685 ENDIF
25686 ENDIF
25687 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25688 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25689 ENDIF
25690 WDTP(I)=FUDGE*WDTP(I)
25691 WDTP(0)=WDTP(0)+WDTP(I)
25692 IF(MDME(IDC,1).GT.0) THEN
25693 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25694 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25695 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25696 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25697 ENDIF
25698 380 CONTINUE
25699
25700 ELSEIF(KFLA.EQ.KTECHN+223) THEN
25701C...Techni-omega:
25702 ALPRHT=2.16D0*(3D0/ITCM(1))
25703 FAC=(ALPRHT/12D0)*SHR
25704 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
25705 SQMZ=PMAS(23,1)**2
25706 SHP=SH
25707 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
25708 GMMZ=SHR*WDTPP(0)
25709 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
25710 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
25711 DO 390 I=1,MDCY(KC,3)
25712 IDC=I+MDCY(KC,2)-1
25713 IF(MDME(IDC,1).LT.0) GOTO 390
25714 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25715 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25716 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
25717 WID2=1D0
25718 IF(I.EQ.1) THEN
25719C...omega_tc0 -> gamma + pi_tc0.
25720 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
25721 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
25722 WID2=WIDS(PYCOMP(KTECHN+111),2)
25723 ELSEIF(I.EQ.2) THEN
25724C...omega_tc0 -> Z0 + pi_tc0
25725 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25726 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
25727 & XW/XW1*SHR**3
25728 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
25729 ELSEIF(I.EQ.3) THEN
25730C...omega_tc0 -> gamma + pi_tc0'
25731 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25732 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25733 & SHR**3
25734 WID2=WIDS(PYCOMP(KTECHN+221),2)
25735 ELSEIF(I.EQ.4) THEN
25736C...omega_tc0 -> Z0 + pi_tc0'
25737 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25738 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
25739 & XW/XW1*SHR**3
25740 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
25741 ELSEIF(I.EQ.5) THEN
25742C...omega_tc0 -> W+ + pi_tc-
25743 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25744 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25745 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25746 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25747 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
25748 ELSEIF(I.EQ.6) THEN
25749C...omega_tc0 -> pi_tc+ + W-
25750 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25751 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
25752 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
25753 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25754 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
25755 ELSEIF(I.EQ.7) THEN
25756C...omega_tc0 -> W+ + W-.
25757C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
25758 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
25759 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
25760 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25761 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
25762 WID2=WIDS(24,1)
25763 ELSEIF(I.EQ.8) THEN
25764C...omega_tc0 -> pi_tc+ + pi_tc-.
25765 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
25766 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25767 WID2=WIDS(PYCOMP(KTECHN+211),1)
25768C...omega_tc0 -> gamma + Z0
25769 ELSEIF(I.EQ.9) THEN
25770 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25771 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
25772 WID2=WIDS(23,2)
25773C...omega_tc0 -> Z0 + Z0
25774 ELSEIF(I.EQ.10) THEN
25775 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25776 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
25777 & /24D0/RTCM(12)**2*SHR**3
25778 WID2=WIDS(23,1)
25779 ELSE
25780C...omega_tc0 -> f + fbar.
25781 WID2=1D0
25782 IF(I.LE.18) THEN
25783 IA=I-10
25784 FCOF=3D0*RADC
25785 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
25786 ELSE
25787 IA=I-8
25788 FCOF=1D0
25789 IF(IA.GE.17) WID2=WIDS(IA,1)
25790 ENDIF
25791 EI=KCHG(IA,1)/3D0
25792 AI=SIGN(1D0,EI+0.1D0)
25793 VI=AI-4D0*EI*XWV
25794 VALI=-0.5D0*(VI+AI)
25795 VARI=-0.5D0*(VI-AI)
25796 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
25797 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
25798 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
25799 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
25800 ENDIF
25801 WDTP(I)=FUDGE*WDTP(I)
25802 WDTP(0)=WDTP(0)+WDTP(I)
25803 IF(MDME(IDC,1).GT.0) THEN
25804 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25805 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25806 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25807 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25808 ENDIF
25809 390 CONTINUE
25810
25811C.....V8 -> quark anti-quark
25812 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
25813 FAC=AS/6D0*SHR
25814 TANT3=RTCM(21)
25815 IF(ITCM(2).EQ.0) THEN
25816 IMDL=1
25817 ELSEIF(ITCM(2).EQ.1) THEN
25818 IMDL=2
25819 ENDIF
25820 DO 400 I=1,MDCY(KC,3)
25821 IDC=I+MDCY(KC,2)-1
25822 IF(MDME(IDC,1).LT.0) GOTO 400
25823 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
25824 RM1=PM1**2/SH
25825 IF(RM1.GT.0.25D0) GOTO 400
25826 WID2=1D0
25827 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25828 FMIX=1D0/TANT3**2
25829 ELSE
25830 FMIX=TANT3**2
25831 ENDIF
25832 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
25833 IF(I.EQ.6) WID2=WIDS(6,1)
25834 WDTP(I)=FUDGE*WDTP(I)
25835 WDTP(0)=WDTP(0)+WDTP(I)
25836 IF(MDME(IDC,1).GT.0) THEN
25837 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25838 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25839 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25840 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25841 ENDIF
25842 400 CONTINUE
25843
25844 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
25845 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
25846 CLEBF=0D0
25847 DO 410 I=1,MDCY(KC,3)
25848 IDC=I+MDCY(KC,2)-1
25849 IF(MDME(IDC,1).LT.0) GOTO 410
25850 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25851 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25852 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
25853 WID2=1D0
25854C...pi_tc -> g + g
25855 IF(I.EQ.7) THEN
25856 IF(KFLA.EQ.KTECHN+100111) THEN
25857 CLEBG=4D0/3D0
25858 ELSE
25859 CLEBG=5D0/3D0
25860 ENDIF
25861 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
25862 & /(2D0*PARU(1))*SH*SHR*CLEBG
25863 WDTP(I)=FACP
25864 ELSE
25865C...pi_tc -> f + fbar.
25866 IF(I.EQ.6) WID2=WIDS(6,1)
25867 FCOF=1D0
25868 IKA=IABS(KFDP(IDC,1))
25869 IF(IKA.LT.10) FCOF=3D0*RADC
25870 HM1=PYMRUN(KFDP(IDC,1),SH)
25871 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
25872 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25873 ENDIF
25874 WDTP(I)=FUDGE*WDTP(I)
25875 WDTP(0)=WDTP(0)+WDTP(I)
25876 IF(MDME(IDC,1).GT.0) THEN
25877 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25878 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25879 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25880 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25881 ENDIF
25882 410 CONTINUE
25883
25884 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
25885 FAC=AS/6D0*SHR
25886 ALPRHT=2.16D0*(3D0/ITCM(1))
25887 TANT3=RTCM(21)
25888 SIN2T=2D0*TANT3/(TANT3**2+1D0)
25889 SINT3=TANT3/SQRT(TANT3**2+1D0)
25890 CSXPP=RTCM(22)
25891 RM82=RTCM(27)**2
25892 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
25893 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
25894 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
25895 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
25896 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
25897 & SINT3**2)*2D0
25898 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
25899 & SINT3**2)*2D0
25900 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
25901
25902 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
25903 GMV8=SHR*WDTPP(0)
25904 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
25905 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
25906 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
25907 IF(ITCM(2).EQ.0) THEN
25908 IMDL=1
25909 ELSE
25910 IMDL=2
25911 ENDIF
25912 DO 420 I=1,MDCY(KC,3)
25913 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
25914 & KFLA.EQ.KTECHN+300113)) GOTO 420
25915 IDC=I+MDCY(KC,2)-1
25916 IF(MDME(IDC,1).LT.0) GOTO 420
25917 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25918 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25919 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
25920 WID2=1D0
25921 IF(I.LE.6) THEN
25922 IF(I.EQ.6) WID2=WIDS(6,1)
25923 XIG=1D0
25924 IF(KFLA.EQ.KTECHN+200113) THEN
25925 XIG=0D0
25926 XIJ=X12
25927 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
25928 XIG=0D0
25929 XIJ=X21
25930 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
25931 XIJ=X11
25932 ELSE
25933 XIJ=X22
25934 ENDIF
25935 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
25936 FMIX=1D0/TANT3/SIN2T
25937 ELSE
25938 FMIX=-TANT3/SIN2T
25939 ENDIF
25940 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
25941 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
25942 ELSEIF(I.EQ.7) THEN
25943 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
25944 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
25945 PSH=SHR*(1D0-RM1)/2D0
25946 WDTP(I)=AS/9D0*PSH**3/RM82
25947 IF(I.EQ.8) THEN
25948 WDTP(I)=2D0*WDTP(I)*CSXPP**2
25949 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25950 ELSE
25951 WDTP(I)=5D0*WDTP(I)
25952 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
25953 ENDIF
25954 ENDIF
25955 WDTP(I)=FUDGE*WDTP(I)
25956 WDTP(0)=WDTP(0)+WDTP(I)
25957 IF(MDME(IDC,1).GT.0) THEN
25958 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25959 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25960 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25961 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25962 ENDIF
25963 420 CONTINUE
25964
25965 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
25966C...d* excited quark.
25967 FAC=(SH/RTCM(41)**2)*SHR
25968 DO 430 I=1,MDCY(KC,3)
25969 IDC=I+MDCY(KC,2)-1
25970 IF(MDME(IDC,1).LT.0) GOTO 430
25971 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25972 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25973 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
25974 WID2=1D0
25975 IF(I.EQ.1) THEN
25976C...d* -> g + d.
25977 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
25978 WID2=1D0
25979 ELSEIF(I.EQ.2) THEN
25980C...d* -> gamma + d.
25981 QF=-RTCM(43)/2D0+RTCM(44)/6D0
25982 WDTP(I)=FAC*AEM*QF**2/4D0
25983 WID2=1D0
25984 ELSEIF(I.EQ.3) THEN
25985C...d* -> Z0 + d.
25986 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
25987 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
25988 & (1D0-RM1)**2*(2D0+RM1)
25989 WID2=WIDS(23,2)
25990 ELSEIF(I.EQ.4) THEN
25991C...d* -> W- + u.
25992 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
25993 & (1D0-RM1)**2*(2D0+RM1)
25994 IF(KFLR.GT.0) WID2=WIDS(24,3)
25995 IF(KFLR.LT.0) WID2=WIDS(24,2)
25996 ENDIF
25997 WDTP(I)=FUDGE*WDTP(I)
25998 WDTP(0)=WDTP(0)+WDTP(I)
25999 IF(MDME(IDC,1).GT.0) THEN
26000 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26001 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26002 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26003 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26004 ENDIF
26005 430 CONTINUE
26006
26007 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26008C...u* excited quark.
26009 FAC=(SH/RTCM(41)**2)*SHR
26010 DO 440 I=1,MDCY(KC,3)
26011 IDC=I+MDCY(KC,2)-1
26012 IF(MDME(IDC,1).LT.0) GOTO 440
26013 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26014 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26015 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26016 WID2=1D0
26017 IF(I.EQ.1) THEN
26018C...u* -> g + u.
26019 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26020 WID2=1D0
26021 ELSEIF(I.EQ.2) THEN
26022C...u* -> gamma + u.
26023 QF=RTCM(43)/2D0+RTCM(44)/6D0
26024 WDTP(I)=FAC*AEM*QF**2/4D0
26025 WID2=1D0
26026 ELSEIF(I.EQ.3) THEN
26027C...u* -> Z0 + u.
26028 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26029 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26030 & (1D0-RM1)**2*(2D0+RM1)
26031 WID2=WIDS(23,2)
26032 ELSEIF(I.EQ.4) THEN
26033C...u* -> W+ + d.
26034 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26035 & (1D0-RM1)**2*(2D0+RM1)
26036 IF(KFLR.GT.0) WID2=WIDS(24,2)
26037 IF(KFLR.LT.0) WID2=WIDS(24,3)
26038 ENDIF
26039 WDTP(I)=FUDGE*WDTP(I)
26040 WDTP(0)=WDTP(0)+WDTP(I)
26041 IF(MDME(IDC,1).GT.0) THEN
26042 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26043 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26044 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26045 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26046 ENDIF
26047 440 CONTINUE
26048
26049 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26050C...e* excited lepton.
26051 FAC=(SH/RTCM(41)**2)*SHR
26052 DO 450 I=1,MDCY(KC,3)
26053 IDC=I+MDCY(KC,2)-1
26054 IF(MDME(IDC,1).LT.0) GOTO 450
26055 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26056 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26057 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26058 WID2=1D0
26059 IF(I.EQ.1) THEN
26060C...e* -> gamma + e.
26061 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26062 WDTP(I)=FAC*AEM*QF**2/4D0
26063 WID2=1D0
26064 ELSEIF(I.EQ.2) THEN
26065C...e* -> Z0 + e.
26066 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26067 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26068 & (1D0-RM1)**2*(2D0+RM1)
26069 WID2=WIDS(23,2)
26070 ELSEIF(I.EQ.3) THEN
26071C...e* -> W- + nu.
26072 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26073 & (1D0-RM1)**2*(2D0+RM1)
26074 IF(KFLR.GT.0) WID2=WIDS(24,3)
26075 IF(KFLR.LT.0) WID2=WIDS(24,2)
26076 ENDIF
26077 WDTP(I)=FUDGE*WDTP(I)
26078 WDTP(0)=WDTP(0)+WDTP(I)
26079 IF(MDME(IDC,1).GT.0) THEN
26080 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26081 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26082 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26083 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26084 ENDIF
26085 450 CONTINUE
26086
26087 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26088C...nu*_e excited neutrino.
26089 FAC=(SH/RTCM(41)**2)*SHR
26090 DO 460 I=1,MDCY(KC,3)
26091 IDC=I+MDCY(KC,2)-1
26092 IF(MDME(IDC,1).LT.0) GOTO 460
26093 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26094 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26095 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26096 WID2=1D0
26097 IF(I.EQ.1) THEN
26098C...nu*_e -> Z0 + nu*_e.
26099 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26100 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26101 & (1D0-RM1)**2*(2D0+RM1)
26102 WID2=WIDS(23,2)
26103 ELSEIF(I.EQ.2) THEN
26104C...nu*_e -> W+ + e.
26105 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26106 & (1D0-RM1)**2*(2D0+RM1)
26107 IF(KFLR.GT.0) WID2=WIDS(24,2)
26108 IF(KFLR.LT.0) WID2=WIDS(24,3)
26109 ENDIF
26110 WDTP(I)=FUDGE*WDTP(I)
26111 WDTP(0)=WDTP(0)+WDTP(I)
26112 IF(MDME(IDC,1).GT.0) THEN
26113 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26114 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26115 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26116 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26117 ENDIF
26118 460 CONTINUE
26119
26120 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26121C...G* (graviton resonance):
26122 FAC=(PARP(50)**2/PARU(1))*SHR
26123 DO 470 I=1,MDCY(KC,3)
26124 IDC=I+MDCY(KC,2)-1
26125 IF(MDME(IDC,1).LT.0) GOTO 470
26126 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26127 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26128 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26129 WID2=1D0
26130 IF(I.LE.8) THEN
26131C...G* -> q + qbar
26132 FCOF=3D0*RADC
26133 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26134 & PYHFTH(SH,SH*RM1,1D0)
26135 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26136 & (1D0+8D0*RM1/3D0)/320D0
26137 IF(I.EQ.6) WID2=WIDS(6,1)
26138 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
26139 ELSEIF(I.LE.16) THEN
26140C...G* -> l+ + l-, nu + nubar
26141 FCOF=1D0
26142 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26143 & (1D0+8D0*RM1/3D0)/320D0
26144 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
26145 ELSEIF(I.EQ.17) THEN
26146C...G* -> g + g.
26147 WDTP(I)=FAC/20D0
26148 ELSEIF(I.EQ.18) THEN
26149C...G* -> gamma + gamma.
26150 WDTP(I)=FAC/160D0
26151 ELSEIF(I.EQ.19) THEN
26152C...G* -> Z0 + Z0.
26153 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26154 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
26155 WID2=WIDS(23,1)
26156 ELSEIF(I.EQ.20) THEN
26157C...G* -> W+ + W-.
26158 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
26159 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
26160 WID2=WIDS(24,1)
26161 ENDIF
26162 WDTP(I)=FUDGE*WDTP(I)
26163 WDTP(0)=WDTP(0)+WDTP(I)
26164 IF(MDME(IDC,1).GT.0) THEN
26165 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26166 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26167 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26168 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26169 ENDIF
26170 470 CONTINUE
26171
26172 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
26173C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
26174 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
26175 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
26176 DO 480 I=1,MDCY(KC,3)
26177 IDC=I+MDCY(KC,2)-1
26178 IF(MDME(IDC,1).LT.0) GOTO 480
26179 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26180 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26181 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26182 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
26183 WID2=1D0
26184 IF(I.LE.9) THEN
26185C...nu_lR -> l- qbar q'
26186 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26187 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26188 ELSEIF(I.LE.18) THEN
26189C...nu_lR -> l+ q qbar'
26190 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
26191 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
26192 ELSE
26193C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
26194 FCOF=1D0
26195 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
26196 ENDIF
26197 X=(PM1+PM2+PM3)/SHR
26198 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
26199 Y=(SHR/PMWR)**2
26200 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
26201 WDTP(I)=FAC*FCOF*FX*FY
26202 WDTP(I)=FUDGE*WDTP(I)
26203 WDTP(0)=WDTP(0)+WDTP(I)
26204 IF(MDME(IDC,1).GT.0) THEN
26205 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26206 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26207 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26208 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26209 ENDIF
26210 480 CONTINUE
26211
26212 ELSEIF(KFLA.EQ.9900023) THEN
26213C...Z_R0:
26214 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
26215 DO 490 I=1,MDCY(KC,3)
26216 IDC=I+MDCY(KC,2)-1
26217 IF(MDME(IDC,1).LT.0) GOTO 490
26218 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26219 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26220 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
26221 WID2=1D0
26222 SYMMET=1D0
26223 IF(I.LE.6) THEN
26224C...Z_R0 -> q + qbar
26225 EF=KCHG(I,1)/3D0
26226 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
26227 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
26228 FCOF=3D0*RADC
26229 IF(I.EQ.6) WID2=WIDS(6,1)
26230 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
26231C...Z_R0 -> l+ + l-
26232 AF=-(1D0-2D0*XW)
26233 VF=-1D0+4D0*XW
26234 FCOF=1D0
26235 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
26236C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
26237 AF=-2D0*XW
26238 VF=0D0
26239 FCOF=1D0
26240 SYMMET=0.5D0
26241 ELSEIF(I.LE.15) THEN
26242C...Z0 -> nu_R + nu_R, assumed Majorana.
26243 AF=2D0*XW1
26244 VF=0D0
26245 FCOF=1D0
26246 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
26247 SYMMET=0.5D0
26248 ENDIF
26249 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
26250 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
26251 WDTP(I)=FUDGE*WDTP(I)
26252 WDTP(0)=WDTP(0)+WDTP(I)
26253 IF(MDME(IDC,1).GT.0) THEN
26254 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26255 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26256 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26257 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26258 ENDIF
26259 490 CONTINUE
26260
26261 ELSEIF(KFLA.EQ.9900024) THEN
26262C...W_R+/-:
26263 FAC=(AEM/(24D0*XW))*SHR
26264 DO 500 I=1,MDCY(KC,3)
26265 IDC=I+MDCY(KC,2)-1
26266 IF(MDME(IDC,1).LT.0) GOTO 500
26267 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26268 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26269 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
26270 WID2=1D0
26271 IF(I.LE.9) THEN
26272C...W_R+/- -> q + qbar'
26273 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
26274 IF(KFLR.GT.0) THEN
26275 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
26276 ELSE
26277 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
26278 ENDIF
26279 ELSEIF(I.LE.12) THEN
26280C...W_R+/- -> l+/- + nu_R
26281 FCOF=1D0
26282 ENDIF
26283 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26284 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26285 WDTP(I)=FUDGE*WDTP(I)
26286 WDTP(0)=WDTP(0)+WDTP(I)
26287 IF(MDME(IDC,1).GT.0) THEN
26288 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26289 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26290 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26291 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26292 ENDIF
26293 500 CONTINUE
26294
26295 ELSEIF(KFLA.EQ.9900041) THEN
26296C...H_L++/--:
26297 FAC=(1D0/(8D0*PARU(1)))*SHR
26298 DO 510 I=1,MDCY(KC,3)
26299 IDC=I+MDCY(KC,2)-1
26300 IF(MDME(IDC,1).LT.0) GOTO 510
26301 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26302 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26303 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
26304 WID2=1D0
26305 IF(I.LE.6) THEN
26306C...H_L++/-- -> l+/- + l'+/-
26307 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26308 & (IABS(KFDP(IDC,2))-9)/2)**2
26309 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26310 ELSEIF(I.EQ.7) THEN
26311C...H_L++/-- -> W_L+/- + W_L+/-
26312 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
26313 & (3D0*RM1+0.25D0/RM1-1D0)
26314 WID2=WIDS(24,4+(1-KFLS)/2)
26315 ENDIF
26316 WDTP(I)=FAC*FCOF*
26317 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26318 WDTP(I)=FUDGE*WDTP(I)
26319 WDTP(0)=WDTP(0)+WDTP(I)
26320 IF(MDME(IDC,1).GT.0) THEN
26321 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26322 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26323 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26324 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26325 ENDIF
26326 510 CONTINUE
26327
26328 ELSEIF(KFLA.EQ.9900042) THEN
26329C...H_R++/--:
26330 FAC=(1D0/(8D0*PARU(1)))*SHR
26331 DO 520 I=1,MDCY(KC,3)
26332 IDC=I+MDCY(KC,2)-1
26333 IF(MDME(IDC,1).LT.0) GOTO 520
26334 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26335 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26336 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
26337 WID2=1D0
26338 IF(I.LE.6) THEN
26339C...H_R++/-- -> l+/- + l'+/-
26340 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
26341 & (IABS(KFDP(IDC,2))-9)/2)**2
26342 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
26343 ELSEIF(I.EQ.7) THEN
26344C...H_R++/-- -> W_R+/- + W_R+/-
26345 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
26346 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
26347 ENDIF
26348 WDTP(I)=FAC*FCOF*
26349 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26350 WDTP(I)=FUDGE*WDTP(I)
26351 WDTP(0)=WDTP(0)+WDTP(I)
26352 IF(MDME(IDC,1).GT.0) THEN
26353 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26354 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26355 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26356 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26357 ENDIF
26358 520 CONTINUE
26359
26360 ELSEIF(KFLA.EQ.KTECHN+115) THEN
26361C...Techni-a2:
26362C...Need to update to alpha_rho
26363 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26364 FAC=(ALPRHT/12D0)*SHR
26365 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26366 SQMZ=PMAS(23,1)**2
26367 SQMW=PMAS(24,1)**2
26368 SHP=SH
26369 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26370 GMMZ=SHR*WDTPP(0)
26371 XWRHT=1D0/(4D0*XW*(1D0-XW))
26372 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26373 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26374 DO 530 I=1,MDCY(KC,3)
26375 IDC=I+MDCY(KC,2)-1
26376 IF(MDME(IDC,1).LT.0) GOTO 530
26377 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26378 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26379 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
26380 WID2=1D0
26381 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26382 IF(I.LE.4) THEN
26383 FACPV=PCM**2
26384 FACPA=PCM**2+1.5D0*RM1
26385 VA2=0D0
26386 AA2=0D0
26387C...a2_tc0 -> W+ + W-
26388 IF(I.EQ.1) THEN
26389 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
26390C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
26391 WID2=WIDS(24,1)
26392C...a2_tc0 -> W+ + pi_tc- + c.c.
26393 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
26394 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26395 IF(I.EQ.6) THEN
26396 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26397 ELSE
26398 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26399 ENDIF
26400 ELSEIF(I.EQ.4) THEN
26401C...a2_tc0 -> Z0 + pi_tc0'
26402 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
26403 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26404 ENDIF
26405 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
26406 ELSEIF(I.GE.5.AND.I.LE.10) THEN
26407 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26408 FACPA=PCM**2*(1D0+RM1+RM2)
26409 VA2=0D0
26410 AA2=0D0
26411 IF(I.EQ.5) THEN
26412C...a_T^0 -> gamma rho_T^0
26413 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26414 WID2=WIDS(PYCOMP(KTECHN+113),2)
26415 ELSEIF(I.EQ.6) THEN
26416C...a_T^0 -> gamma omega_T
26417 VA2=1D0/RTCM(50)**4
26418 WID2=WIDS(PYCOMP(KTECHN+223),2)
26419 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
26420C...a_T^0 -> W^+- rho_T^-+
26421 AA2=.25D0/XW/RTCM(51)**4
26422 IF(I.EQ.7) THEN
26423 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
26424 ELSE
26425 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
26426 ENDIF
26427 ELSEIF(I.EQ.9) THEN
26428C...a_T^0 -> Z^0 rho_T^0
26429 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26430 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
26431 ELSEIF(I.EQ.10) THEN
26432C...a_T^0 -> Z^0 omega_T
26433 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
26434 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
26435 ENDIF
26436 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26437 ELSE
26438C...a2_tc0 -> f + fbar.
26439 WID2=1D0
26440 IF(I.LE.18) THEN
26441 IA=I-10
26442 FCOF=3D0*RADC
26443 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26444 ELSE
26445 IA=I-8
26446 FCOF=1D0
26447 IF(IA.GE.17) WID2=WIDS(IA,1)
26448 ENDIF
26449 EI=KCHG(IA,1)/3D0
26450 AI=SIGN(1D0,EI+0.1D0)
26451 VI=AI-4D0*EI*XWV
26452 VALI=0.5D0*(VI+AI)
26453 VARI=0.5D0*(VI-AI)
26454 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26455 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
26456 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26457 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
26458 ENDIF
26459 WDTP(I)=FUDGE*WDTP(I)
26460 WDTP(0)=WDTP(0)+WDTP(I)
26461 IF(MDME(IDC,1).GT.0) THEN
26462 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26463 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26464 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26465 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26466 ENDIF
26467 530 CONTINUE
26468
26469 ELSEIF(KFLA.EQ.KTECHN+215) THEN
26470C...Techni-a2+/-:
26471 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
26472 FAC=(ALPRHT/12D0)*SHR
26473 SQMZ=PMAS(23,1)**2
26474 SQMW=PMAS(24,1)**2
26475 SHP=SH
26476 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26477 GMMW=SHR*WDTPP(0)
26478 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26479 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26480 DO 540 I=1,MDCY(KC,3)
26481 IDC=I+MDCY(KC,2)-1
26482 IF(MDME(IDC,1).LT.0) GOTO 540
26483 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26484 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26485 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
26486 WID2=1D0
26487 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26488 IF(KFLR.GT.0) THEN
26489 ICHANN=2
26490 ELSE
26491 ICHANN=3
26492 ENDIF
26493 IF(I.LE.7) THEN
26494 AA2=0
26495 VA2=0
26496C...a2_tc+ -> gamma + W+.
26497 IF(I.EQ.1) THEN
26498 AA2=RTCM(3)**2/RTCM(49)**2
26499 WID2=WIDS(24,ICHANN)
26500C...a2_tc+ -> gamma + pi_tc+.
26501 ELSEIF(I.EQ.2) THEN
26502 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
26503 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
26504C...a2_tc+ -> W+ + Z
26505 ELSEIF(I.EQ.3) THEN
26506 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
26507 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
26508 WID2=WIDS(24,ICHANN)*WIDS(23,2)
26509C...a2_tc+ -> W+ + pi_tc0.
26510 ELSEIF(I.EQ.4) THEN
26511 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
26512 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
26513C...a2_tc+ -> W+ + pi_tc'0.
26514 ELSEIF(I.EQ.5) THEN
26515 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
26516 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
26517C...a2_tc+ -> Z0 + pi_tc+.
26518 ELSEIF(I.EQ.6) THEN
26519 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
26520 & RTCM(49)**2
26521 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
26522 ENDIF
26523 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26524 & /3D0*SHR**3
26525 ELSEIF(I.LE.10) THEN
26526 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
26527 FACPA=PCM**2*(1D0+RM1+RM2)
26528 VA2=0D0
26529 AA2=0D0
26530C...a2_tc+ -> gamma + rho_tc+
26531 IF(I.EQ.7) THEN
26532 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
26533 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
26534C...a2_tc+ -> W+ + rho_T^0
26535 ELSEIF(I.EQ.8) THEN
26536 AA2=1D0/(4D0*XW)/RTCM(51)**4
26537 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
26538C...a2_tc+ -> W+ + omega_T
26539 ELSEIF(I.EQ.9) THEN
26540 VA2=.25D0/XW/RTCM(50)**4
26541 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
26542C...a2_tc+ -> Z^0 + rho_T^+
26543 ELSEIF(I.EQ.10) THEN
26544 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
26545 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
26546 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
26547 ENDIF
26548 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
26549 ELSE
26550C...a2_tc+ -> f + fbar'.
26551 IA=I-10
26552 WID2=1D0
26553 IF(IA.LE.16) THEN
26554 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26555 IF(KFLR.GT.0) THEN
26556 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26557 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26558 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26559 ELSE
26560 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26561 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26562 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26563 ENDIF
26564 ELSE
26565 FCOF=1D0
26566 IF(KFLR.GT.0) THEN
26567 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26568 ELSE
26569 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26570 ENDIF
26571 ENDIF
26572 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26573 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26574 ENDIF
26575 WDTP(I)=FUDGE*WDTP(I)
26576 WDTP(0)=WDTP(0)+WDTP(I)
26577 IF(MDME(IDC,1).GT.0) THEN
26578 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26579 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26580 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26581 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26582 ENDIF
26583 540 CONTINUE
26584
26585 ENDIF
26586 MINT(61)=0
26587 MINT(62)=0
26588 MINT(63)=0
26589 RETURN
26590 END
26591
26592C***********************************************************************
26593
26594C...PYOFSH
26595C...Calculates partial width and differential cross-section maxima
26596C...of channels/processes not allowed on mass-shell, and selects
26597C...masses in such channels/processes.
26598
26599 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
26600
26601C...Double precision and integer declarations.
26602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
26603 IMPLICIT INTEGER(I-N)
26604 INTEGER PYK,PYCHGE,PYCOMP
26605C...Commonblocks.
26606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
26607 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
26608 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
26609 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
26610 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
26611 COMMON/PYINT1/MINT(400),VINT(400)
26612 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
26613 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
26614 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
26615 &/PYINT2/,/PYINT5/
26616C...Local arrays.
26617 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
26618 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
26619 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
26620 &WDTE(0:400,0:5)
26621
26622C...Find if particles equal, maximum mass, matrix elements, etc.
26623 MINT(51)=0
26624 ISUB=MINT(1)
26625 KFD(1)=IABS(KFD1)
26626 KFD(2)=IABS(KFD2)
26627 MEQL=0
26628 IF(KFD(1).EQ.KFD(2)) MEQL=1
26629 MLM=0
26630 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
26631 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
26632 NOFF=44
26633 PMMX=PMMO
26634 ELSE
26635 NOFF=40
26636 PMMX=VINT(1)
26637 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
26638 ENDIF
26639 MMED=0
26640 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
26641 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
26642 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
26643 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
26644 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
26645 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
26646 LOOP=1
26647
26648C...Find where Breit-Wigners are required, else select discrete masses.
26649 100 DO 110 I=1,2
26650 KFCA=PYCOMP(KFD(I))
26651 IF(KFCA.GT.0) THEN
26652 PMD(I)=PMAS(KFCA,1)
26653 PGD(I)=PMAS(KFCA,2)
26654 ELSE
26655 PMD(I)=0D0
26656 PGD(I)=0D0
26657 ENDIF
26658 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
26659 MBW(I)=0
26660 PMG(I)=PMD(I)
26661 RMG(I)=(PMG(I)/PMMX)**2
26662 ELSE
26663 MBW(I)=1
26664 ENDIF
26665 110 CONTINUE
26666
26667C...Find allowed mass range and Breit-Wigner parameters.
26668 DO 120 I=1,2
26669 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
26670 PML(I)=PARP(42)
26671 PMU(I)=PMMX-PARP(42)
26672 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26673 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26674 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
26675 ILM=I
26676 IF(MLM.EQ.2) ILM=3-I
26677 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
26678 IF(MBW(3-I).EQ.0) THEN
26679 PMU(I)=PMMX-PMD(3-I)
26680 ELSE
26681 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
26682 ENDIF
26683 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
26684 & MIN(PMU(I),CKIN(NOFF+2*ILM))
26685 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26686 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26687 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26688 IF(MBW(I).EQ.1) THEN
26689 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26690 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26691 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26692 & PGD(I)))
26693 ENDIF
26694 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
26695 ILM=I
26696 IF(MLM.EQ.2) ILM=3-I
26697 PML(I)=MAX(CKIN(48+I),PARP(42))
26698 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
26699 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
26700 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
26701 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
26702 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
26703 IF(MBW(I).EQ.1) THEN
26704 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26705 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
26706 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
26707 & PGD(I)))
26708 ENDIF
26709 ENDIF
26710 120 CONTINUE
26711 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
26712 &THEN
26713 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
26714 MINT(51)=1
26715 RETURN
26716 ENDIF
26717
26718C...Calculation of partial width of resonance.
26719 IF(MOFSH.EQ.1) THEN
26720
26721C..If only one integration, pick that to be the inner.
26722 IF(MBW(1).EQ.0) THEN
26723 PM2=PMD(1)
26724 PMD(1)=PMD(2)
26725 PGD(1)=PGD(2)
26726 PML(1)=PML(2)
26727 PMU(1)=PMU(2)
26728 ELSEIF(MBW(2).EQ.0) THEN
26729 PM2=PMD(2)
26730 ENDIF
26731
26732C...Start outer loop of integration.
26733 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26734 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26735 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
26736 NPT2=1
26737 XPT2(1)=1D0
26738 INX2(1)=0
26739 FMAX2=0D0
26740 ENDIF
26741 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26742 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
26743 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
26744 ENDIF
26745 RM2=(PM2/PMMX)**2
26746
26747C...Start inner loop of integration.
26748 PML1=PML(1)
26749 PMU1=MIN(PMU(1),PMMX-PM2)
26750 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
26751 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26752 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
26753 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
26754 FUNC2=0D0
26755 GOTO 180
26756 ENDIF
26757 NPT1=1
26758 XPT1(1)=1D0
26759 INX1(1)=0
26760 FMAX1=0D0
26761 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
26762 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
26763 RM1=(PM1/PMMX)**2
26764
26765C...Evaluate function value - inner loop.
26766 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26767 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
26768 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
26769 & RM2**2+10D0*RM1*RM2)
26770 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
26771 FPT1(NPT1)=FUNC1
26772
26773C...Go to next position in inner loop.
26774 IF(NPT1.EQ.1) THEN
26775 NPT1=NPT1+1
26776 XPT1(NPT1)=0D0
26777 INX1(NPT1)=1
26778 GOTO 140
26779 ELSEIF(NPT1.LE.8) THEN
26780 NPT1=NPT1+1
26781 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
26782 ISH1=ISH1+1
26783 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26784 INX1(NPT1)=INX1(ISH1)
26785 INX1(ISH1)=NPT1
26786 GOTO 140
26787 ELSEIF(NPT1.LT.100) THEN
26788 ISN1=ISH1
26789 150 ISH1=ISH1+1
26790 IF(ISH1.GT.NPT1) ISH1=2
26791 IF(ISH1.EQ.ISN1) GOTO 160
26792 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
26793 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
26794 NPT1=NPT1+1
26795 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
26796 INX1(NPT1)=INX1(ISH1)
26797 INX1(ISH1)=NPT1
26798 GOTO 140
26799 ENDIF
26800
26801C...Calculate integral over inner loop.
26802 160 FSUM1=0D0
26803 DO 170 IPT1=2,NPT1
26804 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
26805 & (XPT1(INX1(IPT1))-XPT1(IPT1))
26806 170 CONTINUE
26807 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
26808 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
26809 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
26810 FPT2(NPT2)=FUNC2
26811
26812C...Go to next position in outer loop.
26813 IF(NPT2.EQ.1) THEN
26814 NPT2=NPT2+1
26815 XPT2(NPT2)=0D0
26816 INX2(NPT2)=1
26817 GOTO 130
26818 ELSEIF(NPT2.LE.8) THEN
26819 NPT2=NPT2+1
26820 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
26821 ISH2=ISH2+1
26822 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26823 INX2(NPT2)=INX2(ISH2)
26824 INX2(ISH2)=NPT2
26825 GOTO 130
26826 ELSEIF(NPT2.LT.100) THEN
26827 ISN2=ISH2
26828 190 ISH2=ISH2+1
26829 IF(ISH2.GT.NPT2) ISH2=2
26830 IF(ISH2.EQ.ISN2) GOTO 200
26831 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
26832 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
26833 NPT2=NPT2+1
26834 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
26835 INX2(NPT2)=INX2(ISH2)
26836 INX2(ISH2)=NPT2
26837 GOTO 130
26838 ENDIF
26839
26840C...Calculate integral over outer loop.
26841 200 FSUM2=0D0
26842 DO 210 IPT2=2,NPT2
26843 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
26844 & (XPT2(INX2(IPT2))-XPT2(IPT2))
26845 210 CONTINUE
26846 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
26847 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
26848 ELSE
26849 FSUM2=FUNC2
26850 ENDIF
26851
26852C...Save result; second integration for user-selected mass range.
26853 IF(LOOP.EQ.1) WIDW=FSUM2
26854 WID2=FSUM2
26855 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
26856 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
26857 LOOP=2
26858 GOTO 100
26859 ENDIF
26860 RET1=WIDW
26861 RET2=WID2/WIDW
26862
26863C...Select two decay product masses of a resonance.
26864 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
26865 220 DO 230 I=1,2
26866 IF(MBW(I).EQ.0) GOTO 230
26867 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
26868 & (ATU(I)-ATL(I)))
26869 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
26870 RMG(I)=(PMG(I)/PMMX)**2
26871 230 CONTINUE
26872 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26873 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
26874
26875C...Weight with matrix element (if none known, use beta factor).
26876 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
26877 IF(MMED.EQ.1) THEN
26878 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
26879 ELSEIF(MMED.EQ.2) THEN
26880 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
26881 & RMG(2)**2+10D0*RMG(1)*RMG(2))
26882 ELSEIF(MMED.EQ.3) THEN
26883 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
26884 ELSE
26885 WTBE=FLAM
26886 ENDIF
26887 IF(WTBE.LT.PYR(0)) GOTO 220
26888 RET1=PMG(1)
26889 RET2=PMG(2)
26890
26891C...Find suitable set of masses for initialization of 2 -> 2 processes.
26892 ELSEIF(MOFSH.EQ.3) THEN
26893 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
26894 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
26895 PMG(2)=PMD(2)
26896 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
26897 PMG(1)=PMD(1)
26898 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
26899 ELSE
26900 IDIV=-1
26901 240 IDIV=IDIV+1
26902 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
26903 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
26904 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
26905 ENDIF
26906 RET1=PMG(1)
26907 RET2=PMG(2)
26908
26909C...Evaluate importance of excluded tails of Breit-Wigners.
26910 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26911 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26912 IF(MEQL.LE.1) THEN
26913 VINT(80)=1D0
26914 DO 250 I=1,2
26915 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
26916 & PARU(1)
26917 250 CONTINUE
26918 ELSE
26919 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
26920 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
26921 ENDIF
26922 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
26923 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
26924 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
26925 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26926
26927C...Pick one particle to be the lighter (if improves efficiency).
26928 ELSEIF(MOFSH.EQ.4) THEN
26929 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
26930 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
26931 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
26932
26933C...Select two masses according to Breit-Wigner + flat in s + 1/s.
26934 DO 270 I=1,2
26935 IF(MBW(I).EQ.0) GOTO 270
26936 PMV=PMU(I)
26937 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26938 ATV=ATU(I)
26939 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26940 RBR=PYR(0)
26941 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26942 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
26943 IF(RBR.LT.0.8D0) THEN
26944 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
26945 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
26946 ELSEIF(RBR.LT.0.9D0) THEN
26947 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
26948 ELSEIF(RBR.LT.1.5D0) THEN
26949 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
26950 ELSE
26951 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
26952 & (PMV**2-PML(I)**2))))
26953 ENDIF
26954 270 CONTINUE
26955 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
26956 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
26957 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
26958 NGEN(0,1)=NGEN(0,1)+1
26959 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
26960 GOTO 260
26961 ELSE
26962 MINT(51)=1
26963 RETURN
26964 ENDIF
26965 ENDIF
26966 RET1=PMG(1)
26967 RET2=PMG(2)
26968
26969C...Give weight for selected mass distribution.
26970 VINT(80)=1D0
26971 DO 280 I=1,2
26972 IF(MBW(I).EQ.0) GOTO 280
26973 PMV=PMU(I)
26974 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
26975 ATV=ATU(I)
26976 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
26977 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
26978 & (PMD(I)*PGD(I))**2)/PARU(1)
26979 F1=1D0
26980 F2=1D0/PMG(I)**2
26981 F3=1D0/PMG(I)**4
26982 FI0=(ATV-ATL(I))/PARU(1)
26983 FI1=PMV**2-PML(I)**2
26984 FI2=2D0*LOG(PMV/PML(I))
26985 FI3=1D0/PML(I)**2-1D0/PMV**2
26986 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
26987 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
26988 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
26989 & 5D0*F3/FI3))
26990 ELSE
26991 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
26992 ENDIF
26993 VINT(80)=VINT(80)*FI0
26994 280 CONTINUE
26995 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
26996 ENDIF
26997
26998 RETURN
26999 END
27000
27001C***********************************************************************
27002
27003C...PYRECO
27004C...Handles the possibility of colour reconnection in W+W- events,
27005C...Based on the main scenarios of the Sjostrand and Khoze study:
27006C...I, II, II', intermediate and instantaneous; plus one model
27007C...along the lines of the Gustafson and Hakkinen: GH.
27008C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27009C...is as if first resonance is W+ and second W-.
27010
27011 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27012
27013C...Double precision and integer declarations.
27014 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27015 IMPLICIT INTEGER(I-N)
27016 INTEGER PYK,PYCHGE,PYCOMP
27017C...Parameter value; number of points in MC integration.
27018 PARAMETER (NPT=100)
27019C...Commonblocks.
27020 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27021 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27022 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27023 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27024 COMMON/PYINT1/MINT(400),VINT(400)
27025 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27026C...Local arrays.
27027 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27028 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27029 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27030 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27031 &TMC(20),IJOIN(100)
27032
27033C...Functions to give four-product and to do determinants.
27034 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)
27035 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27036 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27037 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27038
27039C...Only allow fraction of recoupling for GH, intermediate and
27040C...instantaneous.
27041 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27042 IF(PYR(0).GT.PARP(120)) RETURN
27043 ENDIF
27044 ISUB=MINT(1)
27045
27046C...Common part for scenarios I, II, II', and GH.
27047 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27048 &MSTP(115).EQ.5) THEN
27049
27050C...Read out frequently-used parameters.
27051 PI=PARU(1)
27052 HBAR=PARU(3)
27053 PMW=PMAS(24,1)
27054 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27055 PGW=PMAS(24,2)
27056 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27057 TFRAG=PARP(115)
27058 RHAD=PARP(116)
27059 FACT=PARP(117)
27060 BLOWR=PARP(118)
27061 BLOWT=PARP(119)
27062
27063C...Find range of decay products of the W's.
27064C...Background: the W's are stored in IW1 and IW2.
27065C...Their direct decay products in NSD1+1 through NSD1+4.
27066C...Products after shower (if any) in NSD1+5 through NAFT1
27067C...for first W and in NAFT1+1 through N for the second.
27068 IF(NAFT1.GT.NSD1+4) THEN
27069 NBEG(1)=NSD1+5
27070 NEND(1)=NAFT1
27071 ELSE
27072 NBEG(1)=NSD1+1
27073 NEND(1)=NSD1+2
27074 ENDIF
27075 IF(N.GT.NAFT1) THEN
27076 NBEG(2)=NAFT1+1
27077 NEND(2)=N
27078 ELSE
27079 NBEG(2)=NSD1+3
27080 NEND(2)=NSD1+4
27081 ENDIF
27082
27083C...Rearrange parton shower products along strings.
27084 NOLD=N
27085 CALL PYPREP(NSD1+1)
27086 IF(MINT(51).NE.0) RETURN
27087
27088C...Find partons pointing back to W+ and W-; store them with quark
27089C...end of string first.
27090 NNP=0
27091 NNM=0
27092 ISGP=0
27093 ISGM=0
27094 DO 120 I=NOLD+1,N
27095 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27096 IF(IABS(K(I,2)).GE.22) GOTO 120
27097 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27098 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27099 NNP=NNP+1
27100 IF(ISGP.EQ.1) THEN
27101 INP(NNP)=I
27102 ELSE
27103 DO 100 I1=NNP,2,-1
27104 INP(I1)=INP(I1-1)
27105 100 CONTINUE
27106 INP(1)=I
27107 ENDIF
27108 IF(K(I,1).EQ.1) ISGP=0
27109 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27110 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27111 NNM=NNM+1
27112 IF(ISGM.EQ.1) THEN
27113 INM(NNM)=I
27114 ELSE
27115 DO 110 I1=NNM,2,-1
27116 INM(I1)=INM(I1-1)
27117 110 CONTINUE
27118 INM(1)=I
27119 ENDIF
27120 IF(K(I,1).EQ.1) ISGM=0
27121 ENDIF
27122 120 CONTINUE
27123
27124C...Boost to W+W- rest frame (not strictly needed).
27125 DO 130 J=1,3
27126 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27127 130 CONTINUE
27128 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27129 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27130 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27131
27132C...Select decay vertices of W+ and W-.
27133 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27134 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27135 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27136 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27137 GTMAX=MAX(TP,TM)
27138 DO 140 J=1,3
27139 XP(J)=TP*P(IW1,J)/P(IW1,4)
27140 XM(J)=TM*P(IW2,J)/P(IW2,4)
27141 140 CONTINUE
27142
27143C...Begin scenario I specifics.
27144 IF(MSTP(115).EQ.1) THEN
27145
27146C...Reconstruct velocity and direction of W+ string pieces.
27147 DO 170 IIP=1,NNP-1
27148 IF(K(INP(IIP),2).LT.0) GOTO 170
27149 I1=INP(IIP)
27150 I2=INP(IIP+1)
27151 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27152 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27153 DO 150 J=1,3
27154 V1(J)=P(I1,J)/P1A
27155 V2(J)=P(I2,J)/P2A
27156 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
27157 DIRP(IIP,J)=V1(J)-V2(J)
27158 150 CONTINUE
27159 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
27160 & BETP(IIP,3)**2)
27161 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
27162 DO 160 J=1,3
27163 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
27164 160 CONTINUE
27165 170 CONTINUE
27166
27167C...Reconstruct velocity and direction of W- string pieces.
27168 DO 200 IIM=1,NNM-1
27169 IF(K(INM(IIM),2).LT.0) GOTO 200
27170 I1=INM(IIM)
27171 I2=INM(IIM+1)
27172 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
27173 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
27174 DO 180 J=1,3
27175 V1(J)=P(I1,J)/P1A
27176 V2(J)=P(I2,J)/P2A
27177 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
27178 DIRM(IIM,J)=V1(J)-V2(J)
27179 180 CONTINUE
27180 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
27181 & BETM(IIM,3)**2)
27182 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
27183 DO 190 J=1,3
27184 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
27185 190 CONTINUE
27186 200 CONTINUE
27187
27188C...Loop over number of space-time points.
27189 NACC=0
27190 SUM=0D0
27191 DO 250 IPT=1,NPT
27192
27193C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
27194 R=SQRT(-LOG(PYR(0)))
27195 PHI=2D0*PI*PYR(0)
27196 X=BLOWR*RHAD*R*COS(PHI)
27197 Y=BLOWR*RHAD*R*SIN(PHI)
27198 R=SQRT(-LOG(PYR(0)))
27199 PHI=2D0*PI*PYR(0)
27200 Z=BLOWR*RHAD*R*COS(PHI)
27201 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
27202
27203C...Reject impossible points. Weight for sample distribution.
27204 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
27205 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
27206 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
27207
27208C...Loop over W+ string pieces and find one with largest weight.
27209 IMAXP=0
27210 WTMAXP=1D-10
27211 XD(1)=X-XP(1)
27212 XD(2)=Y-XP(2)
27213 XD(3)=Z-XP(3)
27214 XD(4)=T-TP
27215 DO 220 IIP=1,NNP-1
27216 IF(K(INP(IIP),2).LT.0) GOTO 220
27217 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
27218 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
27219 DO 210 J=1,3
27220 XB(J)=XD(J)+BEDG*BETP(IIP,J)
27221 210 CONTINUE
27222 XB(4)=BETP(IIP,4)*(XD(4)-BED)
27223 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27224 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
27225 & DIRP(IIP,3)*XB(3))**2
27226 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27227 & TFRAG**2)
27228 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
27229 IF(WTP.GT.WTMAXP) THEN
27230 IMAXP=IIP
27231 WTMAXP=WTP
27232 ENDIF
27233 220 CONTINUE
27234
27235C...Loop over W- string pieces and find one with largest weight.
27236 IMAXM=0
27237 WTMAXM=1D-10
27238 XD(1)=X-XM(1)
27239 XD(2)=Y-XM(2)
27240 XD(3)=Z-XM(3)
27241 XD(4)=T-TM
27242 DO 240 IIM=1,NNM-1
27243 IF(K(INM(IIM),2).LT.0) GOTO 240
27244 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
27245 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
27246 DO 230 J=1,3
27247 XB(J)=XD(J)+BEDG*BETM(IIM,J)
27248 230 CONTINUE
27249 XB(4)=BETM(IIM,4)*(XD(4)-BED)
27250 SR2=XB(1)**2+XB(2)**2+XB(3)**2
27251 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
27252 & DIRM(IIM,3)*XB(3))**2
27253 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
27254 & TFRAG**2)
27255 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
27256 IF(WTM.GT.WTMAXM) THEN
27257 IMAXM=IIM
27258 WTMAXM=WTM
27259 ENDIF
27260 240 CONTINUE
27261
27262C...Result of integration.
27263 WT=0D0
27264 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
27265 WT=WTMAXP*WTMAXM/WTSMP
27266 SUM=SUM+WT
27267 NACC=NACC+1
27268 IAP(NACC)=IMAXP
27269 IAM(NACC)=IMAXM
27270 WTA(NACC)=WT
27271 ENDIF
27272 250 CONTINUE
27273 RES=BLOWR**3*BLOWT*SUM/NPT
27274
27275C...Decide whether to reconnect and, if so, where.
27276 IACC=0
27277 PREC=1D0-EXP(-FACT*RES)
27278 IF(PREC.GT.PYR(0)) THEN
27279 RSUM=PYR(0)*SUM
27280 DO 260 IA=1,NACC
27281 IACC=IA
27282 RSUM=RSUM-WTA(IA)
27283 IF(RSUM.LE.0D0) GOTO 270
27284 260 CONTINUE
27285 270 IIP=IAP(IACC)
27286 IIM=IAM(IACC)
27287 ENDIF
27288
27289C...Begin scenario II and II' specifics.
27290 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
27291
27292C...Loop through all string pieces, one from W+ and one from W-.
27293 NCROSS=0
27294 TC(0)=0D0
27295 DO 340 IIP=1,NNP-1
27296 IF(K(INP(IIP),2).LT.0) GOTO 340
27297 I1P=INP(IIP)
27298 I2P=INP(IIP+1)
27299 DO 330 IIM=1,NNM-1
27300 IF(K(INM(IIM),2).LT.0) GOTO 330
27301 I1M=INM(IIM)
27302 I2M=INM(IIM+1)
27303
27304C...Find endpoint velocity vectors.
27305 DO 280 J=1,3
27306 V1P(J)=P(I1P,J)/P(I1P,4)
27307 V2P(J)=P(I2P,J)/P(I2P,4)
27308 V1M(J)=P(I1M,J)/P(I1M,4)
27309 V2M(J)=P(I2M,J)/P(I2M,4)
27310 280 CONTINUE
27311
27312C...Define q matrix and find t.
27313 DO 290 J=1,3
27314 Q(1,J)=V2P(J)-V1P(J)
27315 Q(2,J)=-(V2M(J)-V1M(J))
27316 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
27317 Q(4,J)=V1P(J)-V1M(J)
27318 290 CONTINUE
27319 T=-DETER(1,2,3)/DETER(1,2,4)
27320
27321C...Find alpha and beta; i.e. coordinates of crossing point.
27322 S11=Q(1,1)*(T-TP)
27323 S12=Q(2,1)*(T-TM)
27324 S13=Q(3,1)+Q(4,1)*T
27325 S21=Q(1,2)*(T-TP)
27326 S22=Q(2,2)*(T-TM)
27327 S23=Q(3,2)+Q(4,2)*T
27328 DEN=S11*S22-S12*S21
27329 ALP=(S12*S23-S22*S13)/DEN
27330 BET=(S21*S13-S11*S23)/DEN
27331
27332C...Check if solution acceptable.
27333 IANSW=1
27334 IF(T.LT.GTMAX) IANSW=0
27335 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
27336 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
27337
27338C...Find point of crossing and check that not inconsistent.
27339 DO 300 J=1,3
27340 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
27341 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
27342 300 CONTINUE
27343 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
27344 & (XPP(3)-XMM(3))**2
27345 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
27346 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
27347 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
27348
27349C...Find string eigentimes at crossing.
27350 IF(IANSW.EQ.1) THEN
27351 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
27352 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
27353 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
27354 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
27355 ELSE
27356 TAUP=0D0
27357 TAUM=0D0
27358 ENDIF
27359
27360C...Order crossings by time. End loop over crossings.
27361 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
27362 NCROSS=NCROSS+1
27363 DO 310 I1=NCROSS,1,-1
27364 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
27365 IPC(I1)=IIP
27366 IMC(I1)=IIM
27367 TC(I1)=T
27368 TPC(I1)=TAUP
27369 TMC(I1)=TAUM
27370 GOTO 320
27371 ELSE
27372 IPC(I1)=IPC(I1-1)
27373 IMC(I1)=IMC(I1-1)
27374 TC(I1)=TC(I1-1)
27375 TPC(I1)=TPC(I1-1)
27376 TMC(I1)=TMC(I1-1)
27377 ENDIF
27378 310 CONTINUE
27379 320 CONTINUE
27380 ENDIF
27381 330 CONTINUE
27382 340 CONTINUE
27383
27384C...Loop over crossings; find first (if any) acceptable one.
27385 IACC=0
27386 IF(NCROSS.GE.1) THEN
27387 DO 350 IC=1,NCROSS
27388 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
27389 IF(PNFRAG.GT.PYR(0)) THEN
27390C...Scenario II: only compare with fragmentation time.
27391 IF(MSTP(115).EQ.2) THEN
27392 IACC=IC
27393 IIP=IPC(IACC)
27394 IIM=IMC(IACC)
27395 GOTO 360
27396C...Scenario II': also require that string length decreases.
27397 ELSE
27398 IIP=IPC(IC)
27399 IIM=IMC(IC)
27400 I1P=INP(IIP)
27401 I2P=INP(IIP+1)
27402 I1M=INM(IIM)
27403 I2M=INM(IIM+1)
27404 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27405 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27406 IF(ELNEW.LT.ELOLD) THEN
27407 IACC=IC
27408 IIP=IPC(IACC)
27409 IIM=IMC(IACC)
27410 GOTO 360
27411 ENDIF
27412 ENDIF
27413 ENDIF
27414 350 CONTINUE
27415 360 CONTINUE
27416 ENDIF
27417
27418C...Begin scenario GH specifics.
27419 ELSEIF(MSTP(115).EQ.5) THEN
27420
27421C...Loop through all string pieces, one from W+ and one from W-.
27422 IACC=0
27423 ELMIN=1D0
27424 DO 380 IIP=1,NNP-1
27425 IF(K(INP(IIP),2).LT.0) GOTO 380
27426 I1P=INP(IIP)
27427 I2P=INP(IIP+1)
27428 DO 370 IIM=1,NNM-1
27429 IF(K(INM(IIM),2).LT.0) GOTO 370
27430 I1M=INM(IIM)
27431 I2M=INM(IIM+1)
27432
27433C...Look for largest decrease of (exponent of) Lambda measure.
27434 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
27435 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
27436 ELDIF=ELNEW/MAX(1D-10,ELOLD)
27437 IF(ELDIF.LT.ELMIN) THEN
27438 IACC=IIP+IIM
27439 ELMIN=ELDIF
27440 IPC(1)=IIP
27441 IMC(1)=IIM
27442 ENDIF
27443 370 CONTINUE
27444 380 CONTINUE
27445 IIP=IPC(1)
27446 IIM=IMC(1)
27447 ENDIF
27448
27449C...Common for scenarios I, II, II' and GH: reconnect strings.
27450 IF(IACC.NE.0) THEN
27451 MINT(32)=1
27452 NJOIN=0
27453 DO 390 IS=1,NNP+NNM
27454 NJOIN=NJOIN+1
27455 IF(IS.LE.IIP) THEN
27456 I=INP(IS)
27457 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
27458 I=INM(IS-IIP+IIM)
27459 ELSEIF(IS.LE.IIP+NNM) THEN
27460 I=INM(IS-IIP-NNM+IIM)
27461 ELSE
27462 I=INP(IS-NNM)
27463 ENDIF
27464 IJOIN(NJOIN)=I
27465 IF(K(I,2).LT.0) THEN
27466 CALL PYJOIN(NJOIN,IJOIN)
27467 NJOIN=0
27468 ENDIF
27469 390 CONTINUE
27470
27471C...Restore original event record if no reconnection.
27472 ELSE
27473 DO 400 I=NSD1+1,NOLD
27474 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
27475 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27476 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27477 ENDIF
27478 400 CONTINUE
27479 DO 410 I=NOLD+1,N
27480 K(K(I,3),1)=3
27481 410 CONTINUE
27482 N=NOLD
27483 ENDIF
27484
27485C...Boost back system.
27486 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27487 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
27488 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
27489 & BEWW(1),BEWW(2),BEWW(3))
27490
27491C...Common part for intermediate and instantaneous scenarios.
27492 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27493 MINT(32)=1
27494
27495C...Remove old shower products and reset showering ones.
27496 N=NSD1+4
27497 DO 420 I=NSD1+1,NSD1+4
27498 K(I,1)=3
27499 K(I,4)=MOD(K(I,4),MSTU(5)**2)
27500 K(I,5)=MOD(K(I,5),MSTU(5)**2)
27501 420 CONTINUE
27502
27503C...Identify quark-antiquark pairs.
27504 IQ1=NSD1+1
27505 IQ2=NSD1+2
27506 IQ3=NSD1+3
27507 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
27508 IQ4=2*NSD1+7-IQ3
27509
27510C...Reconnect strings.
27511 IJOIN(1)=IQ1
27512 IJOIN(2)=IQ4
27513 CALL PYJOIN(2,IJOIN)
27514 IJOIN(1)=IQ3
27515 IJOIN(2)=IQ2
27516 CALL PYJOIN(2,IJOIN)
27517
27518C...Do new parton showers in intermediate scenario.
27519 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
27520 MSTJ50=MSTJ(50)
27521 MSTJ(50)=0
27522 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
27523 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
27524 MSTJ(50)=MSTJ50
27525
27526C...Do new parton showers in instantaneous scenario.
27527 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
27528 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
27529 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
27530 PPM=SQRT(MAX(0D0,PPM2))
27531 CALL PYSHOW(IQ1,IQ4,PPM)
27532 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
27533 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
27534 PPM=SQRT(MAX(0D0,PPM2))
27535 CALL PYSHOW(IQ3,IQ2,PPM)
27536 ENDIF
27537 ENDIF
27538
27539 RETURN
27540 END
27541
27542C***********************************************************************
27543
27544C...PYKLIM
27545C...Checks generated variables against pre-set kinematical limits;
27546C...also calculates limits on variables used in generation.
27547
27548 SUBROUTINE PYKLIM(ILIM)
27549
27550C...Double precision and integer declarations.
27551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27552 IMPLICIT INTEGER(I-N)
27553 INTEGER PYK,PYCHGE,PYCOMP
27554C...Commonblocks.
27555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27558 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27559 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27561 COMMON/PYINT1/MINT(400),VINT(400)
27562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27563 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
27564 &/PYINT1/,/PYINT2/
27565
27566C...Common kinematical expressions.
27567 MINT(51)=0
27568 ISUB=MINT(1)
27569 ISTSB=ISET(ISUB)
27570 IF(ISUB.EQ.96) GOTO 100
27571 SQM3=VINT(63)
27572 SQM4=VINT(64)
27573 IF(ILIM.NE.0) THEN
27574 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
27575 CKIN09=MAX(CKIN(9),CKIN(13))
27576 CKIN10=MIN(CKIN(10),CKIN(14))
27577 CKIN11=MAX(CKIN(11),CKIN(15))
27578 CKIN12=MIN(CKIN(12),CKIN(16))
27579 ELSE
27580 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
27581 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
27582 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
27583 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
27584 ENDIF
27585 ENDIF
27586 IF(ILIM.NE.1) THEN
27587 TAU=VINT(21)
27588 RM3=SQM3/(TAU*VINT(2))
27589 RM4=SQM4/(TAU*VINT(2))
27590 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
27591 ENDIF
27592 PTHMIN=CKIN(3)
27593 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
27594 &PTHMIN=MAX(CKIN(3),CKIN(5))
27595
27596 IF(ILIM.EQ.0) THEN
27597C...Check generated values of tau, y*, cos(theta-hat), and tau' against
27598C...pre-set kinematical limits.
27599 YST=VINT(22)
27600 CTH=VINT(23)
27601 TAUP=VINT(26)
27602 TAUE=TAU
27603 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
27604 X1=SQRT(TAUE)*EXP(YST)
27605 X2=SQRT(TAUE)*EXP(-YST)
27606 XF=X1-X2
27607 IF(MINT(47).NE.1) THEN
27608 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
27609 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
27610 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
27611 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
27612 ENDIF
27613 IF(MINT(45).NE.1) THEN
27614 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
27615 ENDIF
27616 IF(MINT(46).NE.1) THEN
27617 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
27618 ENDIF
27619 IF(MINT(45).EQ.2) THEN
27620 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27621 ENDIF
27622 IF(MINT(46).EQ.2) THEN
27623 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
27624 ENDIF
27625 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
27626 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
27627 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
27628 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
27629 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
27630 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
27631 Y3=YST+0.5D0*LOG(EXPY3)
27632 Y4=YST+0.5D0*LOG(EXPY4)
27633 YLARGE=MAX(Y3,Y4)
27634 YSMALL=MIN(Y3,Y4)
27635 ETALAR=20D0
27636 ETASMA=-20D0
27637 STH=SQRT(MAX(0D0,1D0-CTH**2))
27638 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
27639 & CTH)**2-4D0*RM3))
27640 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
27641 & CTH)**2-4D0*RM4))
27642 IF(STH.GE.1D-10) THEN
27643 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
27644 & (BE34*STH)
27645 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
27646 & (BE34*STH)
27647 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
27648 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
27649 ETALAR=MAX(ETA3,ETA4)
27650 ETASMA=MIN(ETA3,ETA4)
27651 ENDIF
27652 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
27653 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
27654 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
27655 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
27656 SH=TAU*VINT(2)
27657 RPTS=4D0*VINT(71)**2/SH
27658 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
27659 RM34=MAX(1D-20,2D0*RM3*RM4)
27660 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
27661 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
27662 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
27663 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
27664 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
27665 IF(PTH.LT.PTHMIN) MINT(51)=1
27666 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
27667 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
27668 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
27669 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
27670 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
27671 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
27672 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
27673 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
27674 IF(THA.LT.CKIN(35)) MINT(51)=1
27675 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
27676 IF(UHA.LT.CKIN(37)) MINT(51)=1
27677 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
27678 ENDIF
27679 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
27680 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
27681 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
27682 ENDIF
27683
27684C...Additional cuts on W2 (approximately) in DIS.
27685 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
27686 XBJ=X2
27687 IF(IABS(MINT(12)).LT.20) XBJ=X1
27688 Q2BJ=THA
27689 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
27690 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
27691 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
27692 ENDIF
27693
27694 ELSEIF(ILIM.EQ.1) THEN
27695C...Calculate limits on tau
27696C...0) due to definition
27697 TAUMN0=0D0
27698 TAUMX0=1D0
27699C...1) due to limits on subsystem mass
27700 TAUMN1=CKIN(1)**2/VINT(2)
27701 TAUMX1=1D0
27702 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
27703C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
27704 TM3=SQRT(SQM3+PTHMIN**2)
27705 TM4=SQRT(SQM4+PTHMIN**2)
27706 YDCOSH=1D0
27707 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
27708 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
27709 TAUMX2=1D0
27710C...3) due to limits on pT-hat and cos(theta-hat)
27711 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
27712 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
27713 TAUMN3=0D0
27714 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
27715 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
27716 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
27717 TAUMX3=1D0
27718 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
27719 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
27720 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
27721C...4) due to limits on x1 and x2
27722 TAUMN4=CKIN(21)*CKIN(23)
27723 TAUMX4=CKIN(22)*CKIN(24)
27724C...5) due to limits on xF
27725 TAUMN5=0D0
27726 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
27727C...6) due to limits on that and uhat
27728 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
27729 TAUMX6=1D0
27730 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
27731 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
27732
27733C...Net effect of all separate limits.
27734 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
27735 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
27736 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27737 VINT(11)=1D0-1D-9
27738 VINT(31)=1D0+1D-9
27739 ELSEIF(MINT(47).EQ.5) THEN
27740 VINT(31)=MIN(VINT(31),1D0-2D-10)
27741 ELSEIF(MINT(47).GE.6) THEN
27742 VINT(31)=MIN(VINT(31),1D0-1D-10)
27743 ENDIF
27744 IF(VINT(31).LE.VINT(11)) MINT(51)=1
27745
27746 ELSEIF(ILIM.EQ.2) THEN
27747C...Calculate limits on y*
27748 TAUE=TAU
27749 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
27750 TAURT=SQRT(TAUE)
27751C...0) due to kinematics
27752 YSTMN0=LOG(TAURT)
27753 YSTMX0=-YSTMN0
27754C...1) due to explicit limits
27755 YSTMN1=CKIN(7)
27756 YSTMX1=CKIN(8)
27757C...2) due to limits on x1
27758 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
27759 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
27760C...3) due to limits on x2
27761 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
27762 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
27763C...4) due to limits on xF
27764 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
27765 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
27766 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
27767 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
27768C...5) due to simultaneous limits on y-large and y-small
27769 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
27770 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
27771 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
27772 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
27773 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
27774 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
27775C...6) due to simultaneous limits on cos(theta-hat) and y-large or
27776C... y-small
27777 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
27778 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
27779 RZMX=BE34*MIN(CKIN(28),CTHLIM)
27780 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
27781 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
27782 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
27783 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
27784 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
27785 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
27786
27787C...Net effect of all separate limits.
27788 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
27789 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
27790 IF(MINT(47).EQ.1) THEN
27791 VINT(12)=-1D-9
27792 VINT(32)=1D-9
27793 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
27794 VINT(12)=(1D0-1D-9)*YSTMX0
27795 VINT(32)=(1D0+1D-9)*YSTMX0
27796 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
27797 VINT(12)=-(1D0+1D-9)*YSTMX0
27798 VINT(32)=-(1D0-1D-9)*YSTMX0
27799 ELSEIF(MINT(47).EQ.5) THEN
27800 YSTEE=LOG((1D0-1D-10)/TAURT)
27801 VINT(12)=MAX(VINT(12),-YSTEE)
27802 VINT(32)=MIN(VINT(32),YSTEE)
27803 ENDIF
27804 IF(VINT(32).LE.VINT(12)) MINT(51)=1
27805
27806 ELSEIF(ILIM.EQ.3) THEN
27807C...Calculate limits on cos(theta-hat)
27808 YST=VINT(22)
27809C...0) due to definition
27810 CTNMN0=-1D0
27811 CTNMX0=0D0
27812 CTPMN0=0D0
27813 CTPMX0=1D0
27814C...1) due to explicit limits
27815 CTNMN1=MIN(0D0,CKIN(27))
27816 CTNMX1=MIN(0D0,CKIN(28))
27817 CTPMN1=MAX(0D0,CKIN(27))
27818 CTPMX1=MAX(0D0,CKIN(28))
27819C...2) due to limits on pT-hat
27820 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
27821 CTPMX2=-CTNMN2
27822 CTNMX2=0D0
27823 CTPMN2=0D0
27824 IF(CKIN(4).GE.0D0) THEN
27825 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
27826 & (BE34**2*TAU*VINT(2))))
27827 CTPMN2=-CTNMX2
27828 ENDIF
27829C...3) due to limits on y-large and y-small
27830 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
27831 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
27832 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
27833 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
27834 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
27835 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
27836 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
27837 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
27838C...4) due to limits on that
27839 CTNMN4=-1D0
27840 CTNMX4=0D0
27841 CTPMN4=0D0
27842 CTPMX4=1D0
27843 SH=TAU*VINT(2)
27844 IF(CKIN(35).GT.0D0) THEN
27845 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
27846 IF(CTLIM.GT.0D0) THEN
27847 CTPMX4=CTLIM
27848 ELSE
27849 CTPMX4=0D0
27850 CTNMX4=CTLIM
27851 ENDIF
27852 ENDIF
27853 IF(CKIN(36).GT.0D0) THEN
27854 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
27855 IF(CTLIM.LT.0D0) THEN
27856 CTNMN4=CTLIM
27857 ELSE
27858 CTNMN4=0D0
27859 CTPMN4=CTLIM
27860 ENDIF
27861 ENDIF
27862C...5) due to limits on uhat
27863 CTNMN5=-1D0
27864 CTNMX5=0D0
27865 CTPMN5=0D0
27866 CTPMX5=1D0
27867 IF(CKIN(37).GT.0D0) THEN
27868 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
27869 IF(CTLIM.LT.0D0) THEN
27870 CTNMN5=CTLIM
27871 ELSE
27872 CTNMN5=0D0
27873 CTPMN5=CTLIM
27874 ENDIF
27875 ENDIF
27876 IF(CKIN(38).GT.0D0) THEN
27877 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
27878 IF(CTLIM.GT.0D0) THEN
27879 CTPMX5=CTLIM
27880 ELSE
27881 CTPMX5=0D0
27882 CTNMX5=CTLIM
27883 ENDIF
27884 ENDIF
27885
27886C...Net effect of all separate limits.
27887 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
27888 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
27889 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
27890 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
27891 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
27892
27893 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
27894 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
27895
27896 ELSEIF(ILIM.EQ.4) THEN
27897C...Calculate limits on tau'
27898C...0) due to kinematics
27899 TAPMN0=TAU
27900 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
27901 PQRAT=(VINT(201)+VINT(206))/VINT(1)
27902 TAPMN0=(SQRT(TAU)+PQRAT)**2
27903 ENDIF
27904 TAPMX0=1D0
27905C...1) due to explicit limits
27906 TAPMN1=CKIN(31)**2/VINT(2)
27907 TAPMX1=1D0
27908 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
27909
27910C...Net effect of all separate limits.
27911 VINT(16)=MAX(TAPMN0,TAPMN1)
27912 VINT(36)=MIN(TAPMX0,TAPMX1)
27913 IF(MINT(47).EQ.1) THEN
27914 VINT(16)=1D0-1D-9
27915 VINT(36)=1D0+1D-9
27916 ELSEIF(MINT(47).EQ.5) THEN
27917 VINT(36)=MIN(VINT(36),1D0-2D-10)
27918 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
27919 VINT(36)=MIN(VINT(36),1D0-1D-10)
27920 ENDIF
27921 IF(VINT(36).LE.VINT(16)) MINT(51)=1
27922
27923 ENDIF
27924 RETURN
27925
27926C...Special case for low-pT and multiple interactions:
27927C...effective kinematical limits for tau, y*, cos(theta-hat).
27928 100 IF(ILIM.EQ.0) THEN
27929 ELSEIF(ILIM.EQ.1) THEN
27930 IF(MSTP(82).LE.1) THEN
27931 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27932 & VINT(2)
27933 ELSE
27934 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
27935 ENDIF
27936 VINT(31)=1D0
27937 ELSEIF(ILIM.EQ.2) THEN
27938 VINT(12)=0.5D0*LOG(VINT(21))
27939 VINT(32)=-VINT(12)
27940 ELSEIF(ILIM.EQ.3) THEN
27941 IF(MSTP(82).LE.1) THEN
27942 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
27943 & (VINT(21)*VINT(2))
27944 ELSE
27945 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
27946 & (VINT(21)*VINT(2))
27947 ENDIF
27948 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
27949 VINT(33)=0D0
27950 VINT(14)=0D0
27951 VINT(34)=-VINT(13)
27952 ENDIF
27953
27954 RETURN
27955 END
27956
27957C*********************************************************************
27958
27959C...PYKMAP
27960C...Maps a uniform distribution into a distribution of a kinematical
27961C...variable according to one of the possibilities allowed. It is
27962C...assumed that kinematical limits have been set by a PYKLIM call.
27963
27964 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
27965
27966C...Double precision and integer declarations.
27967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27968 IMPLICIT INTEGER(I-N)
27969 INTEGER PYK,PYCHGE,PYCOMP
27970C...Commonblocks.
27971 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27972 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27973 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27975 COMMON/PYINT1/MINT(400),VINT(400)
27976 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27977 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
27978
27979C...Convert VVAR to tau variable.
27980 ISUB=MINT(1)
27981 ISTSB=ISET(ISUB)
27982 IF(IVAR.EQ.1) THEN
27983 TAUMIN=VINT(11)
27984 TAUMAX=VINT(31)
27985 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
27986 TAURE=VINT(73)
27987 GAMRE=VINT(74)
27988 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
27989 TAURE=VINT(75)
27990 GAMRE=VINT(76)
27991 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
27992 TAURE=VINT(77)
27993 GAMRE=VINT(78)
27994 ENDIF
27995 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
27996 TAU=1D0
27997 ELSEIF(MVAR.EQ.1) THEN
27998 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
27999 ELSEIF(MVAR.EQ.2) THEN
28000 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28001 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28002 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28003 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28004 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28005 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28006 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28007 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28008 ELSEIF(MINT(47).EQ.5) THEN
28009 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28010 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28011 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28012 ELSE
28013 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28014 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28015 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28016 ENDIF
28017 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28018
28019C...Convert VVAR to y* variable.
28020 ELSEIF(IVAR.EQ.2) THEN
28021 YSTMIN=VINT(12)
28022 YSTMAX=VINT(32)
28023 TAUE=VINT(21)
28024 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28025 IF(MINT(47).EQ.1) THEN
28026 YST=0D0
28027 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28028 YST=-0.5D0*LOG(TAUE)
28029 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28030 YST=0.5D0*LOG(TAUE)
28031 ELSEIF(MVAR.EQ.1) THEN
28032 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28033 ELSEIF(MVAR.EQ.2) THEN
28034 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28035 ELSEIF(MVAR.EQ.3) THEN
28036 AUPP=ATAN(EXP(YSTMAX))
28037 ALOW=ATAN(EXP(YSTMIN))
28038 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28039 ELSEIF(MVAR.EQ.4) THEN
28040 YST0=-0.5D0*LOG(TAUE)
28041 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28042 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28043 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28044 ELSE
28045 YST0=-0.5D0*LOG(TAUE)
28046 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28047 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28048 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28049 ENDIF
28050 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28051
28052C...Convert VVAR to cos(theta-hat) variable.
28053 ELSEIF(IVAR.EQ.3) THEN
28054 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28055 RSQM=1D0+RM34
28056 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28057 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28058 CTNMIN=VINT(13)
28059 CTNMAX=VINT(33)
28060 CTPMIN=VINT(14)
28061 CTPMAX=VINT(34)
28062 IF(MVAR.EQ.1) THEN
28063 ANEG=CTNMAX-CTNMIN
28064 APOS=CTPMAX-CTPMIN
28065 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28066 VCTN=VVAR*(ANEG+APOS)/ANEG
28067 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28068 ELSE
28069 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28070 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28071 ENDIF
28072 ELSEIF(MVAR.EQ.2) THEN
28073 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28074 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28075 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28076 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28077 ANEG=LOG(RMNMIN/RMNMAX)
28078 APOS=LOG(RMPMIN/RMPMAX)
28079 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28080 VCTN=VVAR*(ANEG+APOS)/ANEG
28081 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28082 ELSE
28083 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28084 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28085 ENDIF
28086 ELSEIF(MVAR.EQ.3) THEN
28087 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28088 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28089 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28090 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28091 ANEG=LOG(RMNMAX/RMNMIN)
28092 APOS=LOG(RMPMAX/RMPMIN)
28093 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28094 VCTN=VVAR*(ANEG+APOS)/ANEG
28095 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28096 ELSE
28097 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28098 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28099 ENDIF
28100 ELSEIF(MVAR.EQ.4) THEN
28101 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28102 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28103 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28104 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28105 ANEG=1D0/RMNMAX-1D0/RMNMIN
28106 APOS=1D0/RMPMAX-1D0/RMPMIN
28107 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28108 VCTN=VVAR*(ANEG+APOS)/ANEG
28109 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28110 ELSE
28111 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28112 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28113 ENDIF
28114 ELSEIF(MVAR.EQ.5) THEN
28115 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28116 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28117 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28118 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28119 ANEG=1D0/RMNMIN-1D0/RMNMAX
28120 APOS=1D0/RMPMIN-1D0/RMPMAX
28121 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28122 VCTN=VVAR*(ANEG+APOS)/ANEG
28123 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28124 ELSE
28125 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28126 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28127 ENDIF
28128 ENDIF
28129 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28130 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28131 VINT(23)=CTH
28132
28133C...Convert VVAR to tau' variable.
28134 ELSEIF(IVAR.EQ.4) THEN
28135 TAU=VINT(21)
28136 TAUPMN=VINT(16)
28137 TAUPMX=VINT(36)
28138 IF(MINT(47).EQ.1) THEN
28139 TAUP=1D0
28140 ELSEIF(MVAR.EQ.1) THEN
28141 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
28142 ELSEIF(MVAR.EQ.2) THEN
28143 AUPP=(1D0-TAU/TAUPMX)**4
28144 ALOW=(1D0-TAU/TAUPMN)**4
28145 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
28146 ELSEIF(MINT(47).EQ.5) THEN
28147 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
28148 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
28149 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28150 ELSE
28151 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
28152 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
28153 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28154 ENDIF
28155 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
28156
28157C...Selection of extra variables needed in 2 -> 3 process:
28158C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
28159C...Since no options are available, the functions of PYKLIM
28160C...and PYKMAP are joint for these choices.
28161 ELSEIF(IVAR.EQ.5) THEN
28162
28163C...Read out total energy and particle masses.
28164 MINT(51)=0
28165 MPTPK=1
28166 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
28167 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
28168 & MPTPK=2
28169 SHP=VINT(26)*VINT(2)
28170 SHPR=SQRT(SHP)
28171 PM1=VINT(201)
28172 PM2=VINT(206)
28173 PM3=SQRT(VINT(21))*VINT(1)
28174 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
28175 MINT(51)=1
28176 RETURN
28177 ENDIF
28178 PMRS1=VINT(204)**2
28179 PMRS2=VINT(209)**2
28180
28181C...Specify coefficients of pT choice; upper and lower limits.
28182 IF(MPTPK.EQ.1) THEN
28183 HWT1=0.4D0
28184 HWT2=0.4D0
28185 ELSE
28186 HWT1=0.05D0
28187 HWT2=0.05D0
28188 ENDIF
28189 HWT3=1D0-HWT1-HWT2
28190 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
28191 & (4D0*SHP)
28192 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
28193 PTSMN1=CKIN(51)**2
28194 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
28195 & (4D0*SHP)
28196 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
28197 PTSMN2=CKIN(53)**2
28198
28199C...Select transverse momenta according to
28200C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
28201 HMX=PMRS1+PTSMX1
28202 HMN=PMRS1+PTSMN1
28203 IF(HMX.LT.1.0001D0*HMN) THEN
28204 MINT(51)=1
28205 RETURN
28206 ENDIF
28207 HDE=PTSMX1-PTSMN1
28208 RPT=PYR(0)
28209 IF(RPT.LT.HWT1) THEN
28210 PTS1=PTSMN1+PYR(0)*HDE
28211 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28212 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
28213 ELSE
28214 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
28215 ENDIF
28216 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
28217 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
28218 HMX=PMRS2+PTSMX2
28219 HMN=PMRS2+PTSMN2
28220 IF(HMX.LT.1.0001D0*HMN) THEN
28221 MINT(51)=1
28222 RETURN
28223 ENDIF
28224 HDE=PTSMX2-PTSMN2
28225 RPT=PYR(0)
28226 IF(RPT.LT.HWT1) THEN
28227 PTS2=PTSMN2+PYR(0)*HDE
28228 ELSEIF(RPT.LT.HWT1+HWT2) THEN
28229 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
28230 ELSE
28231 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
28232 ENDIF
28233 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
28234 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
28235
28236C...Select azimuthal angles and check pT choice.
28237 PHI1=PARU(2)*PYR(0)
28238 PHI2=PARU(2)*PYR(0)
28239 PHIR=PHI2-PHI1
28240 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
28241 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
28242 & CKIN(56)**2)) THEN
28243 MINT(51)=1
28244 RETURN
28245 ENDIF
28246
28247C...Calculate transverse masses and check phase space not closed.
28248 PMS1=PM1**2+PTS1
28249 PMS2=PM2**2+PTS2
28250 PMS3=PM3**2+PTS3
28251 PMT1=SQRT(PMS1)
28252 PMT2=SQRT(PMS2)
28253 PMT3=SQRT(PMS3)
28254 PM12=(PMT1+PMT2)**2
28255 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
28256 MINT(51)=1
28257 RETURN
28258 ENDIF
28259
28260C...Select rapidity for particle 3 and check phase space not closed.
28261 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
28262 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
28263 IF(Y3MAX.LT.1D-6) THEN
28264 MINT(51)=1
28265 RETURN
28266 ENDIF
28267 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
28268 PZ3=PMT3*SINH(Y3)
28269 PE3=PMT3*COSH(Y3)
28270
28271C...Find momentum transfers in two mirror solutions (in 1-2 frame).
28272 PZ12=-PZ3
28273 PE12=SHPR-PE3
28274 PMS12=PE12**2-PZ12**2
28275 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
28276 IF(SQL12.LT.1D-6*SHP) THEN
28277 MINT(51)=1
28278 RETURN
28279 ENDIF
28280 PMM1=PMS12+PMS1-PMS2
28281 PMM2=PMS12+PMS2-PMS1
28282 TFAC=-SHPR/(2D0*PMS12)
28283 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
28284 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
28285 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
28286 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
28287
28288C...Construct relative mirror weights and make choice.
28289 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
28290 WTPU=1D0
28291 WTNU=1D0
28292 ELSE
28293 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
28294 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
28295 ENDIF
28296 WTP=WTPU/(WTPU+WTNU)
28297 WTN=WTNU/(WTPU+WTNU)
28298 EPS=1D0
28299 IF(WTN.GT.PYR(0)) EPS=-1D0
28300
28301C...Store result of variable choice and associated weights.
28302 VINT(202)=PTS1
28303 VINT(207)=PTS2
28304 VINT(203)=PHI1
28305 VINT(208)=PHI2
28306 VINT(205)=WTPTS1
28307 VINT(210)=WTPTS2
28308 VINT(211)=Y3
28309 VINT(212)=Y3MAX
28310 VINT(213)=EPS
28311 IF(EPS.GT.0D0) THEN
28312 VINT(214)=1D0/WTP
28313 VINT(215)=T1P
28314 VINT(216)=T2P
28315 ELSE
28316 VINT(214)=1D0/WTN
28317 VINT(215)=T1N
28318 VINT(216)=T2N
28319 ENDIF
28320 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
28321 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
28322 VINT(219)=0.5D0*(PMS12-PTS3)
28323 VINT(220)=SQL12
28324 ENDIF
28325
28326 RETURN
28327 END
28328
28329C***********************************************************************
28330
28331C...PYSIGH
28332C...Differential matrix elements for all included subprocesses
28333C...Note that what is coded is (disregarding the COMFAC factor)
28334C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
28335C...when d(sigma-hat) is given in the zero-width limit, the delta
28336C...function in tau is replaced by a (modified) Breit-Wigner:
28337C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
28338C...where H_res = s-hat/m_res*Gamma_res(s-hat);
28339C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
28340C...i.e., dimensionless quantities
28341C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
28342C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
28343C...(2pi)^4 delta^4(P - sum p_i)
28344C...COMFAC contains the factor pi/s (or equivalent) and
28345C...the conversion factor from GeV^-2 to mb
28346
28347 SUBROUTINE PYSIGH(NCHN,SIGS)
28348
28349C...Double precision and integer declarations
28350 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28351 IMPLICIT INTEGER(I-N)
28352 INTEGER PYK,PYCHGE,PYCOMP
28353C...Parameter statement to help give large particle numbers.
28354 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
28355 &KEXCIT=4000000,KDIMEN=5000000)
28356C...Commonblocks
28357 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28358 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28359 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28360 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28361 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28362 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28363 COMMON/PYINT1/MINT(400),VINT(400)
28364 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28365 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
28366 COMMON/PYINT4/MWID(500),WIDS(500,5)
28367 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28368 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
28369 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
28370 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
28371 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
28372 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
28373 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
28374 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
28375 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
28376 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
28377 COMMON/PYTCCO/COEFX(194:380,2)
28378 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28379 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
28380 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYSGCM/,/PYTCCO/
28381C...Local arrays and complex variables
28382 DIMENSION XPQ(-25:25)
28383
28384C...Map of processes onto which routine to call
28385C...in order to evaluate cross section:
28386C...0 = not implemented;
28387C...1 = standard QCD (including photons);
28388C...2 = heavy flavours;
28389C...3 = W/Z;
28390C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
28391C...5 = SUSY;
28392C...6 = Technicolor;
28393C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
28394 DIMENSION MAPPR(500)
28395 DATA (MAPPR(I),I=1,180)/
28396 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
28397 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
28398 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
28399 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
28400 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28401 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
28402 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
28403 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
28404 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28405 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
28406 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
28407 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
28408 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
28409 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
28410 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
28411 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
28412 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
28413 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
28414 DATA (MAPPR(I),I=181,500)/
28415 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
28416 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
28417 & 100*5,
28418 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
28419 1 30*0,
28420 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
28421 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
28422 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
28423 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
28424 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
28425 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
28426 & 4, 4, 18*0,
28427 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28428 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28429 4 20*0,
28430 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
28431 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
28432 8 20*0/
28433
28434C...Reset number of channels and cross-section
28435 NCHN=0
28436 SIGS=0D0
28437
28438C...Read process to consider.
28439 ISUB=MINT(1)
28440 ISUBSV=ISUB
28441 MAP=MAPPR(ISUB)
28442
28443C...Read kinematical variables and limits
28444 ISTSB=ISET(ISUBSV)
28445 TAUMIN=VINT(11)
28446 YSTMIN=VINT(12)
28447 CTNMIN=VINT(13)
28448 CTPMIN=VINT(14)
28449 TAUPMN=VINT(16)
28450 TAU=VINT(21)
28451 YST=VINT(22)
28452 CTH=VINT(23)
28453 XT2=VINT(25)
28454 TAUP=VINT(26)
28455 TAUMAX=VINT(31)
28456 YSTMAX=VINT(32)
28457 CTNMAX=VINT(33)
28458 CTPMAX=VINT(34)
28459 TAUPMX=VINT(36)
28460
28461C...Derive kinematical quantities
28462 TAUE=TAU
28463 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28464 X(1)=SQRT(TAUE)*EXP(YST)
28465 X(2)=SQRT(TAUE)*EXP(-YST)
28466 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
28467 IF(X(1).GT.1D0-1D-7) RETURN
28468 ELSEIF(MINT(45).EQ.3) THEN
28469 X(1)=MIN(1D0-1.1D-10,X(1))
28470 ENDIF
28471 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
28472 IF(X(2).GT.1D0-1D-7) RETURN
28473 ELSEIF(MINT(46).EQ.3) THEN
28474 X(2)=MIN(1D0-1.1D-10,X(2))
28475 ENDIF
28476 SH=MAX(1D0,TAU*VINT(2))
28477 SQM3=VINT(63)
28478 SQM4=VINT(64)
28479 RM3=SQM3/SH
28480 RM4=SQM4/SH
28481 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28482 RPTS=4D0*VINT(71)**2/SH
28483 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28484 RM34=MAX(1D-20,2D0*RM3*RM4)
28485 RSQM=1D0+RM34
28486 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
28487 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
28488 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28489 IF(ISTSB.EQ.0) THEN
28490 TH=VINT(45)
28491 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28492 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
28493 ELSE
28494C...Kinematics with incoming masses tricky: now depends on how
28495C...subprocess has been set up w.r.t. order of incoming partons.
28496 RM1=0D0
28497 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
28498 RM2=0D0
28499 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
28500 IF(ISUB.EQ.35) THEN
28501 RM2=MIN(RM1,RM2)
28502 RM1=0D0
28503 ENDIF
28504 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28505 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
28506 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
28507 & BE12*BE34*CTH)
28508 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
28509 & BE12*BE34*CTH)
28510 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
28511 ENDIF
28512 SHR=SQRT(SH)
28513 SH2=SH**2
28514 TH2=TH**2
28515 UH2=UH**2
28516
28517C...Choice of Q2 scale for hard process (e.g. alpha_s).
28518 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
28519 Q2=SH
28520 ELSEIF(ISTSB.EQ.8) THEN
28521 IF(MINT(107).EQ.4) Q2=VINT(307)
28522 IF(MINT(108).EQ.4) Q2=VINT(308)
28523 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
28524 Q2IN1=0D0
28525 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
28526 Q2IN2=0D0
28527 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
28528 IF(MSTP(32).EQ.1) THEN
28529 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
28530 ELSEIF(MSTP(32).EQ.2) THEN
28531 Q2=SQPTH+0.5D0*(SQM3+SQM4)
28532 ELSEIF(MSTP(32).EQ.3) THEN
28533 Q2=MIN(-TH,-UH)
28534 ELSEIF(MSTP(32).EQ.4) THEN
28535 Q2=SH
28536 ELSEIF(MSTP(32).EQ.5) THEN
28537 Q2=-TH
28538 ELSEIF(MSTP(32).EQ.6) THEN
28539 XSF1=X(1)
28540 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
28541 XSF2=X(2)
28542 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
28543 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
28544 & (SQPTH+0.5D0*(SQM3+SQM4))
28545 ELSEIF(MSTP(32).EQ.7) THEN
28546 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
28547 ELSEIF(MSTP(32).EQ.8) THEN
28548 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
28549 ELSEIF(MSTP(32).EQ.9) THEN
28550 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
28551 ELSEIF(MSTP(32).EQ.10) THEN
28552 Q2=VINT(2)
28553C..Begin JA 040914
28554 ELSEIF(MSTP(32).EQ.11) THEN
28555 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
28556 ELSEIF(MSTP(32).EQ.12) THEN
28557 Q2=PARP(193)
28558C..End JA
28559 ELSEIF(MSTP(32).EQ.13) THEN
28560 Q2=SQPTH
28561 ENDIF
28562 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
28563 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
28564 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
28565 ENDIF
28566
28567C...Choice of Q2 scale for parton densities.
28568 Q2SF=Q2
28569C..Begin JA 040914
28570 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
28571 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
28572 & Q2=PARP(194)
28573C..End JA
28574 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28575 Q2SF=PMAS(23,1)**2
28576 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
28577 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
28578 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
28579 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
28580 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
28581 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
28582 IF(MSTP(39).EQ.2) Q2SF=
28583 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
28584 IF(MSTP(39).EQ.3) Q2SF=SH
28585 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
28586 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
28587C..Begin JA 040914
28588 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
28589 IF(MSTP(39).EQ.7) Q2SF=
28590 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
28591 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
28592C..End JA
28593 ENDIF
28594 ENDIF
28595 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
28596
28597 Q2PS=Q2SF
28598 Q2SF=Q2SF*PARP(34)
28599 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
28600 IF(MSTP(69).GE.2) Q2SF=VINT(2)
28601
28602C...Identify to which class(es) subprocess belongs
28603 ISMECR=0
28604 ISQCD=0
28605 ISJETS=0
28606 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
28607 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
28608 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
28609 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
28610 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
28611 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
28612 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
28613 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
28614 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
28615 IF (ISTSB.EQ.9) ISQCD=1
28616 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
28617 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
28618 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
28619 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
28620 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
28621 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
28622 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
28623 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
28624C...WBF is special case of ISJETS
28625 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
28626 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
28627 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
28628 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
28629 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
28630 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
28631 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
28632 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
28633 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
28634C...Some processes with photons also belong here.
28635 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
28636 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
28637 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
28638 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
28639 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
28640 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
28641
28642C...Choice of Q2 scale for parton-shower activity.
28643 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
28644 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
28645 XBJ=X(2)
28646 IF(MINT(43).EQ.3) XBJ=X(1)
28647 IF(MSTP(22).EQ.1) THEN
28648 Q2PS=-TH
28649 ELSEIF(MSTP(22).EQ.2) THEN
28650 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
28651 ELSEIF(MSTP(22).EQ.3) THEN
28652 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
28653 ELSE
28654 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
28655 ENDIF
28656 ENDIF
28657C...For multiple interactions, start from scale defined above
28658C...For all other QCD or "+jets"-type events, start shower from pThard.
28659 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
28660 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
28661C...Max shower scale = s for ME corrected processes.
28662C...(pT-ordering: max pT2 is s/4)
28663 Q2PS=VINT(2)
28664 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28665 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
28666C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
28667C...(pT-ordering: max pT2 is s/4)
28668 Q2PS=VINT(2)
28669 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
28670 ENDIF
28671 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
28672
28673C...Elastic and diffractive events not associated with scales so set 0.
28674 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
28675 Q2SF=0D0
28676 Q2PS=0D0
28677 ENDIF
28678
28679C...Store derived kinematical quantities
28680 VINT(41)=X(1)
28681 VINT(42)=X(2)
28682 VINT(44)=SH
28683 VINT(43)=SQRT(SH)
28684 VINT(45)=TH
28685 VINT(46)=UH
28686 IF(ISTSB.NE.8) VINT(48)=SQPTH
28687 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
28688 VINT(50)=TAUP*VINT(2)
28689 VINT(49)=SQRT(MAX(0D0,VINT(50)))
28690 VINT(52)=Q2
28691 VINT(51)=SQRT(Q2)
28692 VINT(54)=Q2SF
28693 VINT(53)=SQRT(Q2SF)
28694 VINT(56)=Q2PS
28695 VINT(55)=SQRT(Q2PS)
28696
28697C...Set starting scale for multiple interactions
28698 IF (ISUBSV.EQ.95) THEN
28699 XT2GMX=0D0
28700 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
28701 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
28702 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
28703 & ISUBSV.NE.96)) THEN
28704C...All accessible phase space allowed.
28705 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
28706 ELSE
28707C...Scale of hard process sets limit.
28708C...2 -> 1. Limit is tau = x1*x2.
28709C...2 -> 2. Limit is XT2 for hard process + FS masses.
28710C...2 -> n > 2. Limit is tau' = tau of outer process.
28711 XT2GMX=VINT(25)
28712 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
28713 IF(ISTSB.EQ.2)
28714 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
28715 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
28716 ENDIF
28717 VINT(62)=0.25D0*XT2GMX*VINT(2)
28718 VINT(61)=SQRT(MAX(0D0,VINT(62)))
28719
28720C...Calculate parton distributions
28721 IF(ISTSB.LE.0) GOTO 160
28722 IF(MINT(47).GE.2) THEN
28723 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
28724 XSF=X(I)
28725 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
28726 IF(ISUB.EQ.99) THEN
28727 IF(MINT(140+I).EQ.0) THEN
28728 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
28729 ELSE
28730 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
28731 ENDIF
28732 VINT(40+I)=XSF
28733 Q2SF=VINT(309-I)
28734 ENDIF
28735 MINT(105)=MINT(102+I)
28736 MINT(109)=MINT(106+I)
28737 VINT(120)=VINT(2+I)
28738C.... ALICE
28739C.... Store side in MINT(124)
28740 MINT(124)=I
28741C....
28742 IF(MSTP(57).LE.1) THEN
28743 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
28744 ELSE
28745 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
28746 ENDIF
28747C...Safety margin against heavy flavour very close to threshold,
28748C...e.g. caused by mismatch in c and b masses.
28749 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
28750 XPQ(4)=0D0
28751 XPQ(-4)=0D0
28752 ENDIF
28753 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
28754 XPQ(5)=0D0
28755 XPQ(-5)=0D0
28756 ENDIF
28757 DO 100 KFL=-25,25
28758 XSFX(I,KFL)=XPQ(KFL)
28759 100 CONTINUE
28760 110 CONTINUE
28761 ENDIF
28762
28763C...Calculate alpha_em, alpha_strong and K-factor
28764 XW=PARU(102)
28765 XWV=XW
28766 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
28767 &1D0-(PMAS(24,1)/PMAS(23,1))**2
28768 XW1=1D0-XW
28769 XWC=1D0/(16D0*XW*XW1)
28770 AEM=PYALEM(Q2)
28771 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
28772 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
28773 FACK=1D0
28774 FACA=1D0
28775 IF(MSTP(33).EQ.1) THEN
28776 FACK=PARP(31)
28777 ELSEIF(MSTP(33).EQ.2) THEN
28778 FACK=PARP(31)
28779 FACA=PARP(32)/PARP(31)
28780 ELSEIF(MSTP(33).EQ.3) THEN
28781 Q2AS=PARP(33)*Q2
28782 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
28783 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
28784 AS=PYALPS(Q2AS)
28785 ENDIF
28786 VINT(138)=1D0
28787 VINT(57)=AEM
28788 VINT(58)=AS
28789
28790C...Set flags for allowed reacting partons/leptons
28791 DO 140 I=1,2
28792 DO 120 J=-25,25
28793 KFAC(I,J)=0
28794 120 CONTINUE
28795 IF(MINT(44+I).EQ.1) THEN
28796 KFAC(I,MINT(10+I))=1
28797 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
28798 KFAC(I,MINT(10+I))=1
28799 KFAC(I,22)=1
28800 KFAC(I,24)=1
28801 KFAC(I,-24)=1
28802 ELSE
28803 DO 130 J=-25,25
28804 KFAC(I,J)=KFIN(I,J)
28805 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
28806 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
28807 130 CONTINUE
28808 ENDIF
28809 140 CONTINUE
28810
28811C...Lower and upper limit for fermion flavour loops
28812 MMIN1=0
28813 MMAX1=0
28814 MMIN2=0
28815 MMAX2=0
28816 DO 150 J=-20,20
28817 IF(KFAC(1,-J).EQ.1) MMIN1=-J
28818 IF(KFAC(1,J).EQ.1) MMAX1=J
28819 IF(KFAC(2,-J).EQ.1) MMIN2=-J
28820 IF(KFAC(2,J).EQ.1) MMAX2=J
28821 150 CONTINUE
28822 MMINA=MIN(MMIN1,MMIN2)
28823 MMAXA=MAX(MMAX1,MMAX2)
28824
28825C...Common resonance mass and width combinations
28826 SQMZ=PMAS(23,1)**2
28827 SQMW=PMAS(24,1)**2
28828 GMMZ=PMAS(23,1)*PMAS(23,2)
28829 GMMW=PMAS(24,1)*PMAS(24,2)
28830
28831C...Polarization factors...implemented so far for W+W-(25)
28832 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
28833 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
28834 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
28835 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
28836
28837C...Phase space integral in tau
28838 COMFAC=PARU(1)*PARU(5)/VINT(2)
28839 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
28840 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
28841 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
28842 ATAU1=LOG(TAUMAX/TAUMIN)
28843 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
28844 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
28845 IF(MINT(72).GE.1) THEN
28846 TAUR1=VINT(73)
28847 GAMR1=VINT(74)
28848 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
28849 ATAU3=ATAUD/TAUR1
28850 IF(ATAUD.GT.1D-10) H1=H1+
28851 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
28852 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
28853 ATAU4=ATAUD/GAMR1
28854 IF(ATAUD.GT.1D-10) H1=H1+
28855 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
28856 ENDIF
28857 IF(MINT(72).GE.2) THEN
28858 TAUR2=VINT(75)
28859 GAMR2=VINT(76)
28860 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
28861 ATAU5=ATAUD/TAUR2
28862 IF(ATAUD.GT.1D-10) H1=H1+
28863 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
28864 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
28865 ATAU6=ATAUD/GAMR2
28866 IF(ATAUD.GT.1D-10) H1=H1+
28867 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
28868 ENDIF
28869 IF(MINT(72).EQ.3) THEN
28870 TAUR3=VINT(77)
28871 GAMR3=VINT(78)
28872 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
28873 ATAU50=ATAUD/TAUR3
28874 IF(ATAUD.GT.1D-10) H1=H1+
28875 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
28876 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
28877 ATAU60=ATAUD/GAMR3
28878 IF(ATAUD.GT.1D-10) H1=H1+
28879 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
28880 ENDIF
28881 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28882 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
28883 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28884 & MAX(2D-10,1D0-TAU)
28885 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
28886 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
28887 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
28888 & MAX(1D-10,1D0-TAU)
28889 ENDIF
28890 COMFAC=COMFAC*ATAU1/(TAU*H1)
28891 ENDIF
28892
28893C...Phase space integral in y*
28894 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
28895 &THEN
28896 AYST0=YSTMAX-YSTMIN
28897 IF(AYST0.LT.1D-10) THEN
28898 COMFAC=0D0
28899 ELSE
28900 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
28901 AYST2=AYST1
28902 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
28903 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
28904 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
28905 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
28906 IF(MINT(45).EQ.3) THEN
28907 YST0=-0.5D0*LOG(TAUE)
28908 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
28909 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28910 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
28911 & MAX(1D-10,1D0-EXP(YST-YST0))
28912 ENDIF
28913 IF(MINT(46).EQ.3) THEN
28914 YST0=-0.5D0*LOG(TAUE)
28915 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
28916 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28917 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
28918 & MAX(1D-10,1D0-EXP(-YST-YST0))
28919 ENDIF
28920 COMFAC=COMFAC*AYST0/H2
28921 ENDIF
28922 ENDIF
28923
28924C...2 -> 1 processes: reduction in angular part of phase space integral
28925C...for case of decaying resonance
28926 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
28927 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
28928 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
28929 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
28930 & KFPR(ISUB,1).EQ.39) THEN
28931 COMFAC=COMFAC*0.5D0*ACTH0
28932 ELSE
28933 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
28934 & CTPMAX**3-CTPMIN**3)
28935 ENDIF
28936 ENDIF
28937
28938C...2 -> 2 processes: angular part of phase space integral
28939 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28940 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
28941 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
28942 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
28943 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
28944 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
28945 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
28946 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
28947 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
28948 H3=COEF(ISUBSV,13)+
28949 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
28950 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
28951 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
28952 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
28953 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
28954
28955C...2 -> 2 processes: take into account final state Breit-Wigners
28956 COMFAC=COMFAC*VINT(80)
28957 ENDIF
28958
28959C...2 -> 3, 4 processes: phace space integral in tau'
28960 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28961 ATAUP1=LOG(TAUPMX/TAUPMN)
28962 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
28963 H4=COEF(ISUBSV,18)+
28964 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
28965 IF(MINT(47).EQ.5) THEN
28966 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
28967 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
28968 ELSEIF(MINT(47).GE.6) THEN
28969 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
28970 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
28971 ENDIF
28972 COMFAC=COMFAC*ATAUP1/H4
28973 ENDIF
28974
28975C...2 -> 3, 4 processes: effective W/Z parton distributions
28976 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
28977 IF(1D0-TAU/TAUP.GT.1D-4) THEN
28978 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
28979 ELSE
28980 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
28981 ENDIF
28982 COMFAC=COMFAC*FZW
28983 ENDIF
28984
28985C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
28986 IF(ISTSB.EQ.5) THEN
28987 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
28988 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
28989 ENDIF
28990
28991C...Phase space integral for low-pT and multiple interactions
28992 IF(ISTSB.EQ.9) THEN
28993 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
28994 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
28995 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
28996 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
28997 COMFAC=COMFAC*ATAU1/H1
28998 AYST0=YSTMAX-YSTMIN
28999 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29000 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29001 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29002 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29003 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29004 COMFAC=COMFAC*AYST0/H2
29005 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29006C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29007C...introduced to make cross-section finite for xT2 -> 0
29008 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29009 & (1D0+VINT(149)))
29010 ENDIF
29011
29012C...Real gamma + gamma: include factor 2 when different nature
29013 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29014 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29015
29016C...Extra factors to include the effects of
29017C...longitudinal resolved photons (but not direct or DIS ones).
29018 DO 170 ISDE=1,2
29019 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29020 & MINT(106+ISDE).LE.3) THEN
29021 VINT(314+ISDE)=1D0
29022 XY=PARP(166+ISDE)
29023 IF(MSTP(16).EQ.0) THEN
29024 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29025 & XY=VINT(304+ISDE)
29026 ELSE
29027 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29028 & XY=VINT(308+ISDE)
29029 ENDIF
29030 Q2GA=VINT(306+ISDE)
29031 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29032 & Q2GA.GT.0D0) THEN
29033 REDUCE=0D0
29034 IF(MSTP(17).EQ.1) THEN
29035 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29036 ELSEIF(MSTP(17).EQ.2) THEN
29037 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29038 ELSEIF(MSTP(17).EQ.3) THEN
29039 PMVIRT=PMAS(PYCOMP(113),1)
29040 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29041 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29042 PMVIRT=PMAS(PYCOMP(113),1)
29043 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29044 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29045 PMVIRT=PMAS(PYCOMP(113),1)
29046 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29047 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29048 PMVSMN=4D0*PARP(15)**2
29049 PMVSMX=4D0*VINT(154)**2
29050 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29051 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29052 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29053 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29054 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29055 PMVIRT=PMAS(PYCOMP(113),1)
29056 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29057 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29058 PMVIRT=PMAS(PYCOMP(113),1)
29059 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29060 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29061 PMVSMN=4D0*PARP(15)**2
29062 PMVSMX=4D0*VINT(154)**2
29063 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29064 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29065 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29066 ENDIF
29067 BEAMAS=PYMASS(11)
29068 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29069 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29070 & (1D0-2D0*BEAMAS**2/Q2GA))
29071 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29072 ENDIF
29073 ELSE
29074 VINT(314+ISDE)=1D0
29075 ENDIF
29076 COMFAC=COMFAC*VINT(314+ISDE)
29077 170 CONTINUE
29078
29079C...Evaluate cross sections - done in separate routines by kind
29080C...of physics, to keep PYSIGH of sensible size.
29081 IF(MAP.EQ.1) THEN
29082C...Standard QCD (including photons).
29083 CALL PYSGQC(NCHN,SIGS)
29084 ELSEIF(MAP.EQ.2) THEN
29085C...Heavy flavours.
29086 CALL PYSGHF(NCHN,SIGS)
29087 ELSEIF(MAP.EQ.3) THEN
29088C...W/Z.
29089 CALL PYSGWZ(NCHN,SIGS)
29090 ELSEIF(MAP.EQ.4) THEN
29091C...Higgs (2 doublets; including longitudinal W/Z scattering).
29092 CALL PYSGHG(NCHN,SIGS)
29093 ELSEIF(MAP.EQ.5) THEN
29094C...SUSY.
29095 CALL PYSGSU(NCHN,SIGS)
29096 ELSEIF(MAP.EQ.6) THEN
29097C...Technicolor.
29098 CALL PYSGTC(NCHN,SIGS)
29099 ELSEIF(MAP.EQ.7) THEN
29100C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29101 CALL PYSGEX(NCHN,SIGS)
29102 ENDIF
29103
29104C...Multiply with parton distributions
29105 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29106 DO 180 ICHN=1,NCHN
29107 IF(MINT(45).GE.2) THEN
29108 KFL1=ISIG(ICHN,1)
29109 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29110 ENDIF
29111 IF(MINT(46).GE.2) THEN
29112 KFL2=ISIG(ICHN,2)
29113 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29114 ENDIF
29115 SIGS=SIGS+SIGH(ICHN)
29116 180 CONTINUE
29117 ENDIF
29118
29119 RETURN
29120 END
29121
29122C*********************************************************************
29123
29124C...PYSGQC
29125C...Subprocess cross sections for QCD processes,
29126C...including photons.
29127C...Auxiliary to PYSIGH.
29128
29129 SUBROUTINE PYSGQC(NCHN,SIGS)
29130
29131C...Double precision and integer declarations
29132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29133 IMPLICIT INTEGER(I-N)
29134 INTEGER PYK,PYCHGE,PYCOMP
29135C...Parameter statement to help give large particle numbers.
29136 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29137 &KEXCIT=4000000,KDIMEN=5000000)
29138C...Commonblocks
29139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29140 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29141 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29142 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29143 COMMON/PYINT1/MINT(400),VINT(400)
29144 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29145 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29146 COMMON/PYINT4/MWID(500),WIDS(500,5)
29147 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29148 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29149 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29150 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29151 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29152 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
29153 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
29154C...Local arrays
29155 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
29156
29157C...Differential cross section expressions.
29158
29159 IF(ISUB.LE.20) THEN
29160 IF(ISUB.EQ.10) THEN
29161C...f + f' -> f + f' (gamma/Z/W exchange)
29162 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
29163 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
29164 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
29165 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
29166 DO 110 I=MMIN1,MMAX1
29167 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
29168 IA=IABS(I)
29169 DO 100 J=MMIN2,MMAX2
29170 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
29171 JA=IABS(J)
29172C...Electroweak couplings
29173 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
29174 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
29175 VI=AI-4D0*EI*XWV
29176 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
29177 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
29178 VJ=AJ-4D0*EJ*XWV
29179 EPSIJ=ISIGN(1,I*J)
29180C...gamma/Z exchange, only gamma exchange, or only Z exchange
29181 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
29182 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
29183 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
29184 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
29185 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
29186 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29187 ELSEIF(MSTP(21).EQ.2) THEN
29188 FACNCF=FACGGF*EI**2*EJ**2
29189 ELSE
29190 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
29191 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
29192 ENDIF
29193C...Extrafactor 2 for only one incoming neutrino spin state.
29194 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
29195 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
29196 NCHN=NCHN+1
29197 ISIG(NCHN,1)=I
29198 ISIG(NCHN,2)=J
29199 ISIG(NCHN,3)=1
29200 SIGH(NCHN)=FACNCF
29201 ENDIF
29202C...W exchange
29203 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
29204 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
29205 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
29206 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
29207 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
29208 NCHN=NCHN+1
29209 ISIG(NCHN,1)=I
29210 ISIG(NCHN,2)=J
29211 ISIG(NCHN,3)=2
29212 SIGH(NCHN)=FACCCF
29213 ENDIF
29214 100 CONTINUE
29215 110 CONTINUE
29216
29217 ELSEIF(ISUB.EQ.11) THEN
29218C...f + f' -> f + f' (g exchange)
29219 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29220 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29221 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29222 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
29223 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
29224 DO 130 I=MMIN1,MMAX1
29225 IA=IABS(I)
29226 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
29227 DO 120 J=MMIN2,MMAX2
29228 JA=IABS(J)
29229 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
29230 NCHN=NCHN+1
29231 ISIG(NCHN,1)=I
29232 ISIG(NCHN,2)=J
29233 ISIG(NCHN,3)=1
29234 SIGH(NCHN)=FACQQ1
29235 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29236 IF(I.EQ.J) THEN
29237 SIGH(NCHN)=0.5D0*SIGH(NCHN)
29238 NCHN=NCHN+1
29239 ISIG(NCHN,1)=I
29240 ISIG(NCHN,2)=J
29241 ISIG(NCHN,3)=2
29242 SIGH(NCHN)=0.5D0*FACQQ2
29243 ENDIF
29244 120 CONTINUE
29245 130 CONTINUE
29246
29247 ELSEIF(ISUB.EQ.12) THEN
29248C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
29249 CALL PYWIDT(21,SH,WDTP,WDTE)
29250 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29251 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
29252 DO 140 I=MMINA,MMAXA
29253 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29254 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
29255 NCHN=NCHN+1
29256 ISIG(NCHN,1)=I
29257 ISIG(NCHN,2)=-I
29258 ISIG(NCHN,3)=1
29259 SIGH(NCHN)=FACQQB
29260 140 CONTINUE
29261
29262 ELSEIF(ISUB.EQ.13) THEN
29263C...f + fbar -> g + g (q + qbar -> g + g only)
29264 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29265 & UH2/SH2)
29266 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29267 & TH2/SH2)
29268 DO 150 I=MMINA,MMAXA
29269 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29270 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
29271 NCHN=NCHN+1
29272 ISIG(NCHN,1)=I
29273 ISIG(NCHN,2)=-I
29274 ISIG(NCHN,3)=1
29275 SIGH(NCHN)=0.5D0*FACGG1
29276 NCHN=NCHN+1
29277 ISIG(NCHN,1)=I
29278 ISIG(NCHN,2)=-I
29279 ISIG(NCHN,3)=2
29280 SIGH(NCHN)=0.5D0*FACGG2
29281 150 CONTINUE
29282
29283 ELSEIF(ISUB.EQ.14) THEN
29284C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
29285 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
29286 DO 160 I=MMINA,MMAXA
29287 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
29288 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
29289 EI=KCHG(IABS(I),1)/3D0
29290 NCHN=NCHN+1
29291 ISIG(NCHN,1)=I
29292 ISIG(NCHN,2)=-I
29293 ISIG(NCHN,3)=1
29294 SIGH(NCHN)=FACGG*EI**2
29295 160 CONTINUE
29296
29297 ELSEIF(ISUB.EQ.18) THEN
29298C...f + fbar -> gamma + gamma
29299 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
29300 DO 170 I=MMINA,MMAXA
29301 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
29302 EI=KCHG(IABS(I),1)/3D0
29303 FCOI=1D0
29304 IF(IABS(I).LE.10) FCOI=FACA/3D0
29305 NCHN=NCHN+1
29306 ISIG(NCHN,1)=I
29307 ISIG(NCHN,2)=-I
29308 ISIG(NCHN,3)=1
29309 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
29310 170 CONTINUE
29311 ENDIF
29312
29313 ELSEIF(ISUB.LE.40) THEN
29314 IF(ISUB.EQ.28) THEN
29315C...f + g -> f + g (q + g -> q + g only)
29316 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29317 & UH/SH)*FACA
29318 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29319 & SH/UH)
29320 DO 190 I=MMINA,MMAXA
29321 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
29322 DO 180 ISDE=1,2
29323 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
29324 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
29325 NCHN=NCHN+1
29326 ISIG(NCHN,ISDE)=I
29327 ISIG(NCHN,3-ISDE)=21
29328 ISIG(NCHN,3)=1
29329 SIGH(NCHN)=FACQG1
29330 NCHN=NCHN+1
29331 ISIG(NCHN,ISDE)=I
29332 ISIG(NCHN,3-ISDE)=21
29333 ISIG(NCHN,3)=2
29334 SIGH(NCHN)=FACQG2
29335 180 CONTINUE
29336 190 CONTINUE
29337
29338 ELSEIF(ISUB.EQ.29) THEN
29339C...f + g -> f + gamma (q + g -> q + gamma only)
29340 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
29341 DO 210 I=MMINA,MMAXA
29342 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
29343 EI=KCHG(IABS(I),1)/3D0
29344 FACGQ=FGQ*EI**2
29345 DO 200 ISDE=1,2
29346 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
29347 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
29348 NCHN=NCHN+1
29349 ISIG(NCHN,ISDE)=I
29350 ISIG(NCHN,3-ISDE)=21
29351 ISIG(NCHN,3)=1
29352 SIGH(NCHN)=FACGQ
29353 200 CONTINUE
29354 210 CONTINUE
29355
29356 ELSEIF(ISUB.EQ.33) THEN
29357C...f + gamma -> f + g (q + gamma -> q + g only)
29358 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
29359 DO 230 I=MMINA,MMAXA
29360 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
29361 EI=KCHG(IABS(I),1)/3D0
29362 FACGQ=FGQ*EI**2
29363 DO 220 ISDE=1,2
29364 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
29365 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
29366 NCHN=NCHN+1
29367 ISIG(NCHN,ISDE)=I
29368 ISIG(NCHN,3-ISDE)=22
29369 ISIG(NCHN,3)=1
29370 SIGH(NCHN)=FACGQ
29371 220 CONTINUE
29372 230 CONTINUE
29373
29374 ELSEIF(ISUB.EQ.34) THEN
29375C...f + gamma -> f + gamma
29376 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
29377 DO 250 I=MMINA,MMAXA
29378 IF(I.EQ.0) GOTO 250
29379 EI=KCHG(IABS(I),1)/3D0
29380 FACGQ=FGQ*EI**4
29381 DO 240 ISDE=1,2
29382 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
29383 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
29384 NCHN=NCHN+1
29385 ISIG(NCHN,ISDE)=I
29386 ISIG(NCHN,3-ISDE)=22
29387 ISIG(NCHN,3)=1
29388 SIGH(NCHN)=FACGQ
29389 240 CONTINUE
29390 250 CONTINUE
29391 ENDIF
29392
29393 ELSEIF(ISUB.LE.80) THEN
29394 IF(ISUB.EQ.53) THEN
29395C...g + g -> f + fbar (g + g -> q + qbar only)
29396 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
29397 IDC0=MDCY(21,2)-1
29398C...Begin by d, u, s flavours.
29399 FLAVWT=0D0
29400 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29401 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29402 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29403 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29404 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29405 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29406 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29407 & UH2/SH2)*FLAVWT*FACA
29408 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29409 & TH2/SH2)*FLAVWT*FACA
29410 NCHN=NCHN+1
29411 ISIG(NCHN,1)=21
29412 ISIG(NCHN,2)=21
29413 ISIG(NCHN,3)=1
29414 SIGH(NCHN)=FACQQ1
29415 NCHN=NCHN+1
29416 ISIG(NCHN,1)=21
29417 ISIG(NCHN,2)=21
29418 ISIG(NCHN,3)=2
29419 SIGH(NCHN)=FACQQ2
29420C...Next c and b flavours: modified that and uhat for fixed
29421C...cos(theta-hat).
29422 DO 260 IFL=4,5
29423 SQMAVG=PMAS(IFL,1)**2
29424 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29425 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29426 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29427 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29428 THUHQ=THQ*UHQ-SQMAVG*SH
29429 IF(MSTP(34).EQ.0) THEN
29430 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29431 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29432 ELSE
29433 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29434 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29435 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29436 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29437 ENDIF
29438 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29439 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29440 NCHN=NCHN+1
29441 ISIG(NCHN,1)=21
29442 ISIG(NCHN,2)=21
29443 ISIG(NCHN,3)=1+2*(IFL-3)
29444 SIGH(NCHN)=FACQQ1
29445 NCHN=NCHN+1
29446 ISIG(NCHN,1)=21
29447 ISIG(NCHN,2)=21
29448 ISIG(NCHN,3)=2+2*(IFL-3)
29449 SIGH(NCHN)=FACQQ2
29450 ENDIF
29451 260 CONTINUE
29452 270 CONTINUE
29453
29454 ELSEIF(ISUB.EQ.54) THEN
29455C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
29456 CALL PYWIDT(21,SH,WDTP,WDTE)
29457 WDTESU=0D0
29458 DO 280 I=1,MIN(8,MDCY(21,3))
29459 EF=KCHG(I,1)/3D0
29460 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29461 & WDTE(I,4))
29462 280 CONTINUE
29463 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
29464 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29465 NCHN=NCHN+1
29466 ISIG(NCHN,1)=21
29467 ISIG(NCHN,2)=22
29468 ISIG(NCHN,3)=1
29469 SIGH(NCHN)=FACQQ
29470 ENDIF
29471 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29472 NCHN=NCHN+1
29473 ISIG(NCHN,1)=22
29474 ISIG(NCHN,2)=21
29475 ISIG(NCHN,3)=1
29476 SIGH(NCHN)=FACQQ
29477 ENDIF
29478
29479 ELSEIF(ISUB.EQ.58) THEN
29480C...gamma + gamma -> f + fbar
29481 CALL PYWIDT(22,SH,WDTP,WDTE)
29482 WDTESU=0D0
29483 DO 290 I=1,MIN(12,MDCY(22,3))
29484 IF(I.LE.8) EF= KCHG(I,1)/3D0
29485 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
29486 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29487 & WDTE(I,4))
29488 290 CONTINUE
29489 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
29490 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
29491 NCHN=NCHN+1
29492 ISIG(NCHN,1)=22
29493 ISIG(NCHN,2)=22
29494 ISIG(NCHN,3)=1
29495 SIGH(NCHN)=FACFF
29496 ENDIF
29497
29498 ELSEIF(ISUB.EQ.68) THEN
29499C...g + g -> g + g
29500 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
29501 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
29502 & TH2/SH2)*FACA
29503 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
29504 & SH2/UH2)*FACA
29505 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
29506 & UH2/TH2)
29507 NCHN=NCHN+1
29508 ISIG(NCHN,1)=21
29509 ISIG(NCHN,2)=21
29510 ISIG(NCHN,3)=1
29511 SIGH(NCHN)=0.5D0*FACGG1
29512 NCHN=NCHN+1
29513 ISIG(NCHN,1)=21
29514 ISIG(NCHN,2)=21
29515 ISIG(NCHN,3)=2
29516 SIGH(NCHN)=0.5D0*FACGG2
29517 NCHN=NCHN+1
29518 ISIG(NCHN,1)=21
29519 ISIG(NCHN,2)=21
29520 ISIG(NCHN,3)=3
29521 SIGH(NCHN)=0.5D0*FACGG3
29522 300 CONTINUE
29523
29524 ELSEIF(ISUB.EQ.80) THEN
29525C...q + gamma -> q' + pi+/-
29526 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
29527 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
29528 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
29529 DELSH=UH*SQRT(ASSH*Q2FPSH)
29530 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
29531 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
29532 DELUH=SH*SQRT(ASUH*Q2FPUH)
29533 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
29534 IF(I.EQ.0) GOTO 320
29535 EI=KCHG(IABS(I),1)/3D0
29536 EJ=SIGN(1D0-ABS(EI),EI)
29537 DO 310 ISDE=1,2
29538 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
29539 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
29540 NCHN=NCHN+1
29541 ISIG(NCHN,ISDE)=I
29542 ISIG(NCHN,3-ISDE)=22
29543 ISIG(NCHN,3)=1
29544 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
29545 310 CONTINUE
29546 320 CONTINUE
29547 ENDIF
29548
29549 ELSEIF(ISUB.LE.100) THEN
29550 IF(ISUB.EQ.91) THEN
29551C...Elastic scattering
29552 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
29553
29554 ELSEIF(ISUB.EQ.92) THEN
29555C...Single diffractive scattering (first side, i.e. XB)
29556 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
29557
29558 ELSEIF(ISUB.EQ.93) THEN
29559C...Single diffractive scattering (second side, i.e. AX)
29560 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
29561
29562 ELSEIF(ISUB.EQ.94) THEN
29563C...Double diffractive scattering
29564 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
29565
29566 ELSEIF(ISUB.EQ.95) THEN
29567C...Low-pT scattering
29568 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
29569
29570 ELSEIF(ISUB.EQ.96) THEN
29571C...Multiple interactions: sum of QCD processes
29572 CALL PYWIDT(21,SH,WDTP,WDTE)
29573
29574C...q + q' -> q + q'
29575 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
29576 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
29577 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
29578 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
29579 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
29580 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
29581 DO 340 I=-5,5
29582 IF(I.EQ.0) GOTO 340
29583 DO 330 J=-5,5
29584 IF(J.EQ.0) GOTO 330
29585 NCHN=NCHN+1
29586 ISIG(NCHN,1)=I
29587 ISIG(NCHN,2)=J
29588 ISIG(NCHN,3)=111
29589 SIGH(NCHN)=FACQQ1
29590 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
29591 IF(I.EQ.J) THEN
29592 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
29593 NCHN=NCHN+1
29594 ISIG(NCHN,1)=I
29595 ISIG(NCHN,2)=J
29596 ISIG(NCHN,3)=112
29597 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
29598 ENDIF
29599 330 CONTINUE
29600 340 CONTINUE
29601
29602C...q + qbar -> q' + qbar' or g + g
29603 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
29604 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
29605 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29606 & UH2/SH2)
29607 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29608 & TH2/SH2)
29609 DO 350 I=-5,5
29610 IF(I.EQ.0) GOTO 350
29611 NCHN=NCHN+1
29612 ISIG(NCHN,1)=I
29613 ISIG(NCHN,2)=-I
29614 ISIG(NCHN,3)=121
29615 SIGH(NCHN)=FACQQB
29616 NCHN=NCHN+1
29617 ISIG(NCHN,1)=I
29618 ISIG(NCHN,2)=-I
29619 ISIG(NCHN,3)=131
29620 SIGH(NCHN)=0.5D0*FACGG1
29621 NCHN=NCHN+1
29622 ISIG(NCHN,1)=I
29623 ISIG(NCHN,2)=-I
29624 ISIG(NCHN,3)=132
29625 SIGH(NCHN)=0.5D0*FACGG2
29626 350 CONTINUE
29627
29628C...q + g -> q + g
29629 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
29630 & UH/SH)*FACA
29631 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
29632 & SH/UH)
29633 DO 370 I=-5,5
29634 IF(I.EQ.0) GOTO 370
29635 DO 360 ISDE=1,2
29636 NCHN=NCHN+1
29637 ISIG(NCHN,ISDE)=I
29638 ISIG(NCHN,3-ISDE)=21
29639 ISIG(NCHN,3)=281
29640 SIGH(NCHN)=FACQG1
29641 NCHN=NCHN+1
29642 ISIG(NCHN,ISDE)=I
29643 ISIG(NCHN,3-ISDE)=21
29644 ISIG(NCHN,3)=282
29645 SIGH(NCHN)=FACQG2
29646 360 CONTINUE
29647 370 CONTINUE
29648
29649C...g + g -> q + qbar (only d, u, s)
29650 IDC0=MDCY(21,2)-1
29651 FLAVWT=0D0
29652 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
29653 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
29654 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
29655 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
29656 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
29657 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
29658 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
29659 & UH2/SH2)*FLAVWT*FACA
29660 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
29661 & TH2/SH2)*FLAVWT*FACA
29662 NCHN=NCHN+1
29663 ISIG(NCHN,1)=21
29664 ISIG(NCHN,2)=21
29665 ISIG(NCHN,3)=531
29666 SIGH(NCHN)=FACQQ1
29667 NCHN=NCHN+1
29668 ISIG(NCHN,1)=21
29669 ISIG(NCHN,2)=21
29670 ISIG(NCHN,3)=532
29671 SIGH(NCHN)=FACQQ2
29672
29673C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
29674C...cos(theta-hat)
29675 DO 380 IFL=4,5
29676 SQMAVG=PMAS(IFL,1)**2
29677 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
29678 BE34=SQRT(1D0-4D0*SQMAVG/SH)
29679 THQ=-0.5D0*SH*(1D0-BE34*CTH)
29680 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
29681 THUHQ=THQ*UHQ-SQMAVG*SH
29682 IF(MSTP(34).EQ.0) THEN
29683 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
29684 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
29685 ELSE
29686 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29687 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
29688 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
29689 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
29690 ENDIF
29691 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
29692 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
29693 NCHN=NCHN+1
29694 ISIG(NCHN,1)=21
29695 ISIG(NCHN,2)=21
29696 ISIG(NCHN,3)=531+2*(IFL-3)
29697 SIGH(NCHN)=FACQQ1
29698 NCHN=NCHN+1
29699 ISIG(NCHN,1)=21
29700 ISIG(NCHN,2)=21
29701 ISIG(NCHN,3)=532+2*(IFL-3)
29702 SIGH(NCHN)=FACQQ2
29703 ENDIF
29704 380 CONTINUE
29705
29706C...g + g -> g + g
29707 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
29708 & 2D0*TH/SH+TH2/SH2)*FACA
29709 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
29710 & 2D0*SH/UH+SH2/UH2)*FACA
29711 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
29712 & 2D0*UH/TH+UH2/TH2)
29713 NCHN=NCHN+1
29714 ISIG(NCHN,1)=21
29715 ISIG(NCHN,2)=21
29716 ISIG(NCHN,3)=681
29717 SIGH(NCHN)=0.5D0*FACGG1
29718 NCHN=NCHN+1
29719 ISIG(NCHN,1)=21
29720 ISIG(NCHN,2)=21
29721 ISIG(NCHN,3)=682
29722 SIGH(NCHN)=0.5D0*FACGG2
29723 NCHN=NCHN+1
29724 ISIG(NCHN,1)=21
29725 ISIG(NCHN,2)=21
29726 ISIG(NCHN,3)=683
29727 SIGH(NCHN)=0.5D0*FACGG3
29728
29729 ELSEIF(ISUB.EQ.99) THEN
29730C...f + gamma* -> f.
29731 IF(MINT(107).EQ.4) THEN
29732 Q2GA=VINT(307)
29733 P2GA=VINT(308)
29734 ISDE=2
29735 ELSE
29736 Q2GA=VINT(308)
29737 P2GA=VINT(307)
29738 ISDE=1
29739 ENDIF
29740 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
29741 PM2RHO=PMAS(PYCOMP(113),1)**2
29742 IF(MSTP(19).EQ.0) THEN
29743 COMFAC=COMFAC/Q2GA
29744 ELSEIF(MSTP(19).EQ.1) THEN
29745 COMFAC=COMFAC/(Q2GA+PM2RHO)
29746 ELSEIF(MSTP(19).EQ.2) THEN
29747 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29748 ELSE
29749 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
29750 W2GA=VINT(2)
29751 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
29752 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
29753 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
29754 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
29755 ELSE
29756 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
29757 & Q2GA**0.57D0)
29758 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
29759 ENDIF
29760 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
29761 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
29762 ENDIF
29763 DO 390 I=MMINA,MMAXA
29764 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
29765 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
29766 EI=KCHG(IABS(I),1)/3D0
29767 NCHN=NCHN+1
29768 ISIG(NCHN,ISDE)=I
29769 ISIG(NCHN,3-ISDE)=22
29770 ISIG(NCHN,3)=1
29771 SIGH(NCHN)=COMFAC*EI**2
29772 390 CONTINUE
29773 ENDIF
29774
29775 ELSE
29776 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
29777C...g + g -> gamma + gamma or g + g -> g + gamma
29778 A0STUR=0D0
29779 A0STUI=0D0
29780 A0TSUR=0D0
29781 A0TSUI=0D0
29782 A0UTSR=0D0
29783 A0UTSI=0D0
29784 A1STUR=0D0
29785 A1STUI=0D0
29786 A2STUR=0D0
29787 A2STUI=0D0
29788 ALST=LOG(-SH/TH)
29789 ALSU=LOG(-SH/UH)
29790 ALTU=LOG(TH/UH)
29791 IMAX=2*MSTP(1)
29792 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
29793 DO 400 I=1,IMAX
29794 EI=KCHG(IABS(I),1)/3D0
29795 EIWT=EI**2
29796 IF(ISUB.EQ.115) EIWT=EI
29797 SQMQ=PMAS(I,1)**2
29798 EPSS=4D0*SQMQ/SH
29799 EPST=4D0*SQMQ/TH
29800 EPSU=4D0*SQMQ/UH
29801 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
29802 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
29803 & PARU(1)**2)
29804 B0STUI=0D0
29805 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
29806 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
29807 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
29808 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
29809 B1STUR=-1D0
29810 B1STUI=0D0
29811 B2STUR=-1D0
29812 B2STUI=0D0
29813 ELSE
29814 CALL PYWAUX(1,EPSS,W1SR,W1SI)
29815 CALL PYWAUX(1,EPST,W1TR,W1TI)
29816 CALL PYWAUX(1,EPSU,W1UR,W1UI)
29817 CALL PYWAUX(2,EPSS,W2SR,W2SI)
29818 CALL PYWAUX(2,EPST,W2TR,W2TI)
29819 CALL PYWAUX(2,EPSU,W2UR,W2UI)
29820 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
29821 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
29822 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
29823 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
29824 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
29825 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
29826 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
29827 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
29828 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
29829 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
29830 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29831 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29832 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
29833 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
29834 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
29835 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
29836 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
29837 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29838 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
29839 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
29840 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
29841 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
29842 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29843 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
29844 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
29845 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
29846 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
29847 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
29848 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
29849 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
29850 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
29851 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
29852 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
29853 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
29854 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29855 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
29856 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
29857 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
29858 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
29859 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
29860 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
29861 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
29862 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
29863 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
29864 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
29865 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
29866 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
29867 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
29868 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
29869 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
29870 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
29871 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
29872 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
29873 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
29874 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
29875 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
29876 ENDIF
29877 A0STUR=A0STUR+EIWT*B0STUR
29878 A0STUI=A0STUI+EIWT*B0STUI
29879 A0TSUR=A0TSUR+EIWT*B0TSUR
29880 A0TSUI=A0TSUI+EIWT*B0TSUI
29881 A0UTSR=A0UTSR+EIWT*B0UTSR
29882 A0UTSI=A0UTSI+EIWT*B0UTSI
29883 A1STUR=A1STUR+EIWT*B1STUR
29884 A1STUI=A1STUI+EIWT*B1STUI
29885 A2STUR=A2STUR+EIWT*B2STUR
29886 A2STUI=A2STUI+EIWT*B2STUI
29887 400 CONTINUE
29888 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
29889 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
29890 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
29891 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
29892 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
29893 NCHN=NCHN+1
29894 ISIG(NCHN,1)=21
29895 ISIG(NCHN,2)=21
29896 ISIG(NCHN,3)=1
29897 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
29898 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
29899 410 CONTINUE
29900
29901 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
29902C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
29903 PH=0D0
29904 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29905 & PH=VINT(3)**2
29906 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29907 & PH=VINT(4)**2
29908 IF(ISUB.EQ.131) THEN
29909 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
29910 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29911 ELSE
29912 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29913 ENDIF
29914 DO 430 I=MMINA,MMAXA
29915 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
29916 EI=KCHG(IABS(I),1)/3D0
29917 FACGQ=FGQ*EI**2
29918 DO 420 ISDE=1,2
29919 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
29920 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
29921 NCHN=NCHN+1
29922 ISIG(NCHN,ISDE)=I
29923 ISIG(NCHN,3-ISDE)=22
29924 ISIG(NCHN,3)=1
29925 SIGH(NCHN)=FACGQ
29926 420 CONTINUE
29927 430 CONTINUE
29928
29929 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
29930C...f + gamma*_(T,L) -> f + gamma
29931 PH=0D0
29932 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29933 & PH=VINT(3)**2
29934 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29935 & PH=VINT(4)**2
29936 IF(ISUB.EQ.133) THEN
29937 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
29938 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
29939 ELSE
29940 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
29941 ENDIF
29942 DO 450 I=MMINA,MMAXA
29943 IF(I.EQ.0) GOTO 450
29944 EI=KCHG(IABS(I),1)/3D0
29945 FACGQ=FGQ*EI**4
29946 DO 440 ISDE=1,2
29947 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
29948 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
29949 NCHN=NCHN+1
29950 ISIG(NCHN,ISDE)=I
29951 ISIG(NCHN,3-ISDE)=22
29952 ISIG(NCHN,3)=1
29953 SIGH(NCHN)=FACGQ
29954 440 CONTINUE
29955 450 CONTINUE
29956
29957 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
29958C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
29959 PH=0D0
29960 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
29961 & PH=VINT(3)**2
29962 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
29963 & PH=VINT(4)**2
29964 CALL PYWIDT(21,SH,WDTP,WDTE)
29965 WDTESU=0D0
29966 DO 460 I=1,MIN(8,MDCY(21,3))
29967 EF=KCHG(I,1)/3D0
29968 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
29969 & WDTE(I,4))
29970 460 CONTINUE
29971 IF(ISUB.EQ.135) THEN
29972 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
29973 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
29974 ELSE
29975 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
29976 ENDIF
29977 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
29978 NCHN=NCHN+1
29979 ISIG(NCHN,1)=21
29980 ISIG(NCHN,2)=22
29981 ISIG(NCHN,3)=1
29982 SIGH(NCHN)=FACQQ
29983 ENDIF
29984 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
29985 NCHN=NCHN+1
29986 ISIG(NCHN,1)=22
29987 ISIG(NCHN,2)=21
29988 ISIG(NCHN,3)=1
29989 SIGH(NCHN)=FACQQ
29990 ENDIF
29991
29992 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
29993C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
29994 PH1=0D0
29995 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
29996 PH2=0D0
29997 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
29998 CALL PYWIDT(22,SH,WDTP,WDTE)
29999 WDTESU=0D0
30000 DO 470 I=1,MIN(12,MDCY(22,3))
30001 IF(I.LE.8) EF= KCHG(I,1)/3D0
30002 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30003 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30004 & WDTE(I,4))
30005 470 CONTINUE
30006 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30007 IF(ISUB.EQ.137) THEN
30008 FPARAM=-SH*(TH+UH)/DLAMB2
30009 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30010 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30011 & 2D0*PH1*PH2*FPARAM**2)
30012 ELSEIF(ISUB.EQ.138) THEN
30013 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30014 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30015 & 2D0*PH1**2*(TH-UH)**2)
30016 ELSEIF(ISUB.EQ.139) THEN
30017 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30018 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30019 & 2D0*PH2**2*(TH-UH)**2)
30020 ELSE
30021 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30022 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30023 ENDIF
30024 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30025 NCHN=NCHN+1
30026 ISIG(NCHN,1)=22
30027 ISIG(NCHN,2)=22
30028 ISIG(NCHN,3)=1
30029 SIGH(NCHN)=FACFF
30030 ENDIF
30031
30032 ENDIF
30033 ENDIF
30034
30035 RETURN
30036 END
30037
30038C*********************************************************************
30039
30040C...PYSGHF
30041C...Subprocess cross sections for heavy flavour production,
30042C...open and closed.
30043C...Auxiliary to PYSIGH.
30044
30045 SUBROUTINE PYSGHF(NCHN,SIGS)
30046
30047C...Double precision and integer declarations
30048 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30049 IMPLICIT INTEGER(I-N)
30050 INTEGER PYK,PYCHGE,PYCOMP
30051C...Parameter statement to help give large particle numbers.
30052 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30053 &KEXCIT=4000000,KDIMEN=5000000)
30054C...Commonblocks
30055 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30056 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30057 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30058 COMMON/PYINT1/MINT(400),VINT(400)
30059 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30060 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30061 COMMON/PYINT4/MWID(500),WIDS(500,5)
30062 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30063 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30064 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30065 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30066 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30067 &/PYINT4/,/PYSGCM/
30068C...Local arrays
30069 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30070
30071C...Determine where are charmonium/bottomonium wave function parameters.
30072 IONIUM=140
30073 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30074
30075C...Convert bottomonium process into equivalent charmonium ones.
30076 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30077
30078C...Differential cross section expressions.
30079
30080 IF(ISUB.LE.100) THEN
30081 IF(ISUB.EQ.81) THEN
30082C...q + qbar -> Q + Qbar
30083 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30084 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30085 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30086 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30087 & 2D0*SQMAVG/SH)
30088 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30089 WID2=1D0
30090 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30091 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30092 FACQQB=FACQQB*WID2
30093 DO 100 I=MMINA,MMAXA
30094 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30095 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30096 NCHN=NCHN+1
30097 ISIG(NCHN,1)=I
30098 ISIG(NCHN,2)=-I
30099 ISIG(NCHN,3)=1
30100 SIGH(NCHN)=FACQQB
30101 100 CONTINUE
30102
30103 ELSEIF(ISUB.EQ.82) THEN
30104C...g + g -> Q + Qbar
30105 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30106 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30107 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30108 THUHQ=THQ*UHQ-SQMAVG*SH
30109 IF(MSTP(34).EQ.0) THEN
30110 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30111 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30112 ELSE
30113 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30114 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30115 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30116 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30117 ENDIF
30118 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30119 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30120 IF(MSTP(35).GE.1) THEN
30121 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30122 FACQQ1=FACQQ1*FATRE
30123 FACQQ2=FACQQ2*FATRE
30124 ENDIF
30125 WID2=1D0
30126 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30127 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30128 FACQQ1=FACQQ1*WID2
30129 FACQQ2=FACQQ2*WID2
30130 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30131 NCHN=NCHN+1
30132 ISIG(NCHN,1)=21
30133 ISIG(NCHN,2)=21
30134 ISIG(NCHN,3)=1
30135 SIGH(NCHN)=FACQQ1
30136 NCHN=NCHN+1
30137 ISIG(NCHN,1)=21
30138 ISIG(NCHN,2)=21
30139 ISIG(NCHN,3)=2
30140 SIGH(NCHN)=FACQQ2
30141 110 CONTINUE
30142
30143 ELSEIF(ISUB.EQ.83) THEN
30144C...f + q -> f' + Q
30145 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
30146 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
30147 DO 130 I=MMIN1,MMAX1
30148 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
30149 DO 120 J=MMIN2,MMAX2
30150 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
30151 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
30152 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
30153 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
30154 & THEN
30155 NCHN=NCHN+1
30156 ISIG(NCHN,1)=I
30157 ISIG(NCHN,2)=J
30158 ISIG(NCHN,3)=1
30159 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30160 & (IABS(I)+1)/2)*VINT(180+J)
30161 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
30162 & (MINT(55)+1)/2)*VINT(180+J)
30163 WID2=1D0
30164 IF(I.GT.0) THEN
30165 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30166 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30167 & WIDS(MINT(55),2)
30168 ELSE
30169 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30170 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30171 & WIDS(MINT(55),3)
30172 ENDIF
30173 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30174 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30175 ENDIF
30176 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
30177 & THEN
30178 NCHN=NCHN+1
30179 ISIG(NCHN,1)=I
30180 ISIG(NCHN,2)=J
30181 ISIG(NCHN,3)=2
30182 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
30183 & (IABS(J)+1)/2)*VINT(180+I)
30184 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
30185 & (MINT(55)+1)/2)*VINT(180+I)
30186 IF(J.GT.0) THEN
30187 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
30188 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30189 & WIDS(MINT(55),2)
30190 ELSE
30191 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
30192 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
30193 & WIDS(MINT(55),3)
30194 ENDIF
30195 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
30196 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
30197 ENDIF
30198 120 CONTINUE
30199 130 CONTINUE
30200
30201 ELSEIF(ISUB.EQ.84) THEN
30202C...g + gamma -> Q + Qbar
30203 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30204 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30205 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30206 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
30207 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
30208 & (THQ*UHQ)
30209 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
30210 WID2=1D0
30211 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30212 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30213 FACQQ=FACQQ*WID2
30214 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30215 NCHN=NCHN+1
30216 ISIG(NCHN,1)=21
30217 ISIG(NCHN,2)=22
30218 ISIG(NCHN,3)=1
30219 SIGH(NCHN)=FACQQ
30220 ENDIF
30221 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30222 NCHN=NCHN+1
30223 ISIG(NCHN,1)=22
30224 ISIG(NCHN,2)=21
30225 ISIG(NCHN,3)=1
30226 SIGH(NCHN)=FACQQ
30227 ENDIF
30228
30229 ELSEIF(ISUB.EQ.85) THEN
30230C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
30231 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30232 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30233 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30234 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
30235 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
30236 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
30237 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
30238 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
30239 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
30240 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
30241 WID2=1D0
30242 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
30243 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
30244 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
30245 FACFF=FACFF*WID2
30246 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30247 NCHN=NCHN+1
30248 ISIG(NCHN,1)=22
30249 ISIG(NCHN,2)=22
30250 ISIG(NCHN,3)=1
30251 SIGH(NCHN)=FACFF
30252 ENDIF
30253
30254 ELSEIF(ISUB.EQ.86) THEN
30255C...g + g -> J/Psi + g
30256 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
30257 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30258 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30259 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30260 NCHN=NCHN+1
30261 ISIG(NCHN,1)=21
30262 ISIG(NCHN,2)=21
30263 ISIG(NCHN,3)=1
30264 SIGH(NCHN)=FACQQG
30265 ENDIF
30266
30267 ELSEIF(ISUB.EQ.87) THEN
30268C...g + g -> chi_0c + g
30269 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30270 QGTW=(SH*TH*UH)/SH**3
30271 RGTW=SQM3/SH
30272 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30273 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30274 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
30275 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
30276 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
30277 & (QGTW*(QGTW-RGTW*PGTW)**4)
30278 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30279 NCHN=NCHN+1
30280 ISIG(NCHN,1)=21
30281 ISIG(NCHN,2)=21
30282 ISIG(NCHN,3)=1
30283 SIGH(NCHN)=FACQQG
30284 ENDIF
30285
30286 ELSEIF(ISUB.EQ.88) THEN
30287C...g + g -> chi_1c + g
30288 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30289 QGTW=(SH*TH*UH)/SH**3
30290 RGTW=SQM3/SH
30291 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30292 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
30293 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
30294 & (QGTW-RGTW*PGTW)**4
30295 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30296 NCHN=NCHN+1
30297 ISIG(NCHN,1)=21
30298 ISIG(NCHN,2)=21
30299 ISIG(NCHN,3)=1
30300 SIGH(NCHN)=FACQQG
30301 ENDIF
30302
30303 ELSEIF(ISUB.EQ.89) THEN
30304C...g + g -> chi_2c + g
30305 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
30306 QGTW=(SH*TH*UH)/SH**3
30307 RGTW=SQM3/SH
30308 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
30309 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
30310 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
30311 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
30312 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
30313 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
30314 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30315 NCHN=NCHN+1
30316 ISIG(NCHN,1)=21
30317 ISIG(NCHN,2)=21
30318 ISIG(NCHN,3)=1
30319 SIGH(NCHN)=FACQQG
30320 ENDIF
30321 ENDIF
30322
30323 ELSEIF(ISUB.LE.200) THEN
30324 IF(ISUB.EQ.104) THEN
30325C...g + g -> chi_c0.
30326 KC=PYCOMP(10441)
30327 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
30328 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30329 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30330 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30331 NCHN=NCHN+1
30332 ISIG(NCHN,1)=21
30333 ISIG(NCHN,2)=21
30334 ISIG(NCHN,3)=1
30335 SIGH(NCHN)=FACBW
30336 ENDIF
30337
30338 ELSEIF(ISUB.EQ.105) THEN
30339C...g + g -> chi_c2.
30340 KC=PYCOMP(445)
30341 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
30342 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
30343 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
30344 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30345 NCHN=NCHN+1
30346 ISIG(NCHN,1)=21
30347 ISIG(NCHN,2)=21
30348 ISIG(NCHN,3)=1
30349 SIGH(NCHN)=FACBW
30350 ENDIF
30351
30352 ELSEIF(ISUB.EQ.106) THEN
30353C...g + g -> J/Psi + gamma.
30354 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30355 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
30356 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30357 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30358 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30359 NCHN=NCHN+1
30360 ISIG(NCHN,1)=21
30361 ISIG(NCHN,2)=21
30362 ISIG(NCHN,3)=1
30363 SIGH(NCHN)=FACQQG
30364 ENDIF
30365
30366 ELSEIF(ISUB.EQ.107) THEN
30367C...g + gamma -> J/Psi + g.
30368 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30369 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
30370 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30371 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30372 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30373 NCHN=NCHN+1
30374 ISIG(NCHN,1)=21
30375 ISIG(NCHN,2)=22
30376 ISIG(NCHN,3)=1
30377 SIGH(NCHN)=FACQQG
30378 ENDIF
30379 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30380 NCHN=NCHN+1
30381 ISIG(NCHN,1)=22
30382 ISIG(NCHN,2)=21
30383 ISIG(NCHN,3)=1
30384 SIGH(NCHN)=FACQQG
30385 ENDIF
30386
30387 ELSEIF(ISUB.EQ.108) THEN
30388C...gamma + gamma -> J/Psi + gamma.
30389 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
30390 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
30391 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
30392 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
30393 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30394 NCHN=NCHN+1
30395 ISIG(NCHN,1)=22
30396 ISIG(NCHN,2)=22
30397 ISIG(NCHN,3)=1
30398 SIGH(NCHN)=FACQQG
30399 ENDIF
30400 ENDIF
30401
30402C...QUARKONIA+++
30403C...Additional code by Stefan Wolf
30404 ELSE
30405
30406C...Common code for quarkonium production.
30407 SHTH=SH+TH
30408 THUH=TH+UH
30409 UHSH=UH+SH
30410 SHTH2=SHTH**2
30411 THUH2=THUH**2
30412 UHSH2=UHSH**2
30413 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
30414 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
30415 SQMQQ=SQM3
30416 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
30417 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
30418 SQMQQ=SQM4
30419 ENDIF
30420 SQMQQR=SQRT(SQMQQ)
30421 IF(MSTP(145).EQ.1) THEN
30422 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
30423 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
30424 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
30425 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
30426 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30427 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30428 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30429 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30430 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
30431 & ISUB.GE.437) THEN
30432 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
30433 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
30434 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
30435 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
30436 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
30437 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
30438 ENDIF
30439 AQ2=AQ**2
30440 BQ2=BQ**2
30441 SMQQ2=SQMQQ*VINT(2)
30442C...Polarisation frames
30443 IF(MSTP(146).EQ.1) THEN
30444C...Recoil frame
30445 POLH1=SQRT(AQ2-SMQQ2)
30446 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30447 AZ=-SQMQQR/POLH1
30448 BZ=0D0
30449 AX=AQ*BQ/(POLH1*POLH2)
30450 BX=-POLH1/POLH2
30451 ELSEIF(MSTP(146).EQ.2) THEN
30452C...Gottfried Jackson frame
30453 POLH1=AQ+BQ
30454 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30455 AZ=SQMQQR/POLH1
30456 BZ=AZ
30457 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
30458 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
30459 ELSEIF(MSTP(146).EQ.3) THEN
30460C...Target frame
30461 POLH1=AQ-BQ
30462 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
30463 AZ=-SQMQQR/POLH1
30464 BZ=-AZ
30465 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
30466 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
30467 ELSEIF(MSTP(146).EQ.4) THEN
30468C...Collins Soper frame
30469 POLH1=AQ2-BQ2
30470 POLH2=SQRT(VINT(2)*POLH1)
30471 AZ=-BQ/POLH2
30472 BZ=AQ/POLH2
30473 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
30474 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
30475 ENDIF
30476C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
30477 EL1K10=AZ*ATILK1+BZ*BTILK1
30478 EL1K20=AZ*ATILK2+BZ*BTILK2
30479 EL2K10=EL1K10
30480 EL2K20=EL1K20
30481 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
30482 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
30483 EL2K11=EL1K11
30484 EL2K21=EL1K21
30485 ENDIF
30486
30487 IF(ISUB.EQ.421) THEN
30488C...g + g -> QQ~[3S11] + g
30489 IF(MSTP(145).EQ.0) THEN
30490* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30491* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
30492 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30493 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
30494* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
30495* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
30496 ELSE
30497 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
30498 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30499 BB=2D0*(SH2+TH2)
30500 CC=2D0*(SH2+UH2)
30501 DD=2D0*SH2
30502 IF(MSTP(147).EQ.0) THEN
30503 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30504 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30505 ELSEIF(MSTP(147).EQ.1) THEN
30506 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30507 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30508 ELSEIF(MSTP(147).EQ.3) THEN
30509 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30510 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30511 ELSEIF(MSTP(147).EQ.4) THEN
30512 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30513 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30514 ELSEIF(MSTP(147).EQ.5) THEN
30515 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30516 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30517 ELSEIF(MSTP(147).EQ.6) THEN
30518 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30519 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30520 ENDIF
30521 FACQQG=COMFAC*FF*FACQQG
30522 ENDIF
30523 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30524 NCHN=NCHN+1
30525 ISIG(NCHN,1)=21
30526 ISIG(NCHN,2)=21
30527 ISIG(NCHN,3)=1
30528 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
30529 ENDIF
30530
30531 ELSEIF(ISUB.EQ.422) THEN
30532C...g + g -> QQ~[3S18] + g
30533 IF(MSTP(145).EQ.0) THEN
30534 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
30535 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30536 & (SQMQQ*SQMQQR)*
30537 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
30538 ELSE
30539 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
30540 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
30541 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
30542 BB=2D0*(SH2+TH2)
30543 CC=2D0*(SH2+UH2)
30544 DD=2D0*SH2
30545 IF(MSTP(147).EQ.0) THEN
30546 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30547 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30548 ELSEIF(MSTP(147).EQ.1) THEN
30549 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30550 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30551 ELSEIF(MSTP(147).EQ.3) THEN
30552 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30553 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30554 ELSEIF(MSTP(147).EQ.4) THEN
30555 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30556 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30557 ELSEIF(MSTP(147).EQ.5) THEN
30558 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30559 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30560 ELSEIF(MSTP(147).EQ.6) THEN
30561 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30562 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30563 ENDIF
30564 FACQQG=COMFAC*FF*FACQQG
30565 ENDIF
30566C...Split total contribution into different colour flows just like
30567C...in g g -> g g (recalculate kinematics for massless partons).
30568 THP=-0.5D0*SH*(1D0-CTH)
30569 UHP=-0.5D0*SH*(1D0+CTH)
30570 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30571 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30572 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30573 FACGGS=FACGG1+FACGG2+FACGG3
30574 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30575 NCHN=NCHN+1
30576 ISIG(NCHN,1)=21
30577 ISIG(NCHN,2)=21
30578 ISIG(NCHN,3)=1
30579 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
30580 NCHN=NCHN+1
30581 ISIG(NCHN,1)=21
30582 ISIG(NCHN,2)=21
30583 ISIG(NCHN,3)=2
30584 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
30585 NCHN=NCHN+1
30586 ISIG(NCHN,1)=21
30587 ISIG(NCHN,2)=21
30588 ISIG(NCHN,3)=3
30589 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
30590 ENDIF
30591
30592 ELSEIF(ISUB.EQ.423) THEN
30593C...g + g -> QQ~[1S08] + g
30594 IF(MSTP(145).EQ.0) THEN
30595* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
30596* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
30597* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
30598* & (SHTH2*THUH2*UHSH2)
30599 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
30600 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30601 & TH2/(SHTH2*THUH2))*
30602 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30603 ELSE
30604 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
30605 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
30606 & TH2/(SHTH2*THUH2))*
30607 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
30608 IF(MSTP(147).EQ.0) THEN
30609 FACQQG=COMFAC*FA
30610 ELSEIF(MSTP(147).EQ.1) THEN
30611 FACQQG=COMFAC*2D0*FA
30612 ELSEIF(MSTP(147).EQ.3) THEN
30613 FACQQG=COMFAC*FA
30614 ELSEIF(MSTP(147).EQ.4) THEN
30615 FACQQG=COMFAC*FA
30616 ELSEIF(MSTP(147).EQ.5) THEN
30617 FACQQG=0D0
30618 ELSEIF(MSTP(147).EQ.6) THEN
30619 FACQQG=0D0
30620 ENDIF
30621 ENDIF
30622C...Split total contribution into different colour flows just like
30623C...in g g -> g g (recalculate kinematics for massless partons).
30624 THP=-0.5D0*SH*(1D0-CTH)
30625 UHP=-0.5D0*SH*(1D0+CTH)
30626 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30627 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30628 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30629 FACGGS=FACGG1+FACGG2+FACGG3
30630 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30631 NCHN=NCHN+1
30632 ISIG(NCHN,1)=21
30633 ISIG(NCHN,2)=21
30634 ISIG(NCHN,3)=1
30635 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
30636 NCHN=NCHN+1
30637 ISIG(NCHN,1)=21
30638 ISIG(NCHN,2)=21
30639 ISIG(NCHN,3)=2
30640 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
30641 NCHN=NCHN+1
30642 ISIG(NCHN,1)=21
30643 ISIG(NCHN,2)=21
30644 ISIG(NCHN,3)=3
30645 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
30646 ENDIF
30647
30648 ELSEIF(ISUB.EQ.424) THEN
30649C...g + g -> QQ~[3PJ8] + g
30650 POLY=SH2+SH*TH+TH2
30651 IF(MSTP(145).EQ.0) THEN
30652 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
30653 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
30654 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
30655 & +7D0*TH**6)
30656 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
30657 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
30658 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
30659 & +35D0*TH**8)
30660 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
30661 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
30662 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
30663 & +84D0*TH**8)
30664 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
30665 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
30666 & +451D0*SH*TH**5+126D0*TH**6)
30667 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
30668 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
30669 & +171D0*SH*TH**5+42D0*TH**6)
30670 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
30671 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
30672 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
30673 & +99D0*SH*TH**3+35D0*TH**4)
30674 & +7D0*SQMQQ**8*SHTH*POLY)/
30675 & (SH*TH*UH*SQMQQR*SQMQQ*
30676 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30677 ELSE
30678 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
30679 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
30680 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
30681 & -SQMQQ*SHTH2*POLY**2*
30682 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
30683 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
30684 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
30685 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
30686 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
30687 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
30688 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
30689 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
30690 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
30691 & +145D0*SH*TH**5+34D0*TH**6)
30692 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
30693 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
30694 & +44D0*TH**6)
30695 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
30696 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
30697 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
30698 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
30699 & +3D0*SQMQQ**8*SHTH*POLY)
30700 BB=4D0*SHTH2*POLY**3
30701 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
30702 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
30703 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
30704 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
30705 & +84D0*SH*TH**9+20D0*TH**10)
30706 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
30707 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
30708 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
30709 & +40D0*TH**8)
30710 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
30711 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
30712 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
30713 & +40D0*TH**8)
30714 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
30715 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
30716 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
30717 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
30718 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
30719 & +4D0*TH**6)
30720 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
30721 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
30722 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
30723 CC=4D0*TH2*POLY**3
30724 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
30725 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
30726 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
30727 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
30728 & +28D0*TH**9)
30729 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
30730 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
30731 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
30732 & +394D0*SH*TH**9+84D0*TH**10)
30733 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
30734 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
30735 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
30736 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
30737 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
30738 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
30739 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
30740 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
30741 & +266D0*SH*TH**6+84D0*TH**7)
30742 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
30743 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
30744 & +28D0*TH**6)
30745 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
30746 & +7D0*SH*TH**3+4*TH**4)
30747 & +SQMQQ**8*SH*(SH-TH)**2*TH
30748 DD=2D0*TH2*SHTH2*POLY**3
30749 & *(-SH2+2*SH*TH+2*TH2)
30750 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
30751 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
30752 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
30753 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
30754 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
30755 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
30756 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
30757 & -210D0*SH*TH**8-60D0*TH**9)
30758 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
30759 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
30760 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
30761 & -80D0*TH**8)
30762 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
30763 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
30764 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
30765 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
30766 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
30767 & -30D0*SH*TH**6-24D0*TH**7)
30768 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
30769 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
30770 & -4D0*TH**6)
30771 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
30772 IF(MSTP(147).EQ.0) THEN
30773 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30774 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30775 ELSEIF(MSTP(147).EQ.1) THEN
30776 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30777 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30778 ELSEIF(MSTP(147).EQ.3) THEN
30779 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30780 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30781 ELSEIF(MSTP(147).EQ.4) THEN
30782 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30783 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30784 ELSEIF(MSTP(147).EQ.5) THEN
30785 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30786 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30787 ELSEIF(MSTP(147).EQ.6) THEN
30788 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30789 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30790 ENDIF
30791 FACQQG=COMFAC*FF*FACQQG
30792 ENDIF
30793C...Split total contribution into different colour flows just like
30794C...in g g -> g g (recalculate kinematics for massless partons).
30795 THP=-0.5D0*SH*(1D0-CTH)
30796 UHP=-0.5D0*SH*(1D0+CTH)
30797 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
30798 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
30799 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
30800 FACGGS=FACGG1+FACGG2+FACGG3
30801 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
30802 NCHN=NCHN+1
30803 ISIG(NCHN,1)=21
30804 ISIG(NCHN,2)=21
30805 ISIG(NCHN,3)=1
30806 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
30807 NCHN=NCHN+1
30808 ISIG(NCHN,1)=21
30809 ISIG(NCHN,2)=21
30810 ISIG(NCHN,3)=2
30811 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
30812 NCHN=NCHN+1
30813 ISIG(NCHN,1)=21
30814 ISIG(NCHN,2)=21
30815 ISIG(NCHN,3)=3
30816 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
30817 ENDIF
30818
30819 ELSEIF(ISUB.EQ.425) THEN
30820C...q + g -> q + QQ~[3S18]
30821 IF(MSTP(145).EQ.0) THEN
30822 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
30823 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
30824 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
30825 ELSE
30826 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
30827 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
30828 AA=SHTH2+THUH2
30829 BB=4D0
30830 CC=8D0
30831 DD=4D0
30832 IF(MSTP(147).EQ.0) THEN
30833 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30834 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30835 ELSEIF(MSTP(147).EQ.1) THEN
30836 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30837 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30838 ELSEIF(MSTP(147).EQ.3) THEN
30839 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30840 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30841 ELSEIF(MSTP(147).EQ.4) THEN
30842 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30843 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30844 ELSEIF(MSTP(147).EQ.5) THEN
30845 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30846 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30847 ELSEIF(MSTP(147).EQ.6) THEN
30848 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30849 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30850 ENDIF
30851 FACQQG=COMFAC*FF*FACQQG
30852 ENDIF
30853C...Split total contribution into different colour flows just like
30854C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30855C...(recalculate kinematics for massless partons).
30856 THP=-0.5D0*SH*(1D0-CTH)
30857 UHP=-0.5D0*SH*(1D0+CTH)
30858 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30859 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30860 FACQGS=FACQG1+FACQG2
30861 DO 2442 I=MMINA,MMAXA
30862 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
30863 DO 2441 ISDE=1,2
30864 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
30865 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
30866 NCHN=NCHN+1
30867 ISIG(NCHN,ISDE)=I
30868 ISIG(NCHN,3-ISDE)=21
30869 ISIG(NCHN,3)=1
30870 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
30871 NCHN=NCHN+1
30872 ISIG(NCHN,ISDE)=I
30873 ISIG(NCHN,3-ISDE)=21
30874 ISIG(NCHN,3)=2
30875 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
30876 2441 CONTINUE
30877 2442 CONTINUE
30878
30879 ELSEIF(ISUB.EQ.426) THEN
30880C...q + g -> q + QQ~[1S08]
30881 IF(MSTP(145).EQ.0) THEN
30882 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
30883 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
30884 ELSE
30885 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
30886 IF(MSTP(147).EQ.0) THEN
30887 FACQQG=COMFAC*FA
30888 ELSEIF(MSTP(147).EQ.1) THEN
30889 FACQQG=COMFAC*2D0*FA
30890 ELSEIF(MSTP(147).EQ.3) THEN
30891 FACQQG=COMFAC*FA
30892 ELSEIF(MSTP(147).EQ.4) THEN
30893 FACQQG=COMFAC*FA
30894 ELSEIF(MSTP(147).EQ.5) THEN
30895 FACQQG=0D0
30896 ELSEIF(MSTP(147).EQ.6) THEN
30897 FACQQG=0D0
30898 ENDIF
30899 ENDIF
30900C...Split total contribution into different colour flows just like
30901C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30902C...(recalculate kinematics for massless partons).
30903 THP=-0.5D0*SH*(1D0-CTH)
30904 UHP=-0.5D0*SH*(1D0+CTH)
30905 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30906 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30907 FACQGS=FACQG1+FACQG2
30908 DO 2444 I=MMINA,MMAXA
30909 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
30910 DO 2443 ISDE=1,2
30911 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
30912 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
30913 NCHN=NCHN+1
30914 ISIG(NCHN,ISDE)=I
30915 ISIG(NCHN,3-ISDE)=21
30916 ISIG(NCHN,3)=1
30917 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
30918 NCHN=NCHN+1
30919 ISIG(NCHN,ISDE)=I
30920 ISIG(NCHN,3-ISDE)=21
30921 ISIG(NCHN,3)=2
30922 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
30923 2443 CONTINUE
30924 2444 CONTINUE
30925
30926 ELSEIF(ISUB.EQ.427) THEN
30927C...q + g -> q + QQ~[3PJ8]
30928 IF(MSTP(145).EQ.0) THEN
30929 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
30930 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
30931 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
30932 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
30933 ELSE
30934 FF=10D0*PARU(1)*AS**3/
30935 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
30936 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
30937 BB=8D0*(SHTH2+TH*UH)
30938 CC=8D0*UHSH*(SHTH+THUH)
30939 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
30940 IF(MSTP(147).EQ.0) THEN
30941 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30942 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30943 ELSEIF(MSTP(147).EQ.1) THEN
30944 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30945 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
30946 ELSEIF(MSTP(147).EQ.3) THEN
30947 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
30948 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
30949 ELSEIF(MSTP(147).EQ.4) THEN
30950 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30951 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30952 ELSEIF(MSTP(147).EQ.5) THEN
30953 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
30954 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
30955 ELSEIF(MSTP(147).EQ.6) THEN
30956 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
30957 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
30958 ENDIF
30959 FACQQG=COMFAC*FF*FACQQG
30960 ENDIF
30961C...Split total contribution into different colour flows just like
30962C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
30963C...(recalculate kinematics for massless partons).
30964 THP=-0.5D0*SH*(1D0-CTH)
30965 UHP=-0.5D0*SH*(1D0+CTH)
30966 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
30967 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
30968 FACQGS=FACQG1+FACQG2
30969 DO 2446 I=MMINA,MMAXA
30970 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
30971 DO 2445 ISDE=1,2
30972 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
30973 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
30974 NCHN=NCHN+1
30975 ISIG(NCHN,ISDE)=I
30976 ISIG(NCHN,3-ISDE)=21
30977 ISIG(NCHN,3)=1
30978 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
30979 NCHN=NCHN+1
30980 ISIG(NCHN,ISDE)=I
30981 ISIG(NCHN,3-ISDE)=21
30982 ISIG(NCHN,3)=2
30983 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
30984 2445 CONTINUE
30985 2446 CONTINUE
30986
30987 ELSEIF(ISUB.EQ.428) THEN
30988C...q + q~ -> g + QQ~[3S18]
30989 IF(MSTP(145).EQ.0) THEN
30990 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
30991 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
30992 & (SQMQQ*SQMQQR*TH*UH*THUH2)
30993 ELSE
30994 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
30995 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
30996 AA=SHTH2+UHSH2
30997 BB=4D0
30998 CC=4D0
30999 DD=0D0
31000 IF(MSTP(147).EQ.0) THEN
31001 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31002 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31003 ELSEIF(MSTP(147).EQ.1) THEN
31004 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31005 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31006 ELSEIF(MSTP(147).EQ.3) THEN
31007 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31008 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31009 ELSEIF(MSTP(147).EQ.4) THEN
31010 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31011 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31012 ELSEIF(MSTP(147).EQ.5) THEN
31013 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31014 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31015 ELSEIF(MSTP(147).EQ.6) THEN
31016 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31017 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31018 ENDIF
31019 FACQQG=COMFAC*FF*FACQQG
31020 ENDIF
31021C...Split total contribution into different colour flows just like
31022C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31023C...(recalculate kinematics for massless partons).
31024 THP=-0.5D0*SH*(1D0-CTH)
31025 UHP=-0.5D0*SH*(1D0+CTH)
31026 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31027 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31028 FACGGS=FACGG1+FACGG2
31029 DO 2447 I=MMINA,MMAXA
31030 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31031 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31032 NCHN=NCHN+1
31033 ISIG(NCHN,1)=I
31034 ISIG(NCHN,2)=-I
31035 ISIG(NCHN,3)=1
31036 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31037 NCHN=NCHN+1
31038 ISIG(NCHN,1)=I
31039 ISIG(NCHN,2)=-I
31040 ISIG(NCHN,3)=2
31041 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31042 2447 CONTINUE
31043
31044 ELSEIF(ISUB.EQ.429) THEN
31045C...q + q~ -> g + QQ~[1S08]
31046 IF(MSTP(145).EQ.0) THEN
31047 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31048 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31049 ELSE
31050 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31051 IF(MSTP(147).EQ.0) THEN
31052 FACQQG=COMFAC*FA
31053 ELSEIF(MSTP(147).EQ.1) THEN
31054 FACQQG=COMFAC*2D0*FA
31055 ELSEIF(MSTP(147).EQ.3) THEN
31056 FACQQG=COMFAC*FA
31057 ELSEIF(MSTP(147).EQ.4) THEN
31058 FACQQG=COMFAC*FA
31059 ELSEIF(MSTP(147).EQ.5) THEN
31060 FACQQG=0D0
31061 ELSEIF(MSTP(147).EQ.6) THEN
31062 FACQQG=0D0
31063 ENDIF
31064 ENDIF
31065C...Split total contribution into different colour flows just like
31066C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31067C...(recalculate kinematics for massless partons).
31068 THP=-0.5D0*SH*(1D0-CTH)
31069 UHP=-0.5D0*SH*(1D0+CTH)
31070 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31071 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31072 FACGGS=FACGG1+FACGG2
31073 DO 2448 I=MMINA,MMAXA
31074 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31075 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31076 NCHN=NCHN+1
31077 ISIG(NCHN,1)=I
31078 ISIG(NCHN,2)=-I
31079 ISIG(NCHN,3)=1
31080 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31081 NCHN=NCHN+1
31082 ISIG(NCHN,1)=I
31083 ISIG(NCHN,2)=-I
31084 ISIG(NCHN,3)=2
31085 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31086 2448 CONTINUE
31087
31088 ELSEIF(ISUB.EQ.430) THEN
31089C...q + q~ -> g + QQ~[3PJ8]
31090 IF(MSTP(145).EQ.0) THEN
31091 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31092 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31093 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31094 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31095 ELSE
31096 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31097 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31098 BB=8D0*(UHSH2+SH*TH)
31099 CC=8D0*(SHTH2+SH*UH)
31100 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31101 IF(MSTP(147).EQ.0) THEN
31102 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31103 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31104 ELSEIF(MSTP(147).EQ.1) THEN
31105 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31106 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31107 ELSEIF(MSTP(147).EQ.3) THEN
31108 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31109 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31110 ELSEIF(MSTP(147).EQ.4) THEN
31111 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31112 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31113 ELSEIF(MSTP(147).EQ.5) THEN
31114 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31115 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31116 ELSEIF(MSTP(147).EQ.6) THEN
31117 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31118 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31119 ENDIF
31120 FACQQG=COMFAC*FF*FACQQG
31121 ENDIF
31122C...Split total contribution into different colour flows just like
31123C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31124C...(recalculate kinematics for massless partons).
31125 THP=-0.5D0*SH*(1D0-CTH)
31126 UHP=-0.5D0*SH*(1D0+CTH)
31127 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31128 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31129 FACGGS=FACGG1+FACGG2
31130 DO 2449 I=MMINA,MMAXA
31131 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31132 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
31133 NCHN=NCHN+1
31134 ISIG(NCHN,1)=I
31135 ISIG(NCHN,2)=-I
31136 ISIG(NCHN,3)=1
31137 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31138 NCHN=NCHN+1
31139 ISIG(NCHN,1)=I
31140 ISIG(NCHN,2)=-I
31141 ISIG(NCHN,3)=2
31142 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31143 2449 CONTINUE
31144
31145 ELSEIF(ISUB.EQ.431) THEN
31146C...g + g -> QQ~[3P01] + g
31147 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31148 QGTW=(SH*TH*UH)/SH**3
31149 RGTW=SQMQQ/SH
31150 IF(MSTP(145).EQ.0) THEN
31151 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31152 & (9D0*RGTW**2*PGTW**4*
31153 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31154 & -6D0*RGTW*PGTW**3*QGTW*
31155 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31156 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31157 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31158 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31159 ELSE
31160 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
31161 & (9D0*RGTW**2*PGTW**4*
31162 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31163 & -6D0*RGTW*PGTW**3*QGTW*
31164 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
31165 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
31166 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
31167 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31168 IF(MSTP(147).EQ.0) THEN
31169 FACQQG=COMFAC*FC1
31170 ELSEIF(MSTP(147).EQ.1) THEN
31171 FACQQG=COMFAC*2D0*FC1
31172 ELSEIF(MSTP(147).EQ.3) THEN
31173 FACQQG=COMFAC*FC1
31174 ELSEIF(MSTP(147).EQ.4) THEN
31175 FACQQG=COMFAC*FC1
31176 ELSEIF(MSTP(147).EQ.5) THEN
31177 FACQQG=0D0
31178 ELSEIF(MSTP(147).EQ.6) THEN
31179 FACQQG=0D0
31180 ENDIF
31181 ENDIF
31182 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31183 NCHN=NCHN+1
31184 ISIG(NCHN,1)=21
31185 ISIG(NCHN,2)=21
31186 ISIG(NCHN,3)=1
31187 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31188 ENDIF
31189
31190 ELSEIF(ISUB.EQ.432) THEN
31191C...g + g -> QQ~[3P11] + g
31192 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31193 QGTW=(SH*TH*UH)/SH**3
31194 RGTW=SQMQQ/SH
31195 IF(MSTP(145).EQ.0) THEN
31196 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
31197 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
31198 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
31199 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
31200 ELSE
31201 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
31202 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
31203 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
31204 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
31205 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
31206 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31207 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31208 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
31209 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
31210 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
31211 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
31212 C4=-4D0*THUH*(TH-UH)**2*
31213 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
31214 & -SH2*TH*UH*(TH2+UH2))
31215 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
31216 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
31217 & +SH2*(5D0*THUH2-17D0*TH*UH)))
31218 IF(MSTP(147).EQ.0) THEN
31219 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31220 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31221 ELSEIF(MSTP(147).EQ.1) THEN
31222 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31223 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31224 ELSEIF(MSTP(147).EQ.3) THEN
31225 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31226 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31227 ELSEIF(MSTP(147).EQ.4) THEN
31228 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31229 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31230 ELSEIF(MSTP(147).EQ.5) THEN
31231 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31232 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31233 ELSEIF(MSTP(147).EQ.6) THEN
31234 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31235 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31236 ENDIF
31237 FACQQG=COMFAC*FF*FACQQG
31238 ENDIF
31239 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31240 NCHN=NCHN+1
31241 ISIG(NCHN,1)=21
31242 ISIG(NCHN,2)=21
31243 ISIG(NCHN,3)=1
31244 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31245 ENDIF
31246
31247 ELSEIF(ISUB.EQ.433) THEN
31248C...g + g -> QQ~[3P21] + g
31249 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31250 QGTW=(SH*TH*UH)/SH**3
31251 RGTW=SQMQQ/SH
31252 IF(MSTP(145).EQ.0) THEN
31253 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
31254 & (12D0*RGTW**2*PGTW**4*
31255 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
31256 & -3D0*RGTW*PGTW**3*QGTW*
31257 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
31258 & +2D0*PGTW**2*QGTW**2*
31259 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
31260 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
31261 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31262 ELSE
31263 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
31264 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
31265 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
31266 & *SH*SH2**7
31267 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
31268 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
31269 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
31270 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
31271 & +10D0*(SH2**2+TH2**2))
31272 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
31273 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
31274 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
31275 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
31276 & +4D0*SH*TH*UH2**4*SHTH2)
31277 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
31278 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
31279 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
31280 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
31281 & +10D0*(SH2**2+UH2**2))
31282 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
31283 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
31284 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
31285 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
31286 & +4D0*SH*UH*TH2**4*UHSH2)
31287 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
31288 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
31289 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
31290 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
31291 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
31292 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
31293 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
31294 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
31295 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
31296 & +3D0*(TH2**3+UH2**3)))
31297 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
31298 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
31299 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
31300 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
31301 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
31302 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
31303 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
31304 & 82D0*TH**3)
31305 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
31306 & +45D0*TH**3)
31307 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
31308 & 8D0*TH**3)
31309 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
31310 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
31311 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
31312 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
31313 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
31314 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
31315 & 82D0*UH**3)
31316 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
31317 & +45D0*UH**3)
31318 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
31319 & 8D0*UH**3)
31320 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
31321 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
31322 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
31323 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
31324 & +4D0*SH*TH2**2*UH2**2*THUH2
31325 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
31326 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
31327 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
31328 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
31329 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31330 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
31331 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
31332 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
31333 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
31334 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
31335 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
31336 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
31337 & +2D0*(TH2**3+UH2**3))
31338 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
31339 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
31340 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
31341 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
31342 IF(MSTP(147).EQ.0) THEN
31343 FACQQG=1D0/3D0*(C1*3D0
31344 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31345 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31346 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31347 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31348 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31349 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31350 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31351 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31352 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31353 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31354 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31355 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31356 ELSEIF(MSTP(147).EQ.1) THEN
31357 FACQQG=C1*2D0
31358 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31359 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31360 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31361 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31362 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31363 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31364 & +EL1K10*EL2K20*EL1K11*EL2K11)
31365 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31366 & +EL1K10*EL2K20*EL1K21*EL2K21)
31367 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31368 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31369 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31370 & +EL1K20*EL2K20*EL1K11*EL2K11)
31371 ELSEIF(MSTP(147).EQ.2) THEN
31372 FACQQG=2D0*(C1
31373 & -C2*EL1K11*EL2K11
31374 & -C3*EL1K21*EL2K21
31375 & -C4*EL1K11*EL2K21
31376 & +C5*(EL1K11*EL2K11)**2
31377 & +C6*(EL1K21*EL2K21)**2
31378 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31379 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31380 & +(C9+C0)*(EL1K11*EL2K21)**2)
31381 ENDIF
31382 FACQQG=COMFAC*FF*FACQQG
31383 ENDIF
31384 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31385 NCHN=NCHN+1
31386 ISIG(NCHN,1)=21
31387 ISIG(NCHN,2)=21
31388 ISIG(NCHN,3)=1
31389 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31390 ENDIF
31391
31392 ELSEIF(ISUB.EQ.434) THEN
31393C...q + g -> q + QQ~[3P01]
31394 IF(MSTP(145).EQ.0) THEN
31395 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
31396 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31397 ELSE
31398 FA=-PARU(1)*AS**3*(16D0/243D0)*
31399 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
31400 IF(MSTP(147).EQ.0) THEN
31401 FACQQG=COMFAC*FA
31402 ELSEIF(MSTP(147).EQ.1) THEN
31403 FACQQG=COMFAC*2D0*FA
31404 ELSEIF(MSTP(147).EQ.3) THEN
31405 FACQQG=COMFAC*FA
31406 ELSEIF(MSTP(147).EQ.4) THEN
31407 FACQQG=COMFAC*FA
31408 ELSEIF(MSTP(147).EQ.5) THEN
31409 FACQQG=0D0
31410 ELSEIF(MSTP(147).EQ.6) THEN
31411 FACQQG=0D0
31412 ENDIF
31413 ENDIF
31414 DO 2452 I=MMINA,MMAXA
31415 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
31416 DO 2451 ISDE=1,2
31417 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
31418 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
31419 NCHN=NCHN+1
31420 ISIG(NCHN,ISDE)=I
31421 ISIG(NCHN,3-ISDE)=21
31422 ISIG(NCHN,3)=1
31423 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31424 2451 CONTINUE
31425 2452 CONTINUE
31426
31427 ELSEIF(ISUB.EQ.435) THEN
31428C...q + g -> q + QQ~[3P11]
31429 IF(MSTP(145).EQ.0) THEN
31430 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
31431 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
31432 ELSE
31433 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
31434 C1=SH*UH
31435 C2=2D0*SH
31436 C3=0D0
31437 C4=2D0*(SH-UH)
31438 IF(MSTP(147).EQ.0) THEN
31439 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31440 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31441 ELSEIF(MSTP(147).EQ.1) THEN
31442 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31443 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31444 ELSEIF(MSTP(147).EQ.3) THEN
31445 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31446 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31447 ELSEIF(MSTP(147).EQ.4) THEN
31448 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31449 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31450 ELSEIF(MSTP(147).EQ.5) THEN
31451 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31452 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31453 ELSEIF(MSTP(147).EQ.6) THEN
31454 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31455 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31456 ENDIF
31457 FACQQG=COMFAC*FF*FACQQG
31458 ENDIF
31459 DO 2454 I=MMINA,MMAXA
31460 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
31461 DO 2453 ISDE=1,2
31462 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
31463 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
31464 NCHN=NCHN+1
31465 ISIG(NCHN,ISDE)=I
31466 ISIG(NCHN,3-ISDE)=21
31467 ISIG(NCHN,3)=1
31468 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31469 2453 CONTINUE
31470 2454 CONTINUE
31471
31472 ELSEIF(ISUB.EQ.436) THEN
31473C...q + g -> q + QQ~[3P21]
31474 IF(MSTP(145).EQ.0) THEN
31475 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
31476 & ((6D0*SQMQQ**2+TH2)*UHSH2
31477 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
31478 & (SQMQQR*TH*UHSH2**2)
31479 ELSE
31480 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
31481 C1=TH*UHSH2
31482 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
31483 C3=4D0*UHSH2
31484 C4=8D0*SH*UHSH
31485 C5=8D0*TH
31486 C6=0D0
31487 C7=16D0*TH
31488 C8=0D0
31489 C9=-16D0*UHSH
31490 C0=16D0*SQMQQ
31491 IF(MSTP(147).EQ.0) THEN
31492 FACQQG=1D0/3D0*(C1*3D0
31493 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31494 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31495 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31496 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31497 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31498 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31499 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31500 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31501 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31502 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31503 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31504 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31505 ELSEIF(MSTP(147).EQ.1) THEN
31506 FACQQG=C1*2D0
31507 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31508 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31509 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31510 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31511 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31512 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31513 & +EL1K10*EL2K20*EL1K11*EL2K11)
31514 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31515 & +EL1K10*EL2K20*EL1K21*EL2K21)
31516 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31517 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31518 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31519 & +EL1K20*EL2K20*EL1K11*EL2K11)
31520 ELSEIF(MSTP(147).EQ.2) THEN
31521 FACQQG=2D0*(C1
31522 & -C2*EL1K11*EL2K11
31523 & -C3*EL1K21*EL2K21
31524 & -C4*EL1K11*EL2K21
31525 & +C5*(EL1K11*EL2K11)**2
31526 & +C6*(EL1K21*EL2K21)**2
31527 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31528 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31529 & +(C9+C0)*(EL1K11*EL2K21)**2)
31530 ENDIF
31531 FACQQG=COMFAC*FF*FACQQG
31532 ENDIF
31533 DO 2456 I=MMINA,MMAXA
31534 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
31535 DO 2455 ISDE=1,2
31536 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
31537 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
31538 NCHN=NCHN+1
31539 ISIG(NCHN,ISDE)=I
31540 ISIG(NCHN,3-ISDE)=21
31541 ISIG(NCHN,3)=1
31542 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31543 2455 CONTINUE
31544 2456 CONTINUE
31545
31546 ELSEIF(ISUB.EQ.437) THEN
31547C...q + q~ -> g + QQ~[3P01]
31548 IF(MSTP(145).EQ.0) THEN
31549 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
31550 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31551 ELSE
31552 FA=PARU(1)*AS**3*(128D0/729D0)*
31553 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
31554 IF(MSTP(147).EQ.0) THEN
31555 FACQQG=COMFAC*FA
31556 ELSEIF(MSTP(147).EQ.1) THEN
31557 FACQQG=COMFAC*2D0*FA
31558 ELSEIF(MSTP(147).EQ.3) THEN
31559 FACQQG=COMFAC*FA
31560 ELSEIF(MSTP(147).EQ.4) THEN
31561 FACQQG=COMFAC*FA
31562 ELSEIF(MSTP(147).EQ.5) THEN
31563 FACQQG=0D0
31564 ELSEIF(MSTP(147).EQ.6) THEN
31565 FACQQG=0D0
31566 ENDIF
31567 ENDIF
31568 DO 2457 I=MMINA,MMAXA
31569 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31570 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
31571 NCHN=NCHN+1
31572 ISIG(NCHN,1)=I
31573 ISIG(NCHN,2)=-I
31574 ISIG(NCHN,3)=1
31575 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31576 2457 CONTINUE
31577
31578 ELSEIF(ISUB.EQ.438) THEN
31579C...q + q~ -> g + QQ~[3P11]
31580 IF(MSTP(145).EQ.0) THEN
31581 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
31582 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
31583 ELSE
31584 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
31585 C1=TH*UH
31586 C2=2D0*UH
31587 C3=2D0*TH
31588 C4=2D0*THUH
31589 IF(MSTP(147).EQ.0) THEN
31590 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31591 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31592 ELSEIF(MSTP(147).EQ.1) THEN
31593 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31594 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
31595 ELSEIF(MSTP(147).EQ.3) THEN
31596 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
31597 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
31598 ELSEIF(MSTP(147).EQ.4) THEN
31599 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31600 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31601 ELSEIF(MSTP(147).EQ.5) THEN
31602 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
31603 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
31604 ELSEIF(MSTP(147).EQ.6) THEN
31605 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
31606 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
31607 ENDIF
31608 FACQQG=COMFAC*FF*FACQQG
31609 ENDIF
31610 DO 2458 I=MMINA,MMAXA
31611 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31612 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
31613 NCHN=NCHN+1
31614 ISIG(NCHN,1)=I
31615 ISIG(NCHN,2)=-I
31616 ISIG(NCHN,3)=1
31617 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31618 2458 CONTINUE
31619
31620 ELSEIF(ISUB.EQ.439) THEN
31621C...q + q~ -> g + QQ~[3P21]
31622 IF(MSTP(145).EQ.0) THEN
31623 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
31624 & ((6D0*SQMQQ**2+SH2)*THUH2
31625 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
31626 & (SQMQQR*SH*THUH2**2)
31627 ELSE
31628 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
31629 C1=SH*THUH2
31630 C2=4D0*(SH2+UH2+2D0*SH*THUH)
31631 C3=4D0*(SH2+TH2+2D0*SH*THUH)
31632 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
31633 C5=8D0*SH
31634 C6=C5
31635 C7=16D0*SH
31636 C8=C7
31637 C9=-16D0*THUH
31638 C0=16D0*SQMQQ
31639 IF(MSTP(147).EQ.0) THEN
31640 FACQQG=1D0/3D0*(C1*3D0
31641 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
31642 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
31643 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
31644 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
31645 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
31646 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31647 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31648 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
31649 & *(EL1K10*EL2K20-EL1K11*EL2K21)
31650 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
31651 & *(EL1K20*EL2K20-EL1K21*EL2K21)
31652 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
31653 ELSEIF(MSTP(147).EQ.1) THEN
31654 FACQQG=C1*2D0
31655 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
31656 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
31657 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
31658 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
31659 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
31660 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
31661 & +EL1K10*EL2K20*EL1K11*EL2K11)
31662 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
31663 & +EL1K10*EL2K20*EL1K21*EL2K21)
31664 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
31665 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
31666 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
31667 & +EL1K20*EL2K20*EL1K11*EL2K11)
31668 ELSEIF(MSTP(147).EQ.2) THEN
31669 FACQQG=2D0*(C1
31670 & -C2*EL1K11*EL2K11
31671 & -C3*EL1K21*EL2K21
31672 & -C4*EL1K11*EL2K21
31673 & +C5*(EL1K11*EL2K11)**2
31674 & +C6*(EL1K21*EL2K21)**2
31675 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
31676 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
31677 & +(C9+C0)*(EL1K11*EL2K21)**2)
31678 ENDIF
31679 FACQQG=COMFAC*FF*FACQQG
31680 ENDIF
31681 DO 2459 I=MMINA,MMAXA
31682 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31683 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
31684 NCHN=NCHN+1
31685 ISIG(NCHN,1)=I
31686 ISIG(NCHN,2)=-I
31687 ISIG(NCHN,3)=1
31688 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
31689 2459 CONTINUE
31690 ENDIF
31691C...QUARKONIA---
31692
31693 ENDIF
31694
31695 RETURN
31696 END
31697
31698C*********************************************************************
31699
31700C...PYSGWZ
31701C...Subprocess cross sections for W/Z processes,
31702C...except that longitudinal WW scattering is in Higgs sector.
31703C...Auxiliary to PYSIGH.
31704
31705 SUBROUTINE PYSGWZ(NCHN,SIGS)
31706
31707C...Double precision and integer declarations
31708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31709 IMPLICIT INTEGER(I-N)
31710 INTEGER PYK,PYCHGE,PYCOMP
31711C...Parameter statement to help give large particle numbers.
31712 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31713 &KEXCIT=4000000,KDIMEN=5000000)
31714C...Commonblocks
31715 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31716 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31717 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
31718 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
31719 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31720 COMMON/PYINT1/MINT(400),VINT(400)
31721 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31722 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31723 COMMON/PYINT4/MWID(500),WIDS(500,5)
31724 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
31725 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31726 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31727 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31728 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31729 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
31730 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
31731C...Local arrays and complex numbers
31732 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
31733 &HL4(3),HR4(3)
31734 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
31735
31736C...Differential cross section expressions.
31737
31738 IF(ISUB.LE.20) THEN
31739 IF(ISUB.EQ.1) THEN
31740C...f + fbar -> gamma*/Z0
31741 MINT(61)=2
31742 CALL PYWIDT(23,SH,WDTP,WDTE)
31743 HS=SHR*WDTP(0)
31744 FACZ=4D0*COMFAC*3D0
31745 HP0=AEM/3D0*SH
31746 HP1=AEM/3D0*XWC*SH
31747 DO 100 I=MMINA,MMAXA
31748 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31749 EI=KCHG(IABS(I),1)/3D0
31750 AI=SIGN(1D0,EI)
31751 VI=AI-4D0*EI*XWV
31752 HI0=HP0
31753 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
31754 HI1=HP1
31755 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
31756 NCHN=NCHN+1
31757 ISIG(NCHN,1)=I
31758 ISIG(NCHN,2)=-I
31759 ISIG(NCHN,3)=1
31760 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
31761 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
31762 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
31763 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
31764 100 CONTINUE
31765
31766 ELSEIF(ISUB.EQ.2) THEN
31767C...f + fbar' -> W+/-
31768 CALL PYWIDT(24,SH,WDTP,WDTE)
31769 HS=SHR*WDTP(0)
31770 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
31771 HP=AEM/(24D0*XW)*SH
31772 DO 120 I=MMIN1,MMAX1
31773 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
31774 IA=IABS(I)
31775 DO 110 J=MMIN2,MMAX2
31776 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
31777 JA=IABS(J)
31778 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
31779 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31780 & GOTO 110
31781 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31782 HI=HP*2D0
31783 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
31784 NCHN=NCHN+1
31785 ISIG(NCHN,1)=I
31786 ISIG(NCHN,2)=J
31787 ISIG(NCHN,3)=1
31788 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
31789 SIGH(NCHN)=HI*FACBW*HF
31790 110 CONTINUE
31791 120 CONTINUE
31792
31793 ELSEIF(ISUB.EQ.15) THEN
31794C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
31795 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31796C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31797 HFGG=0D0
31798 HFGZ=0D0
31799 HFZZ=0D0
31800 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31801 DO 130 I=1,MIN(16,MDCY(23,3))
31802 IDC=I+MDCY(23,2)-1
31803 IF(MDME(IDC,1).LT.0) GOTO 130
31804 IMDM=0
31805 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31806 & IMDM=1
31807 IF(I.LE.8) THEN
31808 EF=KCHG(I,1)/3D0
31809 AF=SIGN(1D0,EF+0.1D0)
31810 VF=AF-4D0*EF*XWV
31811 ELSEIF(I.LE.16) THEN
31812 EF=KCHG(I+2,1)/3D0
31813 AF=SIGN(1D0,EF+0.1D0)
31814 VF=AF-4D0*EF*XWV
31815 ENDIF
31816 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31817 IF(4D0*RM1.LT.1D0) THEN
31818 FCOF=1D0
31819 IF(I.LE.8) FCOF=3D0*RADC4
31820 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31821 IF(IMDM.EQ.1) THEN
31822 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31823 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31824 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31825 & AF**2*(1D0-4D0*RM1))*BE34
31826 ENDIF
31827 ENDIF
31828 130 CONTINUE
31829C...Propagators: as simulated in PYOFSH and as desired
31830 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31831 MINT15=MINT(15)
31832 MINT(15)=1
31833 MINT(61)=1
31834 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31835 MINT(15)=MINT15
31836 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31837 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31838 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31839 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31840C...Loop over flavours; consider full gamma/Z structure
31841 DO 140 I=MMINA,MMAXA
31842 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31843 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
31844 EI=KCHG(IABS(I),1)/3D0
31845 AI=SIGN(1D0,EI)
31846 VI=AI-4D0*EI*XWV
31847 NCHN=NCHN+1
31848 ISIG(NCHN,1)=I
31849 ISIG(NCHN,2)=-I
31850 ISIG(NCHN,3)=1
31851 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
31852 & (VI**2+AI**2)*HFZZ)/HBW4
31853 140 CONTINUE
31854
31855 ELSEIF(ISUB.EQ.16) THEN
31856C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
31857 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31858C...Propagators: as simulated in PYOFSH and as desired
31859 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31860 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31861 GMMWC=SQRT(SQM4)*WDTP(0)
31862 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31863 FACWG=FACWG*HBW4C/HBW4
31864 DO 160 I=MMIN1,MMAX1
31865 IA=IABS(I)
31866 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
31867 DO 150 J=MMIN2,MMAX2
31868 JA=IABS(J)
31869 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
31870 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
31871 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31872 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31873 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31874 NCHN=NCHN+1
31875 ISIG(NCHN,1)=I
31876 ISIG(NCHN,2)=J
31877 ISIG(NCHN,3)=1
31878 SIGH(NCHN)=FACWG*FCKM*WIDSC
31879 150 CONTINUE
31880 160 CONTINUE
31881
31882 ELSEIF(ISUB.EQ.19) THEN
31883C...f + fbar -> gamma + (gamma*/Z0)
31884 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31885C...gamma, gamma/Z interference and Z couplings to final fermion pairs
31886 HFGG=0D0
31887 HFGZ=0D0
31888 HFZZ=0D0
31889 RADC4=1D0+PYALPS(SQM4)/PARU(1)
31890 DO 170 I=1,MIN(16,MDCY(23,3))
31891 IDC=I+MDCY(23,2)-1
31892 IF(MDME(IDC,1).LT.0) GOTO 170
31893 IMDM=0
31894 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
31895 & IMDM=1
31896 IF(I.LE.8) THEN
31897 EF=KCHG(I,1)/3D0
31898 AF=SIGN(1D0,EF+0.1D0)
31899 VF=AF-4D0*EF*XWV
31900 ELSEIF(I.LE.16) THEN
31901 EF=KCHG(I+2,1)/3D0
31902 AF=SIGN(1D0,EF+0.1D0)
31903 VF=AF-4D0*EF*XWV
31904 ENDIF
31905 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
31906 IF(4D0*RM1.LT.1D0) THEN
31907 FCOF=1D0
31908 IF(I.LE.8) FCOF=3D0*RADC4
31909 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
31910 IF(IMDM.EQ.1) THEN
31911 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
31912 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
31913 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
31914 & AF**2*(1D0-4D0*RM1))*BE34
31915 ENDIF
31916 ENDIF
31917 170 CONTINUE
31918C...Propagators: as simulated in PYOFSH and as desired
31919 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
31920 MINT15=MINT(15)
31921 MINT(15)=1
31922 MINT(61)=1
31923 CALL PYWIDT(23,SQM4,WDTP,WDTE)
31924 MINT(15)=MINT15
31925 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
31926 HFGG=HFGG*HFAEM*VINT(111)/SQM4
31927 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
31928 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
31929C...Loop over flavours; consider full gamma/Z structure
31930 DO 180 I=MMINA,MMAXA
31931 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
31932 EI=KCHG(IABS(I),1)/3D0
31933 AI=SIGN(1D0,EI)
31934 VI=AI-4D0*EI*XWV
31935 FCOI=1D0
31936 IF(IABS(I).LE.10) FCOI=FACA/3D0
31937 NCHN=NCHN+1
31938 ISIG(NCHN,1)=I
31939 ISIG(NCHN,2)=-I
31940 ISIG(NCHN,3)=1
31941 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
31942 & (VI**2+AI**2)*HFZZ)/HBW4
31943 180 CONTINUE
31944
31945 ELSEIF(ISUB.EQ.20) THEN
31946C...f + fbar' -> gamma + W+/-
31947 FACGW=COMFAC*0.5D0*AEM**2/XW
31948C...Propagators: as simulated in PYOFSH and as desired
31949 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
31950 CALL PYWIDT(24,SQM4,WDTP,WDTE)
31951 GMMWC=SQRT(SQM4)*WDTP(0)
31952 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
31953 FACGW=FACGW*HBW4C/HBW4
31954C...Anomalous couplings
31955 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
31956 TERM2=0D0
31957 TERM3=0D0
31958 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
31959 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
31960 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
31961 & (4D0*SQMW))/(TH+UH)**2
31962 ENDIF
31963 DO 200 I=MMIN1,MMAX1
31964 IA=IABS(I)
31965 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
31966 DO 190 J=MMIN2,MMAX2
31967 JA=IABS(J)
31968 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
31969 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
31970 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
31971 & GOTO 190
31972 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
31973 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
31974 IF(IA.LE.10) THEN
31975 FACWR=UH/(TH+UH)-1D0/3D0
31976 FCKM=VCKM((IA+1)/2,(JA+1)/2)
31977 FCOI=FACA/3D0
31978 ELSE
31979 FACWR=-TH/(TH+UH)
31980 FCKM=1D0
31981 FCOI=1D0
31982 ENDIF
31983 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
31984 NCHN=NCHN+1
31985 ISIG(NCHN,1)=I
31986 ISIG(NCHN,2)=J
31987 ISIG(NCHN,3)=1
31988 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
31989 190 CONTINUE
31990 200 CONTINUE
31991 ENDIF
31992
31993 ELSEIF(ISUB.LE.40) THEN
31994 IF(ISUB.EQ.22) THEN
31995C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
31996C...Kinematics dependence
31997 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
31998 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
31999C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32000 DO 220 I=1,6
32001 DO 210 J=1,3
32002 HGZ(I,J)=0D0
32003 210 CONTINUE
32004 220 CONTINUE
32005 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32006 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32007 DO 230 I=1,MIN(16,MDCY(23,3))
32008 IDC=I+MDCY(23,2)-1
32009 IF(MDME(IDC,1).LT.0) GOTO 230
32010 IMDM=0
32011 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32012 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32013 IF(I.LE.8) THEN
32014 EF=KCHG(I,1)/3D0
32015 AF=SIGN(1D0,EF+0.1D0)
32016 VF=AF-4D0*EF*XWV
32017 ELSEIF(I.LE.16) THEN
32018 EF=KCHG(I+2,1)/3D0
32019 AF=SIGN(1D0,EF+0.1D0)
32020 VF=AF-4D0*EF*XWV
32021 ENDIF
32022 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32023 IF(4D0*RM1.LT.1D0) THEN
32024 FCOF=1D0
32025 IF(I.LE.8) FCOF=3D0*RADC3
32026 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32027 IF(IMDM.GE.1) THEN
32028 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32029 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32030 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32031 & AF**2*(1D0-4D0*RM1))*BE34
32032 ENDIF
32033 ENDIF
32034 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32035 IF(4D0*RM1.LT.1D0) THEN
32036 FCOF=1D0
32037 IF(I.LE.8) FCOF=3D0*RADC4
32038 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32039 IF(IMDM.GE.1) THEN
32040 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32041 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32042 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32043 & AF**2*(1D0-4D0*RM1))*BE34
32044 ENDIF
32045 ENDIF
32046 230 CONTINUE
32047C...Propagators: as simulated in PYOFSH and as desired
32048 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32049 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32050 MINT15=MINT(15)
32051 MINT(15)=1
32052 MINT(61)=1
32053 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32054 MINT(15)=MINT15
32055 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32056 DO 240 J=1,3
32057 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32058 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32059 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32060 240 CONTINUE
32061 MINT15=MINT(15)
32062 MINT(15)=1
32063 MINT(61)=1
32064 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32065 MINT(15)=MINT15
32066 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32067 DO 250 J=1,3
32068 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32069 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32070 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32071 250 CONTINUE
32072C...Loop over flavours; separate left- and right-handed couplings
32073 DO 270 I=MMINA,MMAXA
32074 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32075 EI=KCHG(IABS(I),1)/3D0
32076 AI=SIGN(1D0,EI)
32077 VI=AI-4D0*EI*XWV
32078 VALI=VI-AI
32079 VARI=VI+AI
32080 FCOI=1D0
32081 IF(IABS(I).LE.10) FCOI=FACA/3D0
32082 DO 260 J=1,3
32083 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32084 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32085 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32086 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32087 260 CONTINUE
32088 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32089 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32090 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32091 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32092 NCHN=NCHN+1
32093 ISIG(NCHN,1)=I
32094 ISIG(NCHN,2)=-I
32095 ISIG(NCHN,3)=1
32096 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32097 270 CONTINUE
32098
32099 ELSEIF(ISUB.EQ.23) THEN
32100C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32101 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32102 FACZW=FACZW*WIDS(23,2)
32103 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32104 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32105 DO 290 I=MMIN1,MMAX1
32106 IA=IABS(I)
32107 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32108 DO 280 J=MMIN2,MMAX2
32109 JA=IABS(J)
32110 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32111 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32112 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32113 & GOTO 280
32114 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32115 EI=KCHG(IA,1)/3D0
32116 AI=SIGN(1D0,EI+0.1D0)
32117 VI=AI-4D0*EI*XWV
32118 EJ=KCHG(JA,1)/3D0
32119 AJ=SIGN(1D0,EJ+0.1D0)
32120 VJ=AJ-4D0*EJ*XWV
32121 IF(VI+AI.GT.0) THEN
32122 VISAV=VI
32123 AISAV=AI
32124 VI=VJ
32125 AI=AJ
32126 VJ=VISAV
32127 AJ=AISAV
32128 ENDIF
32129 FCKM=1D0
32130 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32131 FCOI=1D0
32132 IF(IA.LE.10) FCOI=FACA/3D0
32133 NCHN=NCHN+1
32134 ISIG(NCHN,1)=I
32135 ISIG(NCHN,2)=J
32136 ISIG(NCHN,3)=1
32137 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
32138 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
32139 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
32140 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
32141 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
32142 & WIDS(24,(5-KCHW)/2)
32143C***Protect against slightly negative cross sections. (Reason yet to be
32144C***sorted out. One possibility: addition of width to the W propagator.)
32145 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
32146 280 CONTINUE
32147 290 CONTINUE
32148
32149 ELSEIF(ISUB.EQ.25) THEN
32150C...f + fbar -> W+ + W-
32151C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
32152 GMMZC=GMMZ
32153 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
32154 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32155 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32156 GMMW3=SQRT(SQM3)*WDTP(0)
32157 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32158 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32159 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32160 GMMW4=SQRT(SQM4)*WDTP(0)
32161 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
32162C...Kinematical functions
32163 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32164 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
32165 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
32166 GT=THUH34+4D0*THUH/TH2
32167 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
32168 GU=THUH34+4D0*THUH/UH2
32169 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
32170C...Common factors and couplings
32171 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
32172 FACWW=FACWW*WIDS(24,1)
32173 CGG=AEM**2/2D0
32174 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
32175 CZZ=AEM**2/(32D0*XW**2)*HBWZC
32176 CNG=AEM**2/(4D0*XW)
32177 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
32178 CNN=AEM**2/(16D0*XW**2)
32179C...Coulomb factor for W+W- pair
32180 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
32181 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
32182 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
32183 IF(COULE.LT.100D0*PMAS(24,2)) THEN
32184 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32185 & PMAS(24,2)**2)-COULE))
32186 ELSE
32187 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
32188 ENDIF
32189 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
32190 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
32191 & PMAS(24,2)**2)+COULE))
32192 ELSE
32193 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
32194 & ABS(COULE)))
32195 ENDIF
32196 IF(MSTP(40).EQ.1) THEN
32197 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
32198 & MAX(1D-10,2D0*COULP*COULP1))
32199 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32200 ELSEIF(MSTP(40).EQ.2) THEN
32201 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
32202 COULCP=DCMPLX(0D0,DBLE(COULP))
32203 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
32204 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
32205 & (4D0*COULCP)*LOG(COULCD)
32206 COULCS=DCMPLX(0D0,0D0)
32207 NSTP=100
32208 DO 300 ISTP=1,NSTP
32209 COULXX=(ISTP-0.5)/NSTP
32210 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
32211 & (1D0+COULXX/COULCD))
32212 300 CONTINUE
32213 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
32214 & (COULCS/NSTP)
32215 FACCOU=ABS(COULCR)**2
32216 ELSEIF(MSTP(40).EQ.3) THEN
32217 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
32218 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
32219 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
32220 ENDIF
32221 ELSEIF(MSTP(40).EQ.4) THEN
32222 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
32223 ELSE
32224 FACCOU=1D0
32225 ENDIF
32226 VINT(95)=FACCOU
32227 FACWW=FACWW*FACCOU
32228C...Loop over allowed flavours
32229 DO 310 I=MMINA,MMAXA
32230 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
32231 EI=KCHG(IABS(I),1)/3D0
32232 AI=SIGN(1D0,EI+0.1D0)
32233 VI=AI-4D0*EI*XWV
32234 FCOI=1D0
32235 IF(IABS(I).LE.10) FCOI=FACA/3D0
32236 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
32237 IF(AI.LT.0D0) THEN
32238 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
32239 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
32240 ELSE
32241 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
32242 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
32243 ENDIF
32244 ELSE
32245 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
32246 BET=SQRT(1D0-4D0*XMW02/SH)
32247 GAT=1D0/SQRT(1D0-BET**2)
32248 STHE2=1D0-CTH**2
32249 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
32250 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
32251 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
32252 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
32253 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
32254 & (1D0-2D0*BET*CTH+BET**2))
32255 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
32256 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
32257 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
32258 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
32259 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
32260 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
32261 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
32262 DSIGWW=ATOT
32263 ENDIF
32264 NCHN=NCHN+1
32265 ISIG(NCHN,1)=I
32266 ISIG(NCHN,2)=-I
32267 ISIG(NCHN,3)=1
32268 SIGH(NCHN)=FACWW*FCOI*DSIGWW
32269 310 CONTINUE
32270
32271 ELSEIF(ISUB.EQ.30) THEN
32272C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
32273 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
32274 & (-SH*UH)
32275C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32276 HFGG=0D0
32277 HFGZ=0D0
32278 HFZZ=0D0
32279 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32280 DO 320 I=1,MIN(16,MDCY(23,3))
32281 IDC=I+MDCY(23,2)-1
32282 IF(MDME(IDC,1).LT.0) GOTO 320
32283 IMDM=0
32284 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32285 & IMDM=1
32286 IF(I.LE.8) THEN
32287 EF=KCHG(I,1)/3D0
32288 AF=SIGN(1D0,EF+0.1D0)
32289 VF=AF-4D0*EF*XWV
32290 ELSEIF(I.LE.16) THEN
32291 EF=KCHG(I+2,1)/3D0
32292 AF=SIGN(1D0,EF+0.1D0)
32293 VF=AF-4D0*EF*XWV
32294 ENDIF
32295 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32296 IF(4D0*RM1.LT.1D0) THEN
32297 FCOF=1D0
32298 IF(I.LE.8) FCOF=3D0*RADC4
32299 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32300 IF(IMDM.EQ.1) THEN
32301 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32302 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32303 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32304 & AF**2*(1D0-4D0*RM1))*BE34
32305 ENDIF
32306 ENDIF
32307 320 CONTINUE
32308C...Propagators: as simulated in PYOFSH and as desired
32309 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32310 MINT15=MINT(15)
32311 MINT(15)=1
32312 MINT(61)=1
32313 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32314 MINT(15)=MINT15
32315 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32316 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32317 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32318 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32319C...Loop over flavours; consider full gamma/Z structure
32320 DO 340 I=MMINA,MMAXA
32321 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
32322 EI=KCHG(IABS(I),1)/3D0
32323 AI=SIGN(1D0,EI)
32324 VI=AI-4D0*EI*XWV
32325 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
32326 & (VI**2+AI**2)*HFZZ)/HBW4
32327 DO 330 ISDE=1,2
32328 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
32329 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
32330 NCHN=NCHN+1
32331 ISIG(NCHN,ISDE)=I
32332 ISIG(NCHN,3-ISDE)=21
32333 ISIG(NCHN,3)=1
32334 SIGH(NCHN)=FACZQ
32335 330 CONTINUE
32336 340 CONTINUE
32337
32338 ELSEIF(ISUB.EQ.31) THEN
32339C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
32340 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
32341 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
32342C...Propagators: as simulated in PYOFSH and as desired
32343 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32344 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32345 GMMWC=SQRT(SQM4)*WDTP(0)
32346 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32347 FACWQ=FACWQ*HBW4C/HBW4
32348 DO 360 I=MMINA,MMAXA
32349 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
32350 IA=IABS(I)
32351 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32352 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32353 DO 350 ISDE=1,2
32354 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
32355 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
32356 NCHN=NCHN+1
32357 ISIG(NCHN,ISDE)=I
32358 ISIG(NCHN,3-ISDE)=21
32359 ISIG(NCHN,3)=1
32360 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32361 350 CONTINUE
32362 360 CONTINUE
32363
32364 ELSEIF(ISUB.EQ.35) THEN
32365C...f + gamma -> f + (gamma*/Z0)
32366 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
32367 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
32368 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
32369 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
32370 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
32371 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
32372 ELSE
32373 FZQN=SH2+UH2+2D0*SQM4*TH
32374 FZQDTM=-SH*UH
32375 ENDIF
32376 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
32377C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32378 HFGG=0D0
32379 HFGZ=0D0
32380 HFZZ=0D0
32381 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32382 DO 370 I=1,MIN(16,MDCY(23,3))
32383 IDC=I+MDCY(23,2)-1
32384 IF(MDME(IDC,1).LT.0) GOTO 370
32385 IMDM=0
32386 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32387 & IMDM=1
32388 IF(I.LE.8) THEN
32389 EF=KCHG(I,1)/3D0
32390 AF=SIGN(1D0,EF+0.1D0)
32391 VF=AF-4D0*EF*XWV
32392 ELSEIF(I.LE.16) THEN
32393 EF=KCHG(I+2,1)/3D0
32394 AF=SIGN(1D0,EF+0.1D0)
32395 VF=AF-4D0*EF*XWV
32396 ENDIF
32397 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32398 IF(4D0*RM1.LT.1D0) THEN
32399 FCOF=1D0
32400 IF(I.LE.8) FCOF=3D0*RADC4
32401 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32402 IF(IMDM.EQ.1) THEN
32403 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32404 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32405 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32406 & AF**2*(1D0-4D0*RM1))*BE34
32407 ENDIF
32408 ENDIF
32409 370 CONTINUE
32410C...Propagators: as simulated in PYOFSH and as desired
32411 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32412 MINT15=MINT(15)
32413 MINT(15)=1
32414 MINT(61)=1
32415 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32416 MINT(15)=MINT15
32417 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32418 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32419 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32420 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32421C...Loop over flavours; consider full gamma/Z structure
32422 DO 390 I=MMINA,MMAXA
32423 IF(I.EQ.0) GOTO 390
32424 EI=KCHG(IABS(I),1)/3D0
32425 AI=SIGN(1D0,EI)
32426 VI=AI-4D0*EI*XWV
32427 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32428 & (VI**2+AI**2)*HFZZ)/HBW4
32429 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
32430 DO 380 ISDE=1,2
32431 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
32432 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
32433 NCHN=NCHN+1
32434 ISIG(NCHN,ISDE)=I
32435 ISIG(NCHN,3-ISDE)=22
32436 ISIG(NCHN,3)=1
32437 SIGH(NCHN)=FACZQ*FZQN/FZQD
32438 380 CONTINUE
32439 390 CONTINUE
32440
32441 ELSEIF(ISUB.EQ.36) THEN
32442C...f + gamma -> f' + W+/-
32443 FWQ=COMFAC*AEM**2/(2D0*XW)*
32444 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
32445C...Propagators: as simulated in PYOFSH and as desired
32446 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32447 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32448 GMMWC=SQRT(SQM4)*WDTP(0)
32449 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32450 FWQ=FWQ*HBW4C/HBW4
32451 DO 410 I=MMINA,MMAXA
32452 IF(I.EQ.0) GOTO 410
32453 IA=IABS(I)
32454 EIA=ABS(KCHG(IABS(I),1)/3D0)
32455 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
32456 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
32457 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32458 DO 400 ISDE=1,2
32459 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
32460 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
32461 NCHN=NCHN+1
32462 ISIG(NCHN,ISDE)=I
32463 ISIG(NCHN,3-ISDE)=22
32464 ISIG(NCHN,3)=1
32465 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
32466 400 CONTINUE
32467 410 CONTINUE
32468 ENDIF
32469
32470 ELSEIF(ISUB.LE.100) THEN
32471 IF(ISUB.EQ.69) THEN
32472C...gamma + gamma -> W+ + W-
32473 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32474 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
32475 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
32476 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
32477 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
32478 NCHN=NCHN+1
32479 ISIG(NCHN,1)=22
32480 ISIG(NCHN,2)=22
32481 ISIG(NCHN,3)=1
32482 SIGH(NCHN)=FACWW
32483 420 CONTINUE
32484
32485 ELSEIF(ISUB.EQ.70) THEN
32486C...gamma + W+/- -> Z0 + W+/-
32487 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
32488 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
32489 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
32490 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
32491 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
32492 DO 440 KCHW=1,-1,-2
32493 DO 430 ISDE=1,2
32494 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
32495 NCHN=NCHN+1
32496 ISIG(NCHN,ISDE)=22
32497 ISIG(NCHN,3-ISDE)=24*KCHW
32498 ISIG(NCHN,3)=1
32499 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
32500 430 CONTINUE
32501 440 CONTINUE
32502 ENDIF
32503 ENDIF
32504
32505 RETURN
32506 END
32507
32508C*********************************************************************
32509
32510C...PYSGHG
32511C...Subprocess cross sections for Higgs processes,
32512C...except Higgs pairs in PYSGSU, but including WW scattering.
32513C...Auxiliary to PYSIGH.
32514
32515 SUBROUTINE PYSGHG(NCHN,SIGS)
32516
32517C...Double precision and integer declarations
32518 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32519 IMPLICIT INTEGER(I-N)
32520 INTEGER PYK,PYCHGE,PYCOMP
32521C...Parameter statement to help give large particle numbers.
32522 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32523 &KEXCIT=4000000,KDIMEN=5000000)
32524C...Commonblocks
32525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32526 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32527 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32528 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32529 COMMON/PYINT1/MINT(400),VINT(400)
32530 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32531 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32532 COMMON/PYINT4/MWID(500),WIDS(500,5)
32533 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32534 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
32535 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32536 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32537 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32538 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32539 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
32540 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
32541C...Local arrays and complex variables
32542 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
32543 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
32544 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
32545
32546C...Convert H or A process into equivalent h one
32547 IHIGG=1
32548 KFHIGG=25
32549 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
32550 KFHIGG=KFPR(ISUB,1)
32551 END IF
32552 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
32553 &ISUB.LE.190)) THEN
32554 IHIGG=2
32555 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
32556 KFHIGG=33+IHIGG
32557 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
32558 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
32559 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
32560 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
32561 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
32562 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
32563 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
32564 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
32565 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
32566 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
32567 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
32568 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
32569 ENDIF
32570 SQMH=PMAS(KFHIGG,1)**2
32571 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
32572
32573C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32574 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
32575 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
32576C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
32577 IF(MSTP(46).LE.4) THEN
32578 HDTLH=LOG(PMAS(25,1)/PARP(44))
32579 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
32580 HDTNR=-1D0/18D0+HDTLH/6D0
32581 ELSE
32582 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
32583 HDTLQ=LOG(PARP(45)/PARP(44))
32584 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
32585 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
32586 ENDIF
32587
32588C...Calculate lowest and next-to-lowest order partial wave amplitudes
32589 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
32590 A00L=DBLE(HDTV*SH)
32591 A20L=-0.5D0*A00L
32592 A11L=A00L/6D0
32593 HDTLS=LOG(SH/PARP(44)**2)
32594 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32595 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
32596 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
32597 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
32598 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
32599 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
32600 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
32601 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
32602
32603C...Unitarize partial wave amplitudes with Pade or K-matrix method
32604 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
32605 A00U=A00L/(1D0-A004/A00L)
32606 A20U=A20L/(1D0-A204/A20L)
32607 A11U=A11L/(1D0-A114/A11L)
32608 ELSE
32609 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
32610 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
32611 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
32612 ENDIF
32613 ENDIF
32614
32615C...Differential cross section expressions.
32616
32617 IF(ISUB.LE.60) THEN
32618 IF(ISUB.EQ.3) THEN
32619C...f + fbar -> h0 (or H0, or A0)
32620 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
32621 HS=SHR*WDTP(0)
32622 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32623 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
32624 & FACBW=0D0
32625 HP=AEM/(8D0*XW)*SH/SQMW*SH
32626 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32627 DO 100 I=MMINA,MMAXA
32628 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32629 IA=IABS(I)
32630 RMQ=PYMRUN(IA,SH)**2/SH
32631 HI=HP*RMQ
32632 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
32633 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
32634 IKFI=1
32635 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
32636 IF(IA.GT.10) IKFI=3
32637 HI=HI*PARU(150+10*IHIGG+IKFI)**2
32638 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
32639 HI=HI/(1D0+RMSS(41))**2
32640 IF(IHIGG.NE.3) THEN
32641 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
32642 & PARU(151+10*IHIGG))**2
32643 ENDIF
32644 ENDIF
32645 ENDIF
32646 NCHN=NCHN+1
32647 ISIG(NCHN,1)=I
32648 ISIG(NCHN,2)=-I
32649 ISIG(NCHN,3)=1
32650 SIGH(NCHN)=HI*FACBW*HF
32651 100 CONTINUE
32652
32653 ELSEIF(ISUB.EQ.5) THEN
32654C...Z0 + Z0 -> h0
32655 CALL PYWIDT(25,SH,WDTP,WDTE)
32656 HS=SHR*WDTP(0)
32657 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32658 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32659 HP=AEM/(8D0*XW)*SH/SQMW*SH
32660 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32661 HI=HP/4D0
32662 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
32663 DO 120 I=MMIN1,MMAX1
32664 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32665 DO 110 J=MMIN2,MMAX2
32666 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32667 EI=KCHG(IABS(I),1)/3D0
32668 AI=SIGN(1D0,EI)
32669 VI=AI-4D0*EI*XWV
32670 EJ=KCHG(IABS(J),1)/3D0
32671 AJ=SIGN(1D0,EJ)
32672 VJ=AJ-4D0*EJ*XWV
32673 NCHN=NCHN+1
32674 ISIG(NCHN,1)=I
32675 ISIG(NCHN,2)=J
32676 ISIG(NCHN,3)=1
32677 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
32678 110 CONTINUE
32679 120 CONTINUE
32680
32681 ELSEIF(ISUB.EQ.8) THEN
32682C...W+ + W- -> h0
32683 CALL PYWIDT(25,SH,WDTP,WDTE)
32684 HS=SHR*WDTP(0)
32685 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
32686 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
32687 HP=AEM/(8D0*XW)*SH/SQMW*SH
32688 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
32689 HI=HP/2D0
32690 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
32691 DO 140 I=MMIN1,MMAX1
32692 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
32693 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
32694 DO 130 J=MMIN2,MMAX2
32695 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
32696 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
32697 IF(EI*EJ.GT.0D0) GOTO 130
32698 NCHN=NCHN+1
32699 ISIG(NCHN,1)=I
32700 ISIG(NCHN,2)=J
32701 ISIG(NCHN,3)=1
32702 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
32703 130 CONTINUE
32704 140 CONTINUE
32705
32706 ELSEIF(ISUB.EQ.24) THEN
32707C...f + fbar -> Z0 + h0 (or H0, or A0)
32708C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
32709 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32710 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32711 GMMZ3=SQRT(SQM3)*WDTP(0)
32712 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
32713 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32714 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32715 GMMH4=SQRT(SQM4)*WDTP(0)
32716 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32717 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32718 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
32719 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
32720 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
32721 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
32722 & PARU(154+10*IHIGG)**2
32723 DO 150 I=MMINA,MMAXA
32724 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
32725 EI=KCHG(IABS(I),1)/3D0
32726 AI=SIGN(1D0,EI)
32727 VI=AI-4D0*EI*XWV
32728 FCOI=1D0
32729 IF(IABS(I).LE.10) FCOI=FACA/3D0
32730 NCHN=NCHN+1
32731 ISIG(NCHN,1)=I
32732 ISIG(NCHN,2)=-I
32733 ISIG(NCHN,3)=1
32734 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
32735 150 CONTINUE
32736
32737 ELSEIF(ISUB.EQ.26) THEN
32738C...f + fbar' -> W+/- + h0 (or H0, or A0)
32739C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
32740 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
32741 CALL PYWIDT(24,SQM3,WDTP,WDTE)
32742 GMMW3=SQRT(SQM3)*WDTP(0)
32743 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
32744 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
32745 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
32746 GMMH4=SQRT(SQM4)*WDTP(0)
32747 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
32748 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32749 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
32750 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
32751 FACHW=FACHW*WIDS(KFHIGG,2)
32752 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
32753 & PARU(155+10*IHIGG)**2
32754 DO 170 I=MMIN1,MMAX1
32755 IA=IABS(I)
32756 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
32757 DO 160 J=MMIN2,MMAX2
32758 JA=IABS(J)
32759 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
32760 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
32761 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32762 & GOTO 160
32763 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32764 FCKM=1D0
32765 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32766 FCOI=1D0
32767 IF(IA.LE.10) FCOI=FACA/3D0
32768 NCHN=NCHN+1
32769 ISIG(NCHN,1)=I
32770 ISIG(NCHN,2)=J
32771 ISIG(NCHN,3)=1
32772 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
32773 160 CONTINUE
32774 170 CONTINUE
32775
32776 ELSEIF(ISUB.EQ.32) THEN
32777C...f + g -> f + h0 (q + g -> q + h0 only)
32778 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
32779C...H propagator: as simulated in PYOFSH and as desired
32780 SQMHC=PMAS(25,1)**2
32781 GMMHC=PMAS(25,1)*PMAS(25,2)
32782 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
32783 CALL PYWIDT(25,SQM4,WDTP,WDTE)
32784 GMMHCC=SQRT(SQM4)*WDTP(0)
32785 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
32786 FHCQ=FHCQ*HBW4C/HBW4
32787 DO 190 I=MMINA,MMAXA
32788 IA=IABS(I)
32789 IF(IA.NE.5) GOTO 190
32790 SQML=PYMRUN(IA,SH)**2
32791 SQMQ=PMAS(IA,1)**2
32792 FACHCQ=FHCQ*SQML/SQMW*
32793 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
32794 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
32795 & (SQM4-SQMQ-SH)/SH)
32796 DO 180 ISDE=1,2
32797 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
32798 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
32799 NCHN=NCHN+1
32800 ISIG(NCHN,ISDE)=I
32801 ISIG(NCHN,3-ISDE)=21
32802 ISIG(NCHN,3)=1
32803 SIGH(NCHN)=FACHCQ*WIDS(25,2)
32804 180 CONTINUE
32805 190 CONTINUE
32806 ENDIF
32807
32808 ELSEIF(ISUB.LE.80) THEN
32809 IF(ISUB.EQ.71) THEN
32810C...Z0 + Z0 -> Z0 + Z0
32811 IF(SH.LE.4.01D0*SQMZ) GOTO 220
32812
32813 IF(MSTP(46).LE.2) THEN
32814C...Exact scattering ME:s for on-mass-shell gauge bosons
32815 BE2=1D0-4D0*SQMZ/SH
32816 TH=-0.5D0*SH*BE2*(1D0-CTH)
32817 UH=-0.5D0*SH*BE2*(1D0+CTH)
32818 IF(MAX(TH,UH).GT.-1D0) GOTO 220
32819 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
32820 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32821 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32822 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
32823 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32824 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32825 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
32826 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
32827 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
32828 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32829 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32830 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
32831 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
32832 & (ASHIM+ATHIM+AUHIM)**2)
32833 IF(MSTP(46).EQ.2) FACZZ=0D0
32834
32835 ELSE
32836C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32837 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32838 & ABS(A00U+2D0*A20U)**2
32839 ENDIF
32840 FACZZ=FACZZ*WIDS(23,1)
32841
32842 DO 210 I=MMIN1,MMAX1
32843 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
32844 EI=KCHG(IABS(I),1)/3D0
32845 AI=SIGN(1D0,EI)
32846 VI=AI-4D0*EI*XWV
32847 AVI=AI**2+VI**2
32848 DO 200 J=MMIN2,MMAX2
32849 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
32850 EJ=KCHG(IABS(J),1)/3D0
32851 AJ=SIGN(1D0,EJ)
32852 VJ=AJ-4D0*EJ*XWV
32853 AVJ=AJ**2+VJ**2
32854 NCHN=NCHN+1
32855 ISIG(NCHN,1)=I
32856 ISIG(NCHN,2)=J
32857 ISIG(NCHN,3)=1
32858 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
32859 200 CONTINUE
32860 210 CONTINUE
32861 220 CONTINUE
32862
32863 ELSEIF(ISUB.EQ.72) THEN
32864C...Z0 + Z0 -> W+ + W-
32865 IF(SH.LE.4.01D0*SQMZ) GOTO 250
32866
32867 IF(MSTP(46).LE.2) THEN
32868C...Exact scattering ME:s for on-mass-shell gauge bosons
32869 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
32870 CTH2=CTH**2
32871 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
32872 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
32873 IF(MAX(TH,UH).GT.-1D0) GOTO 250
32874 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
32875 & (1D0-2D0*SQMZ/SH)
32876 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
32877 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
32878 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
32879 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32880 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32881 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
32882 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32883 ATWIM=0D0
32884 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
32885 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
32886 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
32887 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
32888 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
32889 AUWIM=0D0
32890 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
32891 A4IM=0D0
32892 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
32893 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
32894 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
32895 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
32896 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
32897 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
32898 & (ATWIM+AUWIM+A4IM)**2)
32899
32900 ELSE
32901C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32902 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
32903 & ABS(A00U-A20U)**2
32904 ENDIF
32905 FACWW=FACWW*WIDS(24,1)
32906
32907 DO 240 I=MMIN1,MMAX1
32908 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
32909 EI=KCHG(IABS(I),1)/3D0
32910 AI=SIGN(1D0,EI)
32911 VI=AI-4D0*EI*XWV
32912 AVI=AI**2+VI**2
32913 DO 230 J=MMIN2,MMAX2
32914 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
32915 EJ=KCHG(IABS(J),1)/3D0
32916 AJ=SIGN(1D0,EJ)
32917 VJ=AJ-4D0*EJ*XWV
32918 AVJ=AJ**2+VJ**2
32919 NCHN=NCHN+1
32920 ISIG(NCHN,1)=I
32921 ISIG(NCHN,2)=J
32922 ISIG(NCHN,3)=1
32923 SIGH(NCHN)=FACWW*AVI*AVJ
32924 230 CONTINUE
32925 240 CONTINUE
32926 250 CONTINUE
32927
32928 ELSEIF(ISUB.EQ.73) THEN
32929C...Z0 + W+/- -> Z0 + W+/-
32930 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
32931
32932 IF(MSTP(46).LE.2) THEN
32933C...Exact scattering ME:s for on-mass-shell gauge bosons
32934 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
32935 EP1=1D0-(SQMZ-SQMW)/SH
32936 EP2=1D0+(SQMZ-SQMW)/SH
32937 TH=-0.5D0*SH*BE2*(1D0-CTH)
32938 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
32939 IF(MAX(TH,UH).GT.-1D0) GOTO 280
32940 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
32941 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
32942 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
32943 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
32944 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
32945 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
32946 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
32947 ASWIM=0D0
32948 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
32949 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
32950 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
32951 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
32952 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
32953 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
32954 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
32955 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
32956 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
32957 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
32958 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
32959 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
32960 AUWIM=0D0
32961 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
32962 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
32963 A4IM=0D0
32964 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
32965 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
32966 IF(MSTP(46).LE.0) FACZW=0D0
32967 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
32968 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
32969 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
32970 & (ASWIM+AUWIM+A4IM)**2)
32971
32972 ELSE
32973C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
32974 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
32975 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
32976 ENDIF
32977 FACZW=FACZW*WIDS(23,2)
32978
32979 DO 270 I=MMIN1,MMAX1
32980 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
32981 EI=KCHG(IABS(I),1)/3D0
32982 AI=SIGN(1D0,EI)
32983 VI=AI-4D0*EI*XWV
32984 AVI=AI**2+VI**2
32985 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
32986 DO 260 J=MMIN2,MMAX2
32987 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
32988 EJ=KCHG(IABS(J),1)/3D0
32989 AJ=SIGN(1D0,EJ)
32990 VJ=AI-4D0*EJ*XWV
32991 AVJ=AJ**2+VJ**2
32992 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
32993 NCHN=NCHN+1
32994 ISIG(NCHN,1)=I
32995 ISIG(NCHN,2)=J
32996 ISIG(NCHN,3)=1
32997 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
32998 NCHN=NCHN+1
32999 ISIG(NCHN,1)=I
33000 ISIG(NCHN,2)=J
33001 ISIG(NCHN,3)=2
33002 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33003 260 CONTINUE
33004 270 CONTINUE
33005 280 CONTINUE
33006
33007 ELSEIF(ISUB.EQ.75) THEN
33008C...W+ + W- -> gamma + gamma
33009
33010 ELSEIF(ISUB.EQ.76) THEN
33011C...W+ + W- -> Z0 + Z0
33012 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33013
33014 IF(MSTP(46).LE.2) THEN
33015C...Exact scattering ME:s for on-mass-shell gauge bosons
33016 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33017 CTH2=CTH**2
33018 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33019 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33020 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33021 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33022 & (1D0-2D0*SQMZ/SH)
33023 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33024 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33025 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33026 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33027 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33028 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33029 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33030 ATWIM=0D0
33031 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33032 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33033 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33034 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33035 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33036 AUWIM=0D0
33037 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33038 A4IM=0D0
33039 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33040 & (SH/SQMW)**2*SH2
33041 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33042 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33043 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33044 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33045 & (ATWIM+AUWIM+A4IM)**2)
33046
33047 ELSE
33048C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33049 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33050 & ABS(A00U-A20U)**2
33051 ENDIF
33052 FACZZ=FACZZ*WIDS(23,1)
33053
33054 DO 300 I=MMIN1,MMAX1
33055 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33056 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33057 DO 290 J=MMIN2,MMAX2
33058 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33059 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33060 IF(EI*EJ.GT.0D0) GOTO 290
33061 NCHN=NCHN+1
33062 ISIG(NCHN,1)=I
33063 ISIG(NCHN,2)=J
33064 ISIG(NCHN,3)=1
33065 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33066 290 CONTINUE
33067 300 CONTINUE
33068 310 CONTINUE
33069
33070 ELSEIF(ISUB.EQ.77) THEN
33071C...W+/- + W+/- -> W+/- + W+/-
33072 IF(SH.LE.4.01D0*SQMW) GOTO 340
33073
33074 IF(MSTP(46).LE.2) THEN
33075C...Exact scattering ME:s for on-mass-shell gauge bosons
33076 BE2=1D0-4D0*SQMW/SH
33077 BE4=BE2**2
33078 CTH2=CTH**2
33079 CTH3=CTH**3
33080 TH=-0.5D0*SH*BE2*(1D0-CTH)
33081 UH=-0.5D0*SH*BE2*(1D0+CTH)
33082 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33083 SHANG=(1D0+BE2)**2
33084 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33085 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33086 THANG=(BE2-CTH)**2
33087 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33088 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33089 UHANG=(BE2+CTH)**2
33090 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33091 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33092 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33093 ASGRE=XW*SGZANG
33094 ASGIM=0D0
33095 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33096 ASZIM=0D0
33097 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33098 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33099 ATGRE=0.5D0*XW*SH/TH*TGZANG
33100 ATGIM=0D0
33101 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33102 ATZIM=0D0
33103 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33104 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33105 AUGRE=0.5D0*XW*SH/UH*UGZANG
33106 AUGIM=0D0
33107 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33108 AUZIM=0D0
33109 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33110 A4AIM=0D0
33111 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33112 A4SIM=0D0
33113 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33114 & (SH/SQMW)**2*SH2
33115 IF(MSTP(46).LE.0) THEN
33116 AWWARE=ASHRE
33117 AWWAIM=ASHIM
33118 AWWSRE=0D0
33119 AWWSIM=0D0
33120 ELSEIF(MSTP(46).EQ.1) THEN
33121 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33122 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33123 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33124 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33125 ELSE
33126 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33127 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33128 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33129 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33130 ENDIF
33131 AWWA2=AWWARE**2+AWWAIM**2
33132 AWWS2=AWWSRE**2+AWWSIM**2
33133
33134 ELSE
33135C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33136 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33137 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
33138 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
33139 ENDIF
33140
33141 DO 330 I=MMIN1,MMAX1
33142 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
33143 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33144 DO 320 J=MMIN2,MMAX2
33145 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
33146 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33147 IF(EI*EJ.LT.0D0) THEN
33148C...W+W-
33149 IF(MSTP(45).EQ.1) GOTO 320
33150 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
33151 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
33152 ELSE
33153C...W+W+/W-W-
33154 IF(MSTP(45).EQ.2) GOTO 320
33155 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
33156 IF(MSTP(46).GE.3) FACWW=FWWS
33157 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
33158 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
33159 ENDIF
33160 NCHN=NCHN+1
33161 ISIG(NCHN,1)=I
33162 ISIG(NCHN,2)=J
33163 ISIG(NCHN,3)=1
33164 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
33165 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
33166 320 CONTINUE
33167 330 CONTINUE
33168 340 CONTINUE
33169 ENDIF
33170
33171 ELSEIF(ISUB.LE.120) THEN
33172 IF(ISUB.EQ.102) THEN
33173C...g + g -> h0 (or H0, or A0)
33174 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33175 WDTP13=0D0
33176 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33177 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33178 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33179 345 CONTINUE
33180 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33181 & '(PYSGHG:) did not find Higgs -> g g channel')
33182 HS=SHR*WDTP(0)
33183 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33184 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33185 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33186 & FACBW=0D0
33187 HI=SHR*WDTP13/32D0
33188 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
33189 NCHN=NCHN+1
33190 ISIG(NCHN,1)=21
33191 ISIG(NCHN,2)=21
33192 ISIG(NCHN,3)=1
33193 SIGH(NCHN)=HI*FACBW*HF
33194 350 CONTINUE
33195
33196 ELSEIF(ISUB.EQ.103) THEN
33197C...gamma + gamma -> h0 (or H0, or A0)
33198 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33199 WDTP14=0D0
33200 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33201 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
33202 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
33203 355 CONTINUE
33204 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
33205 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
33206 HS=SHR*WDTP(0)
33207 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33208 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33209 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33210 & FACBW=0D0
33211 HI=SHR*WDTP14*2D0
33212 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
33213 NCHN=NCHN+1
33214 ISIG(NCHN,1)=22
33215 ISIG(NCHN,2)=22
33216 ISIG(NCHN,3)=1
33217 SIGH(NCHN)=HI*FACBW*HF
33218 360 CONTINUE
33219
33220 ELSEIF(ISUB.EQ.110) THEN
33221C...f + fbar -> gamma + h0
33222 THUH=MAX(TH*UH,SH*CKIN(3)**2)
33223 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
33224 FACHG=FACHG*WIDS(KFHIGG,2)
33225C...Calculate loop contributions for intermediate gamma* and Z0
33226 CIGTOT=DCMPLX(0D0,0D0)
33227 CIZTOT=DCMPLX(0D0,0D0)
33228 JMAX=3*MSTP(1)+1
33229 DO 370 J=1,JMAX
33230 IF(J.LE.2*MSTP(1)) THEN
33231 FNC=1D0
33232 EJ=KCHG(J,1)/3D0
33233 AJ=SIGN(1D0,EJ+0.1D0)
33234 VJ=AJ-4D0*EJ*XWV
33235 BALP=SQM4/(2D0*PMAS(J,1))**2
33236 BBET=SH/(2D0*PMAS(J,1))**2
33237 ELSEIF(J.LE.3*MSTP(1)) THEN
33238 FNC=3D0
33239 JL=2*(J-2*MSTP(1))-1
33240 EJ=KCHG(10+JL,1)/3D0
33241 AJ=SIGN(1D0,EJ+0.1D0)
33242 VJ=AJ-4D0*EJ*XWV
33243 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
33244 BBET=SH/(2D0*PMAS(10+JL,1))**2
33245 ELSE
33246 BALP=SQM4/(2D0*PMAS(24,1))**2
33247 BBET=SH/(2D0*PMAS(24,1))**2
33248 ENDIF
33249 BABI=1D0/(BALP-BBET)
33250 IF(BALP.LT.1D0) THEN
33251 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
33252 F1ALP=F0ALP**2
33253 ELSE
33254 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
33255 & -DBLE(0.5D0*PARU(1)))
33256 F1ALP=-F0ALP**2
33257 ENDIF
33258 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
33259 IF(BBET.LT.1D0) THEN
33260 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
33261 F1BET=F0BET**2
33262 ELSE
33263 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
33264 & -DBLE(0.5D0*PARU(1)))
33265 F1BET=-F0BET**2
33266 ENDIF
33267 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
33268 IF(J.LE.3*MSTP(1)) THEN
33269 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
33270 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
33271 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
33272 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
33273 ELSE
33274 TXW=XW/XW1
33275 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
33276 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
33277 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
33278 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
33279 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
33280 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
33281 & (F1BET-F1ALP))
33282 ENDIF
33283 370 CONTINUE
33284 CIGTOT=CIGTOT/DBLE(SH)
33285 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
33286C...Loop over initial flavours
33287 DO 380 I=MMINA,MMAXA
33288 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
33289 EI=KCHG(IABS(I),1)/3D0
33290 AI=SIGN(1D0,EI)
33291 VI=AI-4D0*EI*XWV
33292 FCOI=1D0
33293 IF(IABS(I).LE.10) FCOI=FACA/3D0
33294 NCHN=NCHN+1
33295 ISIG(NCHN,1)=I
33296 ISIG(NCHN,2)=-I
33297 ISIG(NCHN,3)=1
33298 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
33299 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
33300 380 CONTINUE
33301
33302 ELSEIF(ISUB.EQ.111) THEN
33303C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
33304 IF(MSTP(38).NE.0) THEN
33305C...Simple case: only do gg <-> h exactly.
33306 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33307 WDTP13=0D0
33308 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33309 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33310 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33311 385 CONTINUE
33312 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33313 & '(PYSGHG:) did not find Higgs -> g g channel')
33314 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
33315 & (TH**2+UH**2)/(SH*SQM4)
33316C...Propagators: as simulated in PYOFSH and as desired
33317 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33318 GMMHC=SQRT(SQM4)*WDTP(0)
33319 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33320 & ((SQM4-SQMH)**2+GMMHC**2)
33321 FACGH=FACGH*HBW4C/HBW4
33322 ELSE
33323C...Messy case: do full loop integrals
33324 A5STUR=0D0
33325 A5STUI=0D0
33326 DO 390 I=1,2*MSTP(1)
33327 SQMQ=PMAS(I,1)**2
33328 EPSS=4D0*SQMQ/SH
33329 EPSH=4D0*SQMQ/SQMH
33330 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33331 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33332 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33333 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33334 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
33335 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
33336 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
33337 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
33338 390 CONTINUE
33339 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33340 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
33341 FACGH=FACGH*WIDS(25,2)
33342 ENDIF
33343 DO 400 I=MMINA,MMAXA
33344 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33345 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
33346 NCHN=NCHN+1
33347 ISIG(NCHN,1)=I
33348 ISIG(NCHN,2)=-I
33349 ISIG(NCHN,3)=1
33350 SIGH(NCHN)=FACGH
33351 400 CONTINUE
33352
33353 ELSEIF(ISUB.EQ.112) THEN
33354C...f + g -> f + h0 (q + g -> q + h0 only)
33355 IF(MSTP(38).NE.0) THEN
33356C...Simple case: only do gg <-> h exactly.
33357 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33358 WDTP13=0D0
33359 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33360 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33361 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33362 405 CONTINUE
33363 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33364 & '(PYSGHG:) did not find Higgs -> g g channel')
33365 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
33366 & (SH**2+UH**2)/(-TH*SQM4)
33367C...Propagators: as simulated in PYOFSH and as desired
33368 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33369 GMMHC=SQRT(SQM4)*WDTP(0)
33370 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33371 & ((SQM4-SQMH)**2+GMMHC**2)
33372 FACQH=FACQH*HBW4C/HBW4
33373 ELSE
33374C...Messy case: do full loop integrals
33375 A5TSUR=0D0
33376 A5TSUI=0D0
33377 DO 410 I=1,2*MSTP(1)
33378 SQMQ=PMAS(I,1)**2
33379 EPST=4D0*SQMQ/TH
33380 EPSH=4D0*SQMQ/SQMH
33381 CALL PYWAUX(1,EPST,W1TR,W1TI)
33382 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33383 CALL PYWAUX(2,EPST,W2TR,W2TI)
33384 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33385 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
33386 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
33387 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
33388 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
33389 410 CONTINUE
33390 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
33391 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
33392 FACQH=FACQH*WIDS(25,2)
33393 ENDIF
33394 DO 430 I=MMINA,MMAXA
33395 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
33396 DO 420 ISDE=1,2
33397 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
33398 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
33399 NCHN=NCHN+1
33400 ISIG(NCHN,ISDE)=I
33401 ISIG(NCHN,3-ISDE)=21
33402 ISIG(NCHN,3)=1
33403 SIGH(NCHN)=FACQH
33404 420 CONTINUE
33405 430 CONTINUE
33406
33407 ELSEIF(ISUB.EQ.113) THEN
33408C...g + g -> g + h0
33409 IF(MSTP(38).NE.0) THEN
33410C...Simple case: only do gg <-> h exactly.
33411 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33412 WDTP13=0D0
33413 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
33414 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
33415 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
33416 435 CONTINUE
33417 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
33418 & '(PYSGHG:) did not find Higgs -> g g channel')
33419 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
33420 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
33421C...Propagators: as simulated in PYOFSH and as desired
33422 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33423 GMMHC=SQRT(SQM4)*WDTP(0)
33424 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
33425 & ((SQM4-SQMH)**2+GMMHC**2)
33426 FACGH=FACGH*HBW4C/HBW4
33427 ELSE
33428C...Messy case: do full loop integrals
33429 A2STUR=0D0
33430 A2STUI=0D0
33431 A2USTR=0D0
33432 A2USTI=0D0
33433 A2TUSR=0D0
33434 A2TUSI=0D0
33435 A4STUR=0D0
33436 A4STUI=0D0
33437 DO 440 I=1,2*MSTP(1)
33438 SQMQ=PMAS(I,1)**2
33439 EPSS=4D0*SQMQ/SH
33440 EPST=4D0*SQMQ/TH
33441 EPSU=4D0*SQMQ/UH
33442 EPSH=4D0*SQMQ/SQMH
33443 IF(EPSH.LT.1D-6) GOTO 440
33444 CALL PYWAUX(1,EPSS,W1SR,W1SI)
33445 CALL PYWAUX(1,EPST,W1TR,W1TI)
33446 CALL PYWAUX(1,EPSU,W1UR,W1UI)
33447 CALL PYWAUX(1,EPSH,W1HR,W1HI)
33448 CALL PYWAUX(2,EPSS,W2SR,W2SI)
33449 CALL PYWAUX(2,EPST,W2TR,W2TI)
33450 CALL PYWAUX(2,EPSU,W2UR,W2UI)
33451 CALL PYWAUX(2,EPSH,W2HR,W2HI)
33452 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
33453 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
33454 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
33455 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
33456 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
33457 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
33458 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
33459 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
33460 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
33461 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
33462 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
33463 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
33464 W3STUR=YHSTUR-Y3STUR-Y3UTSR
33465 W3STUI=YHSTUI-Y3STUI-Y3UTSI
33466 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
33467 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
33468 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
33469 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
33470 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
33471 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
33472 W3USTR=YHUSTR-Y3USTR-Y3TSUR
33473 W3USTI=YHUSTI-Y3USTI-Y3TSUI
33474 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
33475 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
33476 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
33477 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
33478 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
33479 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
33480 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
33481 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
33482 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
33483 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
33484 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
33485 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
33486 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
33487 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
33488 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
33489 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
33490 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
33491 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
33492 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
33493 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
33494 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
33495 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
33496 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
33497 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
33498 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
33499 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
33500 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
33501 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
33502 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
33503 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
33504 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
33505 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
33506 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
33507 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
33508 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
33509 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
33510 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
33511 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
33512 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
33513 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
33514 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
33515 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
33516 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
33517 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
33518 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
33519 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
33520 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
33521 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
33522 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
33523 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
33524 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
33525 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
33526 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
33527 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
33528 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
33529 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
33530 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
33531 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
33532 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
33533 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
33534 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
33535 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
33536 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33537 & (W2SR-W2HR+W3STUR))
33538 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
33539 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33540 & (W2TR-W2HR+W3TUSR))
33541 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
33542 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
33543 & (W2UR-W2HR+W3USTR))
33544 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
33545 A2STUR=A2STUR+B2STUR+B2SUTR
33546 A2STUI=A2STUI+B2STUI+B2SUTI
33547 A2USTR=A2USTR+B2USTR+B2UTSR
33548 A2USTI=A2USTI+B2USTI+B2UTSI
33549 A2TUSR=A2TUSR+B2TUSR+B2TSUR
33550 A2TUSI=A2TUSI+B2TUSI+B2TSUI
33551 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
33552 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
33553 440 CONTINUE
33554 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
33555 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
33556 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
33557 FACGH=FACGH*WIDS(25,2)
33558 ENDIF
33559 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
33560 NCHN=NCHN+1
33561 ISIG(NCHN,1)=21
33562 ISIG(NCHN,2)=21
33563 ISIG(NCHN,3)=1
33564 SIGH(NCHN)=FACGH
33565 450 CONTINUE
33566 ENDIF
33567
33568 ELSEIF(ISUB.LE.170) THEN
33569 IF(ISUB.EQ.121) THEN
33570C...g + g -> Q + Qbar + h0
33571 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
33572 IA=KFPR(ISUBSV,2)
33573 PMF=PYMRUN(IA,SH)
33574 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33575 & (0.5D0*PMF/PMAS(24,1))**2
33576 WID2=1D0
33577 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33578 FACQQH=FACQQH*WID2
33579 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33580 IKFI=1
33581 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33582 IF(IA.GT.10) IKFI=3
33583 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33584 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33585 FACQQH=FACQQH/(1D0+RMSS(41))**2
33586 IF(IHIGG.NE.3) THEN
33587 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33588 & PARU(151+10*IHIGG))**2
33589 ENDIF
33590 ENDIF
33591 ENDIF
33592 CALL PYQQBH(WTQQBH)
33593 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33594 HS=SHR*WDTP(0)
33595 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33596 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33597 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33598 & FACBW=0D0
33599 NCHN=NCHN+1
33600 ISIG(NCHN,1)=21
33601 ISIG(NCHN,2)=21
33602 ISIG(NCHN,3)=1
33603 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33604 460 CONTINUE
33605
33606 ELSEIF(ISUB.EQ.122) THEN
33607C...q + qbar -> Q + Qbar + h0
33608 IA=KFPR(ISUBSV,2)
33609 PMF=PYMRUN(IA,SH)
33610 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
33611 & (0.5D0*PMF/PMAS(24,1))**2
33612 WID2=1D0
33613 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
33614 FACQQH=FACQQH*WID2
33615 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33616 IKFI=1
33617 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33618 IF(IA.GT.10) IKFI=3
33619 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
33620 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33621 FACQQH=FACQQH/(1D0+RMSS(41))**2
33622 IF(IHIGG.NE.3) THEN
33623 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33624 & PARU(151+10*IHIGG))**2
33625 ENDIF
33626 ENDIF
33627 ENDIF
33628 CALL PYQQBH(WTQQBH)
33629 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33630 HS=SHR*WDTP(0)
33631 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33632 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33633 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33634 & FACBW=0D0
33635 DO 470 I=MMINA,MMAXA
33636 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33637 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
33638 NCHN=NCHN+1
33639 ISIG(NCHN,1)=I
33640 ISIG(NCHN,2)=-I
33641 ISIG(NCHN,3)=1
33642 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
33643 470 CONTINUE
33644
33645 ELSEIF(ISUB.EQ.123) THEN
33646C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
33647C...inner process)
33648 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
33649 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33650 & PARU(154+10*IHIGG)**2
33651 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33652 & (VINT(216)-VINT(209)**2))**2
33653 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33654 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
33655 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33656 HS=SHR*WDTP(0)
33657 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33658 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33659 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33660 & FACBW=0D0
33661 DO 490 I=MMIN1,MMAX1
33662 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
33663 IA=IABS(I)
33664 DO 480 J=MMIN2,MMAX2
33665 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
33666 JA=IABS(J)
33667 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
33668 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
33669 VI=AI-4D0*EI*XWV
33670 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
33671 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
33672 VJ=AJ-4D0*EJ*XWV
33673 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
33674 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
33675 NCHN=NCHN+1
33676 ISIG(NCHN,1)=I
33677 ISIG(NCHN,2)=J
33678 ISIG(NCHN,3)=1
33679 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
33680 480 CONTINUE
33681 490 CONTINUE
33682
33683 ELSEIF(ISUB.EQ.124) THEN
33684C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
33685C...inner process)
33686 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
33687 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
33688 & PARU(155+10*IHIGG)**2
33689 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
33690 & (VINT(216)-VINT(209)**2))**2
33691 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
33692 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33693 HS=SHR*WDTP(0)
33694 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33695 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
33696 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33697 & FACBW=0D0
33698 DO 510 I=MMIN1,MMAX1
33699 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
33700 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33701 DO 500 J=MMIN2,MMAX2
33702 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
33703 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33704 IF(EI*EJ.GT.0D0) GOTO 500
33705 FACLR=VINT(180+I)*VINT(180+J)
33706 NCHN=NCHN+1
33707 ISIG(NCHN,1)=I
33708 ISIG(NCHN,2)=J
33709 ISIG(NCHN,3)=1
33710 SIGH(NCHN)=FACLR*FACWW*FACBW
33711 500 CONTINUE
33712 510 CONTINUE
33713
33714 ELSEIF(ISUB.EQ.143) THEN
33715C...f + fbar' -> H+/-
33716 SQMHC=PMAS(37,1)**2
33717 CALL PYWIDT(37,SH,WDTP,WDTE)
33718 HS=SHR*WDTP(0)
33719 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
33720 HP=AEM/(8D0*XW)*SH/SQMW*SH
33721 DO 530 I=MMIN1,MMAX1
33722 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
33723 IA=IABS(I)
33724 IM=(MOD(IA,10)+1)/2
33725 DO 520 J=MMIN2,MMAX2
33726 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
33727 JA=IABS(J)
33728 JM=(MOD(JA,10)+1)/2
33729 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
33730 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33731 & GOTO 520
33732 IF(MOD(IA,2).EQ.0) THEN
33733 IU=IA
33734 IL=JA
33735 ELSE
33736 IU=JA
33737 IL=IA
33738 ENDIF
33739 RML=PYMRUN(IL,SH)**2/SH
33740 RMU=PYMRUN(IU,SH)**2/SH
33741 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
33742 IF(IA.LE.10) HI=HI*FACA/3D0
33743 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33744 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
33745 NCHN=NCHN+1
33746 ISIG(NCHN,1)=I
33747 ISIG(NCHN,2)=J
33748 ISIG(NCHN,3)=1
33749 SIGH(NCHN)=HI*FACBW*HF
33750 520 CONTINUE
33751 530 CONTINUE
33752
33753 ELSEIF(ISUB.EQ.161) THEN
33754C...f + g -> f' + H+/- (b + g -> t + H+/- only)
33755C...(choice of only b and t to avoid kinematics problems)
33756 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
33757C...H propagator: as simulated in PYOFSH and as desired
33758 SQMHC=PMAS(37,1)**2
33759 GMMHC=PMAS(37,1)*PMAS(37,2)
33760 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33761 CALL PYWIDT(37,SQM4,WDTP,WDTE)
33762 GMMHCC=SQRT(SQM4)*WDTP(0)
33763 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33764 FHCQ=FHCQ*HBW4C/HBW4
33765 Q2RM=SH
33766 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
33767 DO 550 I=MMINA,MMAXA
33768 IA=IABS(I)
33769 IF(IA.NE.5) GOTO 550
33770 SQML=PYMRUN(IA,Q2RM)**2
33771 IUA=IA+MOD(IA,2)
33772 SQMQ=PYMRUN(IUA,Q2RM)**2
33773 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
33774 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33775 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
33776 & (SQMHC-SQMQ-SH)/SH)
33777 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33778 DO 540 ISDE=1,2
33779 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
33780 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
33781 NCHN=NCHN+1
33782 ISIG(NCHN,ISDE)=I
33783 ISIG(NCHN,3-ISDE)=21
33784 ISIG(NCHN,3)=1
33785 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
33786 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
33787 540 CONTINUE
33788 550 CONTINUE
33789 ENDIF
33790
33791 ELSEIF(ISUB.LE.402) THEN
33792 IF(ISUB.EQ.401) THEN
33793C... g + g -> t + bbar + H-
33794 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
33795 IA=KFPR(ISUBSV,2)
33796 CALL PYSTBH(WTTBH)
33797 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33798 HS=SHR*WDTP(0)
33799 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33800 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33801 & FACBW=0D0
33802 NCHN=NCHN+1
33803 ISIG(NCHN,1)=21
33804 ISIG(NCHN,2)=21
33805 ISIG(NCHN,3)=1
33806 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33807c Since we don't know yet if H+ or H-, assume H+
33808c when calculating suppression due to closed channels.
33809 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33810 IF(ABS(WIDS(37,2)-WIDS(37,3))
33811 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
33812 & ABS(WIDS(6,2)-WIDS(6,3))
33813 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
33814 WRITE(*,*)'Error: Process 401 cannot handle different'
33815 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33816 WRITE(*,*)'Execution stopped.'
33817 CALL PYSTOP(108)
33818 END IF
33819 560 CONTINUE
33820
33821 ELSEIF(ISUB.EQ.402) THEN
33822C... q + qbar -> t + bbar + H-
33823 IA=KFPR(ISUBSV,2)
33824 CALL PYSTBH(WTTBH)
33825 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33826 HS=SHR*WDTP(0)
33827 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
33828 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33829 & FACBW=0D0
33830 DO 570 I=MMINA,MMAXA
33831 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33832 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
33833 NCHN=NCHN+1
33834 ISIG(NCHN,1)=I
33835 ISIG(NCHN,2)=-I
33836 ISIG(NCHN,3)=1
33837 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
33838c Since we don't know yet if H+ or H-, assume H+
33839c when calculating suppression due to closed channels.
33840 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
33841 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
33842 & .GE.1D-6.OR.
33843 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
33844 & .GE.1D-6) THEN
33845 WRITE(*,*)'Error: Process 402 cannot handle different'
33846 WRITE(*,*)'decays for H+ and H- or t and tbar.'
33847 WRITE(*,*)'Execution stopped.'
33848 CALL PYSTOP(108)
33849 END IF
33850 570 CONTINUE
33851 ENDIF
33852 ENDIF
33853
33854 RETURN
33855 END
33856
33857C*********************************************************************
33858
33859C...PYSGSU
33860C...Subprocess cross sections for SUSY processes,
33861C...including Higgs pair production.
33862C...Auxiliary to PYSIGH.
33863
33864 SUBROUTINE PYSGSU(NCHN,SIGS)
33865
33866C...Double precision and integer declarations
33867 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33868 IMPLICIT INTEGER(I-N)
33869 INTEGER PYK,PYCHGE,PYCOMP
33870C...Parameter statement to help give large particle numbers.
33871 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33872 &KEXCIT=4000000,KDIMEN=5000000)
33873C...Commonblocks
33874 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33875 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33876 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33877 COMMON/PYINT1/MINT(400),VINT(400)
33878 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33879 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33880 COMMON/PYINT4/MWID(500),WIDS(500,5)
33881 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33882 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
33883 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
33884 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33885 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33886 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33887 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33888 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
33889 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
33890C...Local arrays and complex variables
33891 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33892 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
33893 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
33894 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
33895
33896CMRENNA++
33897C...Z and W width, combinations of weak mixing angle
33898 ZWID=PMAS(23,2)
33899 WWID=PMAS(24,2)
33900 TANW=SQRT(XW/XW1)
33901 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
33902
33903C...Convert almost equivalent SUSY processes into each other
33904C...Extract differences in flavours and couplings
33905
33906C...Sleptons and sneutrinos
33907 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
33908 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33909 ISUB=201
33910 ILR=0
33911 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
33912 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33913 ISUB=201
33914 ILR=1
33915 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
33916 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33917 ISUB=203
33918 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
33919 IF(ISUB.EQ.210) THEN
33920 RKF=2.0D0
33921 ELSEIF(ISUB.EQ.211) THEN
33922 RKF=SFMIX(15,1)**2
33923 ELSEIF(ISUB.EQ.212) THEN
33924 RKF=SFMIX(15,2)**2
33925 ENDIF
33926 ISUB=210
33927 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
33928 IF(ISUB.EQ.213) THEN
33929 KFID=MOD(KFPR(ISUB,1),KSUSY1)
33930 RKF=2.0D0
33931 ELSEIF(ISUB.EQ.214) THEN
33932 KFID=16
33933 RKF=1.0D0
33934 ENDIF
33935 ISUB=213
33936
33937C...Neutralinos
33938 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
33939 IF(ISUB.EQ.216) THEN
33940 IZID1=1
33941 IZID2=1
33942 ELSEIF(ISUB.EQ.217) THEN
33943 IZID1=2
33944 IZID2=2
33945 ELSEIF(ISUB.EQ.218) THEN
33946 IZID1=3
33947 IZID2=3
33948 ELSEIF(ISUB.EQ.219) THEN
33949 IZID1=4
33950 IZID2=4
33951 ELSEIF(ISUB.EQ.220) THEN
33952 IZID1=1
33953 IZID2=2
33954 ELSEIF(ISUB.EQ.221) THEN
33955 IZID1=1
33956 IZID2=3
33957 ELSEIF(ISUB.EQ.222) THEN
33958 IZID1=1
33959 IZID2=4
33960 ELSEIF(ISUB.EQ.223) THEN
33961 IZID1=2
33962 IZID2=3
33963 ELSEIF(ISUB.EQ.224) THEN
33964 IZID1=2
33965 IZID2=4
33966 ELSEIF(ISUB.EQ.225) THEN
33967 IZID1=3
33968 IZID2=4
33969 ENDIF
33970 ISUB=216
33971
33972C...Charginos
33973 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
33974 IF(ISUB.EQ.226) THEN
33975 IZID1=1
33976 IZID2=1
33977 ELSEIF(ISUB.EQ.227) THEN
33978 IZID1=2
33979 IZID2=2
33980 ELSEIF(ISUB.EQ.228) THEN
33981 IZID1=1
33982 IZID2=2
33983 ENDIF
33984 ISUB=226
33985
33986C...Neutralino + chargino
33987 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
33988 IF(ISUB.EQ.229) THEN
33989 IZID1=1
33990 IZID2=1
33991 ELSEIF(ISUB.EQ.230) THEN
33992 IZID1=1
33993 IZID2=2
33994 ELSEIF(ISUB.EQ.231) THEN
33995 IZID1=1
33996 IZID2=3
33997 ELSEIF(ISUB.EQ.232) THEN
33998 IZID1=1
33999 IZID2=4
34000 ELSEIF(ISUB.EQ.233) THEN
34001 IZID1=2
34002 IZID2=1
34003 ELSEIF(ISUB.EQ.234) THEN
34004 IZID1=2
34005 IZID2=2
34006 ELSEIF(ISUB.EQ.235) THEN
34007 IZID1=2
34008 IZID2=3
34009 ELSEIF(ISUB.EQ.236) THEN
34010 IZID1=2
34011 IZID2=4
34012 ENDIF
34013 ISUB=229
34014
34015C...Gluino + neutralino
34016 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34017 IF(ISUB.EQ.237) THEN
34018 IZID=1
34019 ELSEIF(ISUB.EQ.238) THEN
34020 IZID=2
34021 ELSEIF(ISUB.EQ.239) THEN
34022 IZID=3
34023 ELSEIF(ISUB.EQ.240) THEN
34024 IZID=4
34025 ENDIF
34026 ISUB=237
34027
34028C...Gluino + chargino
34029 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34030 IF(ISUB.EQ.241) THEN
34031 IZID=1
34032 ELSEIF(ISUB.EQ.242) THEN
34033 IZID=2
34034 ENDIF
34035 ISUB=241
34036
34037C...Squark + neutralino
34038 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34039 ILR=0
34040 IF(MOD(ISUB,2).NE.0) ILR=1
34041 IF(ISUB.LE.247) THEN
34042 IZID=1
34043 ELSEIF(ISUB.LE.249) THEN
34044 IZID=2
34045 ELSEIF(ISUB.LE.251) THEN
34046 IZID=3
34047 ELSEIF(ISUB.LE.253) THEN
34048 IZID=4
34049 ENDIF
34050 ISUB=246
34051 RKF=5D0
34052
34053C...Squark + chargino
34054 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34055 IF(ISUB.LE.255) THEN
34056 IZID=1
34057 ELSEIF(ISUB.LE.257) THEN
34058 IZID=2
34059 ENDIF
34060 IF(MOD(ISUB,2).EQ.0) THEN
34061 ILR=0
34062 ELSE
34063 ILR=1
34064 ENDIF
34065 ISUB=254
34066 RKF=5D0
34067
34068C...Squark + gluino
34069 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34070 ISUB=258
34071 RKF=4D0
34072
34073C...Stops
34074 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34075 ILR=0
34076 IF(ISUB.EQ.262) ILR=1
34077 ISUB=261
34078 ELSEIF(ISUB.EQ.265) THEN
34079 ISUB=264
34080
34081C...Squarks
34082 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34083 ILR=0
34084 IF(ISUB.LE.273) THEN
34085 IF(ISUB.EQ.273) ILR=1
34086 ISUB=271
34087 RKF=16D0
34088 ELSEIF(ISUB.LE.276) THEN
34089 IF(ISUB.EQ.276) ILR=1
34090 ISUB=274
34091 RKF=16D0
34092 ELSEIF(ISUB.LE.278) THEN
34093 IF(ISUB.EQ.278) ILR=1
34094 ISUB=277
34095 RKF=4D0
34096 ELSE
34097 IF(ISUB.EQ.280) ILR=1
34098 ISUB=279
34099 RKF=4D0
34100 ENDIF
34101C...Sbottoms
34102 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34103 ILR=0
34104 IF(ISUB.LE.283) THEN
34105 IF(ISUB.EQ.283) ILR=1
34106 ISUB=271
34107 RKF=4D0
34108 ELSEIF(ISUB.LE.286) THEN
34109 IF(ISUB.EQ.286) ILR=1
34110 ISUB=274
34111 RKF=4D0
34112 ELSEIF(ISUB.LE.288) THEN
34113 IF(ISUB.EQ.288) ILR=1
34114 ISUB=277
34115 RKF=1D0
34116 ELSEIF(ISUB.LE.290) THEN
34117 IF(ISUB.EQ.290) ILR=1
34118 ISUB=279
34119 RKF=1D0
34120 ELSEIF(ISUB.LE.293) THEN
34121 IF(ISUB.EQ.293) ILR=1
34122 ISUB=271
34123 RKF=1D0
34124 ELSEIF(ISUB.EQ.296) THEN
34125 ILR=1
34126 ISUB=274
34127 RKF=1D0
34128C...Squark + gluino
34129 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
34130 ISUB=258
34131 RKF=1D0
34132 ENDIF
34133C...H+/- + H0
34134 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
34135 IF(ISUB.EQ.297) THEN
34136 RKF=.5D0*PARU(195)**2
34137 ELSEIF(ISUB.EQ.298) THEN
34138 RKF=.5D0*(1D0-PARU(195)**2)
34139 ENDIF
34140 ISUB=210
34141C...A0 + H0
34142 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
34143 IF(ISUB.EQ.299) THEN
34144 RKF=PARU(186)**2
34145 KFID=25
34146 ELSEIF(ISUB.EQ.300) THEN
34147 RKF=PARU(187)**2
34148 KFID=35
34149 ENDIF
34150 ISUB=213
34151C...H+ + H-
34152 ELSEIF(ISUB.EQ.301) THEN
34153 KFID=37
34154 RKF=1D0
34155 ISUB=201
34156 ENDIF
34157
34158C...Supersymmetric processes - all of type 2 -> 2 :
34159C...correct final-state Breit-Wigners from fixed to running width.
34160 IF(MSTP(42).GT.0) THEN
34161 DO 100 I=1,2
34162 KFLW=KFPR(ISUBSV,I)
34163 KCW=PYCOMP(KFLW)
34164 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
34165 IF(I.EQ.1) SQMI=SQM3
34166 IF(I.EQ.2) SQMI=SQM4
34167 SQMS=PMAS(KCW,1)**2
34168 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
34169 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
34170 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
34171 GMMI=SQRT(SQMI)*WDTP(0)
34172 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
34173 COMFAC=COMFAC*(HBWI/HBWS)
34174 100 CONTINUE
34175 ENDIF
34176
34177C...Differential cross section expressions.
34178
34179 IF(ISUB.LE.210) THEN
34180 IF(ISUB.EQ.201) THEN
34181C...f + fbar -> e_L + e_Lbar
34182 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34183 DO 130 I=MMIN1,MMAX1
34184 IA=IABS(I)
34185 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
34186 EI=KCHG(IA,1)/3D0
34187 TT3I=SIGN(1D0,EI+1D-6)/2D0
34188 EJ=-1D0
34189 TT3J=-1D0/2D0
34190 FCOL=1D0
34191C...Color factor for e+ e-
34192 IF(IA.GE.11) FCOL=3D0
34193 IF(ISUBSV.EQ.301) THEN
34194 A1=1D0
34195 A2=0D0
34196 ELSEIF(ILR.EQ.1) THEN
34197 A1=SFMIX(KFID,3)**2
34198 A2=SFMIX(KFID,4)**2
34199 ELSEIF(ILR.EQ.0) THEN
34200 A1=SFMIX(KFID,1)**2
34201 A2=SFMIX(KFID,2)**2
34202 ENDIF
34203 XLQ=(TT3J-EJ*XW)*A1
34204 XRQ=(-EJ*XW)*A2
34205 XLF=(TT3I-EI*XW)
34206 XRF=(-EI*XW)
34207 TAA=(EI*EJ)**2*(POLL+POLR)
34208 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
34209 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
34210 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
34211 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34212 TNN=0.0D0
34213 TAN=0.0D0
34214 TZN=0.0D0
34215 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34216 FAC2=SQRT(2D0)
34217 TNN1=0D0
34218 TNN2=0D0
34219 TNN3=0D0
34220 DO 120 II=1,4
34221 DK=1D0/(TH-SMZ(II)**2)
34222 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34223 & ZMIX(II,1))
34224 FREK=FAC2*TANW*EI*ZMIX(II,1)
34225 TNN1=TNN1+FLEK**2*DK
34226 TNN2=TNN2+FREK**2*DK
34227 DO 110 JJ=1,4
34228 DL=1D0/(TH-SMZ(JJ)**2)
34229 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34230 & ZMIX(JJ,1))
34231 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34232 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34233 110 CONTINUE
34234 120 CONTINUE
34235 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
34236 & A2**2*TNN2**2*POLR)
34237 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
34238 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
34239 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
34240 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
34241 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34242 & (1D0-SQMZ/SH)/SH
34243 TZN=TZN/XW**2/XW1
34244 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
34245 & A2*TNN2*POLR)/XW
34246 ENDIF
34247 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
34248 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
34249 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
34250 NCHN=NCHN+1
34251 ISIG(NCHN,1)=I
34252 ISIG(NCHN,2)=-I
34253 ISIG(NCHN,3)=1
34254 SIGH(NCHN)=FACQQ1+FACQQ2
34255 130 CONTINUE
34256
34257 ELSEIF(ISUB.EQ.203) THEN
34258C...f + fbar -> e_L + e_Rbar
34259 DO 160 I=MMIN1,MMAX1
34260 IA=IABS(I)
34261 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
34262 EI=KCHG(IABS(I),1)/3D0
34263 TT3I=SIGN(1D0,EI)/2D0
34264 EJ=-1
34265 TT3J=-1D0/2D0
34266 FCOL=1D0
34267C...Color factor for e+ e-
34268 IF(IA.GE.11) FCOL=3D0
34269 A1=SFMIX(KFID,1)**2
34270 A2=SFMIX(KFID,2)**2
34271 XLQ=(TT3J-EJ*XW)
34272 XRQ=(-EJ*XW)
34273 XLF=(TT3I-EI*XW)
34274 XRF=(-EI*XW)
34275 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
34276 & /XW**2/XW1**2*A1*A2
34277 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34278 TNN=0.0D0
34279 TZN=0.0D0
34280 TNNA=0D0
34281 TNNB=0D0
34282 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
34283 FAC2=SQRT(2D0)
34284 TNN1=0D0
34285 TNN2=0D0
34286 TNN3=0D0
34287 DO 150 II=1,4
34288 DK=1D0/(TH-SMZ(II)**2)
34289 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
34290 & ZMIX(II,1))
34291 FREK=FAC2*TANW*EI*ZMIX(II,1)
34292 TNN1=TNN1+FLEK**2*DK
34293 TNN2=TNN2+FREK**2*DK
34294 DO 140 JJ=1,4
34295 DL=1D0/(TH-SMZ(JJ)**2)
34296 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
34297 & ZMIX(JJ,1))
34298 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
34299 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
34300 140 CONTINUE
34301 150 CONTINUE
34302 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
34303 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
34304 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
34305 TZN=(UH*TH-SQM3*SQM4)*A1*A2
34306 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
34307 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
34308 & (1D0-SQMZ/SH)/SH
34309 ENDIF
34310 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
34311 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
34312 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
34313C%%%%%%%%%%%
34314 NCHN=NCHN+1
34315 ISIG(NCHN,1)=I
34316 ISIG(NCHN,2)=-I
34317 ISIG(NCHN,3)=1
34318 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34319 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34320 NCHN=NCHN+1
34321 ISIG(NCHN,1)=I
34322 ISIG(NCHN,2)=-I
34323 ISIG(NCHN,3)=2
34324 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34325 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34326 160 CONTINUE
34327
34328 ELSEIF(ISUB.EQ.210) THEN
34329C...q + qbar' -> W*- > ~l_L + ~nu_L
34330 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
34331 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
34332 DO 180 I=MMIN1,MMAX1
34333 IA=IABS(I)
34334 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
34335 DO 170 J=MMIN2,MMAX2
34336 JA=IABS(J)
34337 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
34338 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
34339 FCKM=3D0
34340 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34341 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34342 KCHW=2
34343 IF(KCHSUM.LT.0) KCHW=3
34344 NCHN=NCHN+1
34345 ISIG(NCHN,1)=I
34346 ISIG(NCHN,2)=J
34347 ISIG(NCHN,3)=1
34348 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
34349 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34350 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34351 ELSE
34352 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
34353 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34354 ENDIF
34355 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
34356 170 CONTINUE
34357 180 CONTINUE
34358 ENDIF
34359
34360 ELSEIF(ISUB.LE.220) THEN
34361 IF(ISUB.EQ.213) THEN
34362C...f + fbar -> ~nu_L + ~nu_Lbar
34363 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
34364 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34365 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34366 ELSE
34367 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34368 ENDIF
34369 COMFAC=COMFAC*FACR
34370 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
34371 XLL=0.5D0
34372 XLR=0.0D0
34373 DO 190 I=MMIN1,MMAX1
34374 IA=IABS(I)
34375 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
34376 EI=KCHG(IA,1)/3D0
34377 FCOL=1D0
34378C...Color factor for e+ e-
34379 IF(IA.GE.11) FCOL=3D0
34380 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
34381 XRQ=-EI*XW
34382 TZC=0.0D0
34383 TCC=0.0D0
34384 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
34385 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
34386 & (TH-SMW(2)**2)
34387 TCC=TZC**2
34388 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
34389 ENDIF
34390 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
34391 FACQQ2=TZC+TCC/4D0
34392 NCHN=NCHN+1
34393 ISIG(NCHN,1)=I
34394 ISIG(NCHN,2)=-I
34395 ISIG(NCHN,3)=1
34396 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
34397 & *AEM**2*FCOL/3D0/XW**2
34398 190 CONTINUE
34399
34400 ELSEIF(ISUB.EQ.216) THEN
34401C...q + qbar -> ~chi0_1 + ~chi0_1
34402 IF(IZID1.EQ.IZID2) THEN
34403 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34404 ELSE
34405 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34406 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34407 ENDIF
34408 FACXX=COMFAC*AEM**2/3D0/XW**2
34409 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
34410 ZM12=SQM3
34411 ZM22=SQM4
34412 WU2 = (UH-ZM12)*(UH-ZM22)
34413 WT2 = (TH-ZM12)*(TH-ZM22)
34414 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
34415 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34416 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34417 DO 200 I=1,4
34418 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
34419 IF(IZID2.NE.IZID1) THEN
34420 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34421 ENDIF
34422 200 CONTINUE
34423 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
34424 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
34425 ORPP=DCONJG(OLPP)
34426 DO 210 I=MMINA,MMAXA
34427 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
34428 EI=KCHG(IABS(I),1)/3D0
34429 T3I=SIGN(1D0,EI+1D-6)/2D0
34430 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
34431 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
34432 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
34433 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
34434 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
34435 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
34436 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
34437 & /DCMPLX(TH-XML2)
34438 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
34439 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
34440 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
34441 FCOL=1D0
34442 IF(IABS(I).GE.11) FCOL=3D0
34443 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34444 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34445 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34446 & QRL*DCONJG(QRR)*POLR)*WS2
34447 NCHN=NCHN+1
34448 ISIG(NCHN,1)=I
34449 ISIG(NCHN,2)=-I
34450 ISIG(NCHN,3)=1
34451 SIGH(NCHN)=FACXX*FACGG1*FCOL
34452 210 CONTINUE
34453 ENDIF
34454
34455 ELSEIF(ISUB.LE.230) THEN
34456 IF(ISUB.EQ.226) THEN
34457C...f + fbar -> ~chi+_1 + ~chi-_1
34458 FACXX=COMFAC*AEM**2/3D0
34459 ZM12=SQM3
34460 ZM22=SQM4
34461 WU2 = (UH-ZM12)*(UH-ZM22)
34462 WT2 = (TH-ZM12)*(TH-ZM22)
34463 WS2 = SMW(IZID1)*SMW(IZID2)*SH
34464 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
34465 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
34466 DIFF=0D0
34467 IF(IZID1.EQ.IZID2) DIFF=1D0
34468 DO 220 I=1,2
34469 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34470 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34471 IF(IZID2.NE.IZID1) THEN
34472 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
34473 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
34474 ENDIF
34475 220 CONTINUE
34476 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
34477 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
34478 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
34479 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
34480 DO 230 I=MMINA,MMAXA
34481 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
34482 EI=KCHG(IABS(I),1)/3D0
34483 T3I=SIGN(1D0,EI+1D-6)/2D0
34484 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
34485 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
34486 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
34487 IF(MOD(I,2).EQ.0) THEN
34488 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
34489 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34490 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
34491 & DCMPLX(T3I/XW/(TH-XML2))
34492 ELSE
34493 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
34494 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
34495 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
34496 & DCMPLX(T3I/XW/(TH-XML2))
34497 ENDIF
34498 FCOL=1D0
34499 IF(IABS(I).GE.11) FCOL=3D0
34500 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
34501 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
34502 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
34503 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
34504 NCHN=NCHN+1
34505 ISIG(NCHN,1)=I
34506 ISIG(NCHN,2)=-I
34507 ISIG(NCHN,3)=1
34508 IF(IZID1.EQ.IZID2) THEN
34509 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34510 ELSE
34511 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34512 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34513 NCHN=NCHN+1
34514 ISIG(NCHN,1)=I
34515 ISIG(NCHN,2)=-I
34516 ISIG(NCHN,3)=2
34517 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34518 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34519 ENDIF
34520 230 CONTINUE
34521
34522 ELSEIF(ISUB.EQ.229) THEN
34523C...q + qbar' -> ~chi0_1 + ~chi+-_1
34524 FACXX=COMFAC*AEM**2/6D0/XW**2
34525 ZM12=SQM3
34526 ZM22=SQM4
34527 WU2 = (UH-ZM12)*(UH-ZM22)
34528 WT2 = (TH-ZM12)*(TH-ZM22)
34529 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
34530 RT2I = 1D0/SQRT(2D0)
34531 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
34532 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
34533 DO 240 I=1,2
34534 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
34535 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
34536 240 CONTINUE
34537 DO 250 I=1,4
34538 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
34539 250 CONTINUE
34540 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
34541 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
34542 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
34543 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
34544
34545 DO 270 I=MMIN1,MMAX1
34546 IA=IABS(I)
34547 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
34548 EI=KCHG(IA,1)/3D0
34549 T3I=SIGN(1D0,EI+1D-6)/2D0
34550 DO 260 J=MMIN2,MMAX2
34551 JA=IABS(J)
34552 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
34553 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
34554 EJ=KCHG(JA,1)/3D0
34555 T3J=SIGN(1D0,EJ+1D-6)/2D0
34556 FCKM=3D0
34557 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34558 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34559 KCHW=2
34560 IF(KCHSUM.LT.0) KCHW=3
34561 IF(MOD(IA,2).EQ.0) THEN
34562 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34563 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34564 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
34565 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
34566 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34567 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
34568 & /DCMPLX(TH-ZMJ2)
34569 ELSE
34570 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
34571 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
34572 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
34573 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
34574 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
34575 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
34576 & /DCMPLX(TH-ZMI2)
34577 ENDIF
34578 ZINTR=DBLE(QLR*DCONJG(QLL))
34579 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
34580 & 2D0*ZINTR*WS2)
34581 NCHN=NCHN+1
34582 ISIG(NCHN,1)=I
34583 ISIG(NCHN,2)=J
34584 ISIG(NCHN,3)=1
34585 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34586 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34587 260 CONTINUE
34588 270 CONTINUE
34589 ENDIF
34590
34591 ELSEIF(ISUB.LE.240) THEN
34592 IF(ISUB.EQ.237) THEN
34593C...q + qbar -> gluino + ~chi0_1
34594 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34595 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34596 ASYUK=RMSS(42)*AS
34597 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
34598 GM2=SQM3
34599 ZM2=SQM4
34600 DO 280 I=MMINA,MMAXA
34601 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
34602 EI=KCHG(IABS(I),1)/3D0
34603 IA=IABS(I)
34604 XLQC = -TANW*EI*ZMIX(IZID,1)
34605 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34606 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34607 XLQ2=XLQC**2
34608 XRQ2=XRQC**2
34609 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
34610 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
34611 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
34612 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
34613 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
34614 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34615 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
34616 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
34617 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
34618 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
34619 NCHN=NCHN+1
34620 ISIG(NCHN,1)=I
34621 ISIG(NCHN,2)=-I
34622 ISIG(NCHN,3)=1
34623 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
34624 280 CONTINUE
34625 ENDIF
34626
34627 ELSEIF(ISUB.LE.250) THEN
34628 IF(ISUB.EQ.241) THEN
34629C...q + qbar' -> ~chi+-_1 + gluino
34630 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
34631 GM2=SQM3
34632 ZM2=SQM4
34633 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
34634 FAC0=UMIX(IZID,1)**2
34635 FAC1=VMIX(IZID,1)**2
34636 DO 300 I=MMIN1,MMAX1
34637 IA=IABS(I)
34638 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
34639 DO 290 J=MMIN2,MMAX2
34640 JA=IABS(J)
34641 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
34642 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
34643 FCKM=1D0
34644 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34645 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
34646 KCHW=2
34647 IF(KCHSUM.LT.0) KCHW=3
34648 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
34649 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
34650 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
34651 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
34652 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
34653 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
34654 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
34655 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
34656 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
34657 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
34658 & SH/(TH-XMU2)/(UH-XMD2))/2D0
34659 NCHN=NCHN+1
34660 ISIG(NCHN,1)=I
34661 ISIG(NCHN,2)=J
34662 ISIG(NCHN,3)=1
34663 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
34664 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34665 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
34666 290 CONTINUE
34667 300 CONTINUE
34668
34669 ELSEIF(ISUB.EQ.243) THEN
34670C...q + qbar -> gluino + gluino
34671 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34672 XMT=SQM3-TH
34673 XMU=SQM3-UH
34674 DO 310 I=MMINA,MMAXA
34675 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34676 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
34677 NCHN=NCHN+1
34678 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
34679 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
34680 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34681 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34682 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34683 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34684 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
34685 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
34686 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
34687 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
34688 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
34689 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
34690 ISIG(NCHN,1)=I
34691 ISIG(NCHN,2)=-I
34692 ISIG(NCHN,3)=1
34693C...1/2 for identical particles
34694 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
34695 310 CONTINUE
34696
34697 ELSEIF(ISUB.EQ.244) THEN
34698C...g + g -> gluino + gluino
34699 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34700 XMT=SQM3-TH
34701 XMU=SQM3-UH
34702 FACQQ1=COMFAC*AS**2*9D0/4D0*(
34703 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
34704 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
34705 FACQQ2=COMFAC*AS**2*9D0/4D0*(
34706 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
34707 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
34708 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
34709 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
34710 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
34711 NCHN=NCHN+1
34712 ISIG(NCHN,1)=21
34713 ISIG(NCHN,2)=21
34714 ISIG(NCHN,3)=1
34715 SIGH(NCHN)=FACQQ1/2D0
34716 NCHN=NCHN+1
34717 ISIG(NCHN,1)=21
34718 ISIG(NCHN,2)=21
34719 ISIG(NCHN,3)=2
34720 SIGH(NCHN)=FACQQ2/2D0
34721 NCHN=NCHN+1
34722 ISIG(NCHN,1)=21
34723 ISIG(NCHN,2)=21
34724 ISIG(NCHN,3)=3
34725 SIGH(NCHN)=FACQQ3/2D0
34726 320 CONTINUE
34727
34728 ELSEIF(ISUB.EQ.246) THEN
34729C...g + q_j -> ~chi0_1 + ~q_j
34730 FAC0=COMFAC*AS*AEM/6D0/XW
34731 ZM2=SQM4
34732 QM2=SQM3
34733 FACZQ0=FAC0*( (ZM2-TH)/SH +
34734 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34735 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34736 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34737 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
34738 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
34739 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
34740 EI=KCHG(IABS(I),1)/3D0
34741 IA=IABS(I)
34742 XRQZ = -TANW*EI*ZMIX(IZID,1)
34743 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
34744 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
34745 IF(ILR.EQ.0) THEN
34746 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
34747 ELSE
34748 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
34749 ENDIF
34750 FACZQ=FACZQ0*BS
34751 KCHQ=2
34752 IF(I.LT.0) KCHQ=3
34753 DO 330 ISDE=1,2
34754 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
34755 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
34756 NCHN=NCHN+1
34757 ISIG(NCHN,ISDE)=I
34758 ISIG(NCHN,3-ISDE)=21
34759 ISIG(NCHN,3)=1
34760 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34761 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34762 330 CONTINUE
34763 340 CONTINUE
34764 ENDIF
34765
34766 ELSEIF(ISUB.LE.260) THEN
34767 IF(ISUB.EQ.254) THEN
34768C...g + q_j -> ~chi1_1 + ~q_i
34769 FAC0=COMFAC*AS*AEM/12D0/XW
34770 ZM2=SQM4
34771 QM2=SQM3
34772 AU=UMIX(IZID,1)**2
34773 AD=VMIX(IZID,1)**2
34774 FACZQ0=FAC0*( (ZM2-TH)/SH +
34775 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
34776 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
34777 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
34778 IF(MOD(KFNSQ1,2).EQ.0) THEN
34779 KFNSQ=KFNSQ1-1
34780 KCHW=2
34781 ELSE
34782 KFNSQ=KFNSQ1+1
34783 KCHW=3
34784 ENDIF
34785 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
34786 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
34787 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
34788 IA=IABS(I)
34789 IF(MOD(IA,2).EQ.0) THEN
34790 FACZQ=FACZQ0*AU
34791 ELSE
34792 FACZQ=FACZQ0*AD
34793 ENDIF
34794 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
34795 KCHQ=2
34796 IF(I.LT.0) KCHQ=3
34797 KCHWQ=KCHW
34798 IF(I.LT.0) KCHWQ=5-KCHW
34799 DO 350 ISDE=1,2
34800 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
34801 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
34802 NCHN=NCHN+1
34803 ISIG(NCHN,ISDE)=I
34804 ISIG(NCHN,3-ISDE)=21
34805 ISIG(NCHN,3)=1
34806 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34807 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
34808 350 CONTINUE
34809 360 CONTINUE
34810
34811 ELSEIF(ISUB.EQ.258) THEN
34812C...g + q_j -> gluino + ~q_i
34813 XG2=SQM4
34814 XQ2=SQM3
34815 XMT=XG2-TH
34816 XMU=XG2-UH
34817 XST=XQ2-TH
34818 XSU=XQ2-UH
34819 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
34820 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
34821 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
34822 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
34823 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
34824 & (SH*(UH+XG2)
34825 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
34826 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
34827 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
34828 ASYUK=RMSS(42)*AS
34829 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
34830 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
34831 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34832 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
34833 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
34834 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
34835 KCHQ=2
34836 IF(I.LT.0) KCHQ=3
34837 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34838 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34839 DO 370 ISDE=1,2
34840 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
34841 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
34842 NCHN=NCHN+1
34843 ISIG(NCHN,ISDE)=I
34844 ISIG(NCHN,3-ISDE)=21
34845 ISIG(NCHN,3)=1
34846 SIGH(NCHN)=FACQG1*FACSEL
34847 NCHN=NCHN+1
34848 ISIG(NCHN,ISDE)=I
34849 ISIG(NCHN,3-ISDE)=21
34850 ISIG(NCHN,3)=2
34851 SIGH(NCHN)=FACQG2*FACSEL
34852 370 CONTINUE
34853 380 CONTINUE
34854 ENDIF
34855
34856 ELSEIF(ISUB.LE.270) THEN
34857 IF(ISUB.EQ.261) THEN
34858C...q_i + q_ibar -> ~t_1 + ~t_1bar
34859 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
34860 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34861 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
34862 FAC0=AS**2*4D0/9D0
34863 DO 390 I=MMIN1,MMAX1
34864 IA=IABS(I)
34865 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
34866 IF(IA.GE.11.AND.IA.LE.18) THEN
34867 EI=KCHG(IA,1)/3D0
34868 EJ=KCHG(KFNSQ,1)/3D0
34869 T3I=SIGN(1D0,EI)/2D0
34870 T3J=SIGN(1D0,EJ)/2D0
34871 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
34872 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
34873 XLF=2D0*(T3I-EI*XW)
34874 XRF=2D0*(-EI*XW)
34875 TAA=0.5D0*(EI*EJ)**2
34876 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
34877 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34878 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
34879 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
34880 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
34881 ENDIF
34882 NCHN=NCHN+1
34883 ISIG(NCHN,1)=I
34884 ISIG(NCHN,2)=-I
34885 ISIG(NCHN,3)=1
34886 SIGH(NCHN)=FACQQ1*FAC0
34887 390 CONTINUE
34888
34889 ELSEIF(ISUB.EQ.263) THEN
34890C...f + fbar -> ~t1 + ~t2bar
34891 DO 400 I=MMIN1,MMAX1
34892 IA=IABS(I)
34893 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34894 EI=KCHG(IABS(I),1)/3D0
34895 TT3I=SIGN(1D0,EI)/2D0
34896 EJ=2D0/3D0
34897 TT3J=1D0/2D0
34898 FCOL=1D0
34899C...Color factor for e+ e-
34900 IF(IA.GE.11) FCOL=3D0
34901 XLQ=2D0*(TT3J-EJ*XW)
34902 XRQ=2D0*(-EJ*XW)
34903 XLF=2D0*(TT3I-EI*XW)
34904 XRF=2D0*(-EI*XW)
34905 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
34906 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
34907 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
34908C...Factor of 2 for t1 t2bar + t2 t1bar
34909 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
34910 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
34911 NCHN=NCHN+1
34912 ISIG(NCHN,1)=I
34913 ISIG(NCHN,2)=-I
34914 ISIG(NCHN,3)=1
34915 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
34916 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
34917 NCHN=NCHN+1
34918 ISIG(NCHN,1)=I
34919 ISIG(NCHN,2)=-I
34920 ISIG(NCHN,3)=2
34921 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
34922 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
34923 400 CONTINUE
34924
34925 ELSEIF(ISUB.EQ.264) THEN
34926C...g + g -> ~t_1 + ~t_1bar
34927 XSU=SQM3-UH
34928 XST=SQM3-TH
34929 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
34930 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
34931 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
34932 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
34933 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
34934 NCHN=NCHN+1
34935 ISIG(NCHN,1)=21
34936 ISIG(NCHN,2)=21
34937 ISIG(NCHN,3)=1
34938 SIGH(NCHN)=FACQQ1
34939 NCHN=NCHN+1
34940 ISIG(NCHN,1)=21
34941 ISIG(NCHN,2)=21
34942 ISIG(NCHN,3)=2
34943 SIGH(NCHN)=FACQQ2
34944 410 CONTINUE
34945 ENDIF
34946
34947 ELSEIF(ISUB.LE.280) THEN
34948 IF(ISUB.EQ.271) THEN
34949C...q + q' -> ~q + ~q' (~g exchange)
34950 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
34951 XMT=XMG2-TH
34952 XMU=XMG2-UH
34953 XSU1=SQM3-UH
34954 XSU2=SQM4-UH
34955 XST1=SQM3-TH
34956 XST2=SQM4-TH
34957 ASYUK=RMSS(42)*AS
34958 IF(ILR.EQ.1) THEN
34959 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
34960 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
34961 FACQQB=0.0D0
34962 ELSE
34963 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
34964 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
34965 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
34966 & XMT/XMU )
34967 ENDIF
34968 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
34969 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
34970 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
34971 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
34972 IA=IABS(I)
34973 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
34974 KCHQ=2
34975 IF(I.LT.0) KCHQ=3
34976 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
34977 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
34978 JA=IABS(J)
34979 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
34980 IF(I*J.LT.0) GOTO 420
34981 NCHN=NCHN+1
34982 ISIG(NCHN,1)=I
34983 ISIG(NCHN,2)=J
34984 ISIG(NCHN,3)=1
34985 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34986 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34987 IF(I.EQ.J) THEN
34988 IF(ILR.EQ.0) THEN
34989 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
34990 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
34991 ELSE
34992 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
34993 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
34994 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
34995 ENDIF
34996 NCHN=NCHN+1
34997 ISIG(NCHN,1)=I
34998 ISIG(NCHN,2)=J
34999 ISIG(NCHN,3)=2
35000 IF(ILR.EQ.0) THEN
35001 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35002 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35003 ELSE
35004 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35005 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35006 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35007 ENDIF
35008 ENDIF
35009 420 CONTINUE
35010 430 CONTINUE
35011
35012 ELSEIF(ISUB.EQ.274) THEN
35013C...q + qbar' -> ~q + ~qbar'
35014 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35015 XMT=XMG2-TH
35016 XMU=XMG2-UH
35017 IF(ILR.EQ.0) THEN
35018C...Mrenna...Normalization.and.1/XMT
35019 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35020 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35021 FACQQB=COMFAC*AS**2*4D0/9D0*(
35022 & (UH*TH-SQM3*SQM4)/SH2 )
35023 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35024 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35025 FACQQB=FACQQB+FACQQ1+FACQQI
35026 ELSE
35027 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35028 FACQQB=FACQQ1
35029 ENDIF
35030 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35031 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35032 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35033 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35034 IA=IABS(I)
35035 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35036 KCHQ=2
35037 IF(I.LT.0) KCHQ=3
35038 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35039 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35040 JA=IABS(J)
35041 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35042 IF(I*J.GT.0) GOTO 440
35043 NCHN=NCHN+1
35044 ISIG(NCHN,1)=I
35045 ISIG(NCHN,2)=J
35046 ISIG(NCHN,3)=1
35047 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35048 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35049 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35050 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35051 440 CONTINUE
35052 450 CONTINUE
35053
35054 ELSEIF(ISUB.EQ.277) THEN
35055C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35056C...if i .eq. j covered in 274
35057 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35058 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35059 FAC0=0D0
35060 DO 460 I=MMIN1,MMAX1
35061 IA=IABS(I)
35062 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35063 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35064 IF(IA.EQ.KFNSQ) GOTO 460
35065 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35066 EI=KCHG(IA,1)/3D0
35067 EJ=KCHG(KFNSQ,1)/3D0
35068 T3J=SIGN(0.5D0,EJ)
35069 T3I=SIGN(1D0,EI)/2D0
35070 IF(ILR.EQ.0) THEN
35071 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35072 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35073 ELSE
35074 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35075 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35076 ENDIF
35077 XLF=2D0*(T3I-EI*XW)
35078 XRF=2D0*(-EI*XW)
35079 IF(ILR.EQ.0) THEN
35080 XRQ=0D0
35081 ELSE
35082 XLQ=0D0
35083 ENDIF
35084 TAA=0.5D0*(EI*EJ)**2
35085 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35086 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35087 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35088 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35089 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35090 ELSEIF(IA.LE.6) THEN
35091 FAC0=AS**2*8D0/9D0/2D0
35092 ENDIF
35093 NCHN=NCHN+1
35094 ISIG(NCHN,1)=I
35095 ISIG(NCHN,2)=-I
35096 ISIG(NCHN,3)=1
35097 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35098 460 CONTINUE
35099
35100 ELSEIF(ISUB.EQ.279) THEN
35101C...g + g -> ~q_j + ~q_jbar
35102 XSU=SQM3-UH
35103 XST=SQM3-TH
35104C...5=RKF because ~t ~tbar treated separately
35105 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
35106 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35107 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35108 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
35109 NCHN=NCHN+1
35110 ISIG(NCHN,1)=21
35111 ISIG(NCHN,2)=21
35112 ISIG(NCHN,3)=1
35113 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35114 NCHN=NCHN+1
35115 ISIG(NCHN,1)=21
35116 ISIG(NCHN,2)=21
35117 ISIG(NCHN,3)=2
35118 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35119 470 CONTINUE
35120
35121 ENDIF
35122 ENDIF
35123CMRENNA--
35124
35125 RETURN
35126 END
35127
35128C*********************************************************************
35129
35130C...PYSGTC
35131C...Subprocess cross sections for Technicolor processes.
35132C...Auxiliary to PYSIGH.
35133
35134 SUBROUTINE PYSGTC(NCHN,SIGS)
35135
35136C...Double precision and integer declarations
35137 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35138 IMPLICIT INTEGER(I-N)
35139 INTEGER PYK,PYCHGE,PYCOMP
35140C...Parameter statement to help give large particle numbers.
35141 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35142 &KEXCIT=4000000,KDIMEN=5000000)
35143C...Commonblocks
35144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35145 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35146 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
35147 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35148 COMMON/PYINT1/MINT(400),VINT(400)
35149 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35150 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35151 COMMON/PYINT4/MWID(500),WIDS(500,5)
35152 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
35153 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35154 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35155 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35156 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35157 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
35158 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
35159C...Local arrays and complex variables
35160 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35161 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
35162 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
35163 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
35164 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
35165 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
35166 COMPLEX*16 DVVS,DVVT,DVVU
35167 INTEGER INDX(6)
35168
35169C...Combinations of weak mixing angle.
35170 TANW=SQRT(XW/XW1)
35171 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35172
35173C...Convert almost equivalent technicolor processes into
35174C...a few basic processes, and set distinguishing parameters.
35175 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
35176 SQTV=RTCM(12)**2
35177 SQTA=RTCM(13)**2
35178 SN2W=2D0*SQRT(XW*XW1)
35179 CS2W=1D0-2D0*XW
35180 CT2W=CS2W/SN2W
35181 CSXI=COS(ASIN(RTCM(3)))
35182 CSXIP=COS(ASIN(RTCM(4)))
35183 QUPD=2D0*RTCM(2)-1D0
35184 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
35185 CAB2=0D0
35186 VOGP=0D0
35187 VRGP=0D0
35188 AOGP=0D0
35189 ARGP=0D0
35190 VXGP=0D0
35191 AXGP=0D0
35192 VAGP=0D0
35193 VZGP=0D0
35194 VWGP=0D0
35195C... rho_tc0, etc. -> W_L W_L, W_L W_T
35196 IF(ISUB.EQ.361) THEN
35197 KFA=24
35198 KFB=24
35199 CAB2=RTCM(3)**4
35200 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35201 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35202 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
35203C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
35204 AXGP = SQRT(2D0)*AXGP
35205 ARGP = SQRT(2D0)*ARGP
35206 VOGP = SQRT(2D0)*VOGP
35207C... rho_tc0 -> W_L pi_tc-
35208 ELSEIF(ISUB.EQ.362) THEN
35209 KFA=24
35210 KFB=KTECHN+211
35211 ISUB=361
35212 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35213C... pi_tc pi_tc
35214 ELSEIF(ISUB.EQ.363) THEN
35215 KFA=KTECHN+211
35216 KFB=KTECHN+211
35217 ISUB=361
35218 CAB2=(1D0-RTCM(3)**2)**2
35219C... rho_tc0/omega_tc -> gamma pi_tc
35220 ELSEIF(ISUB.EQ.364) THEN
35221 KFA=22
35222 KFB=KTECHN+111
35223 ISUB=361
35224 VOGP=CSXI/RTCM(12)
35225 VRGP=VOGP*QUPD
35226 VAGP=2D0*QUPD*CSXI
35227 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35228C... gamma pi_tc'
35229 ELSEIF(ISUB.EQ.365) THEN
35230 KFA=22
35231 KFB=KTECHN+221
35232 ISUB=361
35233 VRGP=CSXIP/RTCM(12)
35234 VOGP=VRGP*QUPD
35235 VAGP=2D0*Q2UD*CSXIP
35236 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
35237C... Z pi_tc
35238 ELSEIF(ISUB.EQ.366) THEN
35239 KFA=23
35240 KFB=KTECHN+111
35241 ISUB=361
35242 VOGP=CSXI*CT2W/RTCM(12)
35243 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35244 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
35245 VZGP=-QUPD*CSXI*CS2W/XW1
35246C... Z pi_tc'
35247 ELSEIF(ISUB.EQ.367) THEN
35248 KFA=23
35249 KFB=KTECHN+221
35250 ISUB=361
35251C...RTCM(48) is the M_V for the techni-a
35252 VXGP=-CSXIP/SN2W/RTCM(48)
35253 VRGP=CSXIP*CT2W/RTCM(12)
35254 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
35255 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
35256 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
35257C... W_T pi_tc
35258 ELSEIF(ISUB.EQ.368) THEN
35259 KFA=24
35260 KFB=KTECHN+211
35261 ISUB=361
35262C...RTCM(49) is the M_A for the techni-a
35263 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
35264 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
35265 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
35266 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
35267 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35268C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
35269 ELSEIF(ISUB.EQ.370) THEN
35270 KFA=24
35271 KFB=23
35272 CAB2=RTCM(3)**4
35273 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
35274 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
35275C... W_L pi_tc0
35276 ELSEIF(ISUB.EQ.371) THEN
35277 KFA=24
35278 KFB=KTECHN+111
35279 ISUB=370
35280 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35281C... Z_L pi_tc+
35282 ELSEIF(ISUB.EQ.372) THEN
35283 KFA=KTECHN+211
35284 KFB=23
35285 ISUB=370
35286 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
35287C... pi_tc+ pi_tc0
35288 ELSEIF(ISUB.EQ.373) THEN
35289 KFA=KTECHN+211
35290 KFB=KTECHN+111
35291 ISUB=370
35292 CAB2=(1D0-RTCM(3)**2)**2
35293C... gamma pi_tc+
35294 ELSEIF(ISUB.EQ.374) THEN
35295 KFA=KTECHN+211
35296 KFB=22
35297 ISUB=370
35298 VRGP=QUPD*CSXI/RTCM(12)
35299 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
35300 AXGP=-CSXI/RTCM(49)
35301C... Z_T pi_tc+
35302 ELSEIF(ISUB.EQ.375) THEN
35303 KFA=KTECHN+211
35304 KFB=23
35305 ISUB=370
35306 VRGP=-QUPD*CSXI*TANW/RTCM(12)
35307 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
35308 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
35309 AXGP=-CSXI*CT2W/RTCM(49)
35310C... W_T pi_tc0
35311 ELSEIF(ISUB.EQ.376) THEN
35312 KFA=24
35313 KFB=KTECHN+111
35314 ISUB=370
35315 VRGP=0D0
35316 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
35317 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
35318C... W_T pi_tc0'
35319 ELSEIF(ISUB.EQ.377) THEN
35320 KFA=24
35321 KFB=KTECHN+221
35322 ISUB=370
35323 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
35324 VWGP=CSXIP/(2D0*XW)
35325 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
35326C... gamma W+
35327 ELSEIF(ISUB.EQ.378) THEN
35328 KFA=24
35329 KFB=22
35330 ISUB=370
35331 VRGP=QUPD*RTCM(3)/RTCM(12)
35332 AXGP=-RTCM(3)/RTCM(49)
35333C... gamma Z
35334 ELSEIF(ISUB.EQ.379) THEN
35335 KFA=23
35336 KFB=22
35337 ISUB=361
35338 VOGP=RTCM(3)/RTCM(12)
35339 VRGP=QUPD*RTCM(3)/RTCM(12)
35340 ELSEIF(ISUB.EQ.380) THEN
35341 KFA=23
35342 KFB=23
35343 ISUB=361
35344 VOGP=RTCM(3)*CT2W/RTCM(12)
35345 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
35346 ENDIF
35347 ENDIF
35348
35349C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
35350 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
35351 IF(ITCM(5).LE.4) THEN
35352 SQDQQS=1D0/SH2
35353 SQDQQT=1D0/TH2
35354 SQDQQU=1D0/UH2
35355 SQDGGS=SQDQQS
35356 SQDGGT=SQDQQT
35357 SQDGGU=SQDQQU
35358 REDGGS=1D0/SH
35359 REDGGT=1D0/TH
35360 REDGGU=1D0/UH
35361 REDGTU=1D0/UH/TH
35362 REDGSU=1D0/SH/UH
35363 REDGST=1D0/SH/TH
35364 REDQST=1D0/SH/TH
35365 REDQTU=1D0/UH/TH
35366 SQDLGS=0D0
35367 SQDLGT=0D0
35368 SQDQTS=SQDQQS
35369 ELSEIF(ITCM(5).EQ.5) THEN
35370 TANT3=RTCM(21)
35371 IF(ITCM(2).EQ.0) THEN
35372 IMDL=1
35373 ELSE
35374 IMDL=2
35375 ENDIF
35376 ALPRHT=2.16D0*(3D0/ITCM(1))
35377 SIN2T=2D0*TANT3/(TANT3**2+1D0)
35378 SINT3=TANT3/SQRT(TANT3**2+1D0)
35379 XIG=SQRT(PYALPS(SH)/ALPRHT)
35380 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
35381 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
35382 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
35383 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
35384 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
35385 & SINT3**2)*2D0/SIN2T
35386 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
35387 & SINT3**2)*2D0/SIN2T
35388
35389 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
35390 SM1112=X12*RTCM(28)**2*SIN2T
35391 SM1121=-X21*RTCM(28)**2*SIN2T
35392 SM2212=-SM1112
35393 SM2221=-SM1121
35394 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
35395 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
35396
35397C.........SH LOOP
35398 ZTC(1,1)=DCMPLX(SH,0D0)
35399 CALL PYWIDT(3100021,SH,WDTP,WDTE)
35400 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
35401 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
35402 CALL PYWIDT(3100113,SH,WDTP,WDTE)
35403 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
35404 CALL PYWIDT(3400113,SH,WDTP,WDTE)
35405 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
35406 CALL PYWIDT(3200113,SH,WDTP,WDTE)
35407 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
35408 CALL PYWIDT(3300113,SH,WDTP,WDTE)
35409 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
35410 ZTC(1,2)=(0D0,0D0)
35411 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
35412 ZTC(1,4)=ZTC(1,3)
35413 ZTC(1,5)=ZTC(1,2)
35414 ZTC(1,6)=ZTC(1,2)
35415 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
35416 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
35417 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
35418 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
35419 ZTC(3,4)=-SM1122
35420 ZTC(3,5)=-SM1112
35421 ZTC(3,6)=-SM1121
35422 ZTC(4,5)=-SM2212
35423 ZTC(4,6)=-SM2221
35424 ZTC(5,6)=-SM1221
35425
35426 DO 110 I=1,5
35427 DO 100 J=I+1,6
35428 ZTC(J,I)=ZTC(I,J)
35429 100 CONTINUE
35430 110 CONTINUE
35431 CALL PYLDCM(ZTC,6,6,INDX,D)
35432 DO 130 I=1,6
35433 DO 120 J=1,6
35434 YTC(I,J)=(0D0,0D0)
35435 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35436 120 CONTINUE
35437 130 CONTINUE
35438
35439 DO 140 I=1,6
35440 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35441 140 CONTINUE
35442 DGGS=YTC(1,1)
35443 DVVS=YTC(2,2)
35444 DGVS=YTC(1,2)
35445
35446 XIG=SQRT(PYALPS(-TH)/ALPRHT)
35447C.........TH LOOP
35448 ZTC(1,1)=DCMPLX(TH)
35449 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
35450 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
35451 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
35452 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
35453 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
35454 ZTC(1,2)=(0D0,0D0)
35455 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
35456 ZTC(1,4)=ZTC(1,3)
35457 ZTC(1,5)=ZTC(1,2)
35458 ZTC(1,6)=ZTC(1,2)
35459 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
35460 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
35461 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
35462 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
35463 ZTC(3,4)=-SM1122
35464 ZTC(3,5)=-SM1112
35465 ZTC(3,6)=-SM1121
35466 ZTC(4,5)=-SM2212
35467 ZTC(4,6)=-SM2221
35468 ZTC(5,6)=-SM1221
35469 DO 160 I=1,5
35470 DO 150 J=I+1,6
35471 ZTC(J,I)=ZTC(I,J)
35472 150 CONTINUE
35473 160 CONTINUE
35474 CALL PYLDCM(ZTC,6,6,INDX,D)
35475 DO 180 I=1,6
35476 DO 170 J=1,6
35477 YTC(I,J)=(0D0,0D0)
35478 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35479 170 CONTINUE
35480 180 CONTINUE
35481 DO 190 I=1,6
35482 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35483 190 CONTINUE
35484 DGGT=YTC(1,1)
35485 DVVT=YTC(2,2)
35486 DGVT=YTC(1,2)
35487
35488 XIG=SQRT(PYALPS(-UH)/ALPRHT)
35489C.........UH LOOP
35490 ZTC(1,1)=DCMPLX(UH,0D0)
35491 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
35492 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
35493 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
35494 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
35495 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
35496 ZTC(1,2)=(0D0,0D0)
35497 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
35498 ZTC(1,4)=ZTC(1,3)
35499 ZTC(1,5)=ZTC(1,2)
35500 ZTC(1,6)=ZTC(1,2)
35501 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
35502 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
35503 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
35504 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
35505 ZTC(3,4)=-SM1122
35506 ZTC(3,5)=-SM1112
35507 ZTC(3,6)=-SM1121
35508 ZTC(4,5)=-SM2212
35509 ZTC(4,6)=-SM2221
35510 ZTC(5,6)=-SM1221
35511 DO 210 I=1,5
35512 DO 200 J=I+1,6
35513 ZTC(J,I)=ZTC(I,J)
35514 200 CONTINUE
35515 210 CONTINUE
35516 CALL PYLDCM(ZTC,6,6,INDX,D)
35517 DO 230 I=1,6
35518 DO 220 J=1,6
35519 YTC(I,J)=(0D0,0D0)
35520 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
35521 220 CONTINUE
35522 230 CONTINUE
35523 DO 240 I=1,6
35524 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
35525 240 CONTINUE
35526 DGGU=YTC(1,1)
35527 DVVU=YTC(2,2)
35528 DGVU=YTC(1,2)
35529
35530 IF(IMDL.EQ.1) THEN
35531 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
35532 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
35533 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
35534 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
35535 DQGS=DGGS-DGVS*DCMPLX(TANT3)
35536 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35537 ELSE
35538 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35539 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
35540 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
35541 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
35542 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35543 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
35544 ENDIF
35545
35546 SQDQTS=ABS(DQTS)**2
35547 SQDQQS=ABS(DQQS)**2
35548 SQDQQT=ABS(DQQT)**2
35549 SQDQQU=ABS(DQQU)**2
35550 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
35551 REDLGS=DBLE(DQGS)
35552 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
35553 REDHGS=DBLE(DTGS)
35554 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
35555
35556 SQDGGS=ABS(DGGS)**2
35557 SQDGGT=ABS(DGGT)**2
35558 SQDGGU=ABS(DGGU)**2
35559 REDGGS=DBLE(DGGS)
35560 REDGGT=DBLE(DGGT)
35561 REDGGU=DBLE(DGGU)
35562 REDGTU=DBLE(DGGU*DCONJG(DGGT))
35563 REDGSU=DBLE(DGGU*DCONJG(DGGS))
35564 REDGST=DBLE(DGGS*DCONJG(DGGT))
35565 REDQST=DBLE(DQQS*DCONJG(DQQT))
35566 REDQTU=DBLE(DQQT*DCONJG(DQQU))
35567 ENDIF
35568 ENDIF
35569
35570
35571C...Differential cross section expressions.
35572
35573 IF(ISUB.LE.190) THEN
35574 IF(ISUB.EQ.149) THEN
35575C...g + g -> eta_tc
35576 KCTC=PYCOMP(KTECHN+331)
35577 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
35578 HS=SHR*WDTP(0)
35579 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
35580 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35581 HP=SH
35582 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
35583 HI=HP*WDTP(3)
35584 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35585 NCHN=NCHN+1
35586 ISIG(NCHN,1)=21
35587 ISIG(NCHN,2)=21
35588 ISIG(NCHN,3)=1
35589 SIGH(NCHN)=HI*FACBW*HF
35590 250 CONTINUE
35591
35592 ELSEIF(ISUB.EQ.165) THEN
35593C...q + qbar -> l+ + l- (including contact term for compositeness)
35594 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35595 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35596 KFF=IABS(KFPR(ISUB,1))
35597 EF=KCHG(KFF,1)/3D0
35598 AF=SIGN(1D0,EF+0.1D0)
35599 VF=AF-4D0*EF*XWV
35600 VALF=VF+AF
35601 VARF=VF-AF
35602 FCOF=1D0
35603 IF(KFF.LE.10) FCOF=3D0
35604 WID2=1D0
35605 IF(KFF.EQ.6) WID2=WIDS(6,1)
35606 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
35607 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35608 DO 260 I=MMINA,MMAXA
35609 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
35610 EI=KCHG(IABS(I),1)/3D0
35611 AI=SIGN(1D0,EI+0.1D0)
35612 VI=AI-4D0*EI*XWV
35613 VALI=VI+AI
35614 VARI=VI-AI
35615 FCOI=1D0
35616 IF(IABS(I).LE.10) FCOI=FACA/3D0
35617 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
35618 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
35619 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
35620 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35621 ELSE
35622 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
35623 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
35624 ENDIF
35625 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
35626 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
35627 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
35628 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
35629 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
35630 NCHN=NCHN+1
35631 ISIG(NCHN,1)=I
35632 ISIG(NCHN,2)=-I
35633 ISIG(NCHN,3)=1
35634 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
35635 260 CONTINUE
35636
35637 ELSEIF(ISUB.EQ.166) THEN
35638C...q + q'bar -> l + nu_l (including contact term for compositeness)
35639 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
35640 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
35641 KFF=IABS(KFPR(ISUB,1))
35642 FCOF=1D0
35643 IF(KFF.LE.10) FCOF=3D0
35644 DO 280 I=MMIN1,MMAX1
35645 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
35646 IA=IABS(I)
35647 DO 270 J=MMIN2,MMAX2
35648 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
35649 JA=IABS(J)
35650 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
35651 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35652 & GOTO 270
35653 FCOI=1D0
35654 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35655 WID2=1D0
35656 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
35657 & MOD(J,2).EQ.0)) THEN
35658 IF(KFF.EQ.5) WID2=WIDS(6,2)
35659 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
35660 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
35661 ELSE
35662 IF(KFF.EQ.5) WID2=WIDS(6,3)
35663 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
35664 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
35665 ENDIF
35666 NCHN=NCHN+1
35667 ISIG(NCHN,1)=I
35668 ISIG(NCHN,2)=J
35669 ISIG(NCHN,3)=1
35670 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
35671 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
35672 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
35673 270 CONTINUE
35674 280 CONTINUE
35675 ENDIF
35676
35677 ELSEIF(ISUB.LE.200) THEN
35678 IF(ISUB.EQ.191) THEN
35679C...q + qbar -> rho_tc0.
35680 KCTC=PYCOMP(KTECHN+113)
35681 SQMRHT=PMAS(KCTC,1)**2
35682 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35683 HS=SHR*WDTP(0)
35684 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35685 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35686 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35687 ALPRHT=2.16D0*(3D0/ITCM(1))
35688 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
35689 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
35690 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35691 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35692 DO 290 I=MMINA,MMAXA
35693 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
35694 IA=IABS(I)
35695 EI=KCHG(IABS(I),1)/3D0
35696 AI=SIGN(1D0,EI+0.1D0)
35697 VI=AI-4D0*EI*XWV
35698 VALI=0.5D0*(VI+AI)
35699 VARI=0.5D0*(VI-AI)
35700 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
35701 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
35702 IF(IA.LE.10) HI=HI*FACA/3D0
35703 NCHN=NCHN+1
35704 ISIG(NCHN,1)=I
35705 ISIG(NCHN,2)=-I
35706 ISIG(NCHN,3)=1
35707 SIGH(NCHN)=HI*FACBW*HF
35708 290 CONTINUE
35709
35710 ELSEIF(ISUB.EQ.192) THEN
35711C...q + qbar' -> rho_tc+/-.
35712 KCTC=PYCOMP(KTECHN+213)
35713 SQMRHT=PMAS(KCTC,1)**2
35714 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35715 HS=SHR*WDTP(0)
35716 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
35717 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35718 ALPRHT=2.16D0*(3D0/ITCM(1))
35719 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
35720 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
35721 DO 310 I=MMIN1,MMAX1
35722 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
35723 IA=IABS(I)
35724 DO 300 J=MMIN2,MMAX2
35725 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
35726 JA=IABS(J)
35727 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
35728 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35729 & GOTO 300
35730 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35731 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
35732 HI=HP
35733 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
35734 NCHN=NCHN+1
35735 ISIG(NCHN,1)=I
35736 ISIG(NCHN,2)=J
35737 ISIG(NCHN,3)=1
35738 SIGH(NCHN)=HI*FACBW*HF
35739 300 CONTINUE
35740 310 CONTINUE
35741
35742 ELSEIF(ISUB.EQ.193) THEN
35743C...q + qbar -> omega_tc0.
35744 KCTC=PYCOMP(KTECHN+223)
35745 SQMOMT=PMAS(KCTC,1)**2
35746 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35747 HS=SHR*WDTP(0)
35748 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
35749 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
35750 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35751 ALPRHT=2.16D0*(3D0/ITCM(1))
35752 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
35753 & (2D0*RTCM(2)-1D0)**2
35754 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
35755 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
35756 DO 320 I=MMINA,MMAXA
35757 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
35758 IA=IABS(I)
35759 EI=KCHG(IABS(I),1)/3D0
35760 AI=SIGN(1D0,EI+0.1D0)
35761 VI=AI-4D0*EI*XWV
35762 VALI=0.5D0*(VI+AI)
35763 VARI=0.5D0*(VI-AI)
35764 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
35765 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
35766 IF(IA.LE.10) HI=HI*FACA/3D0
35767 NCHN=NCHN+1
35768 ISIG(NCHN,1)=I
35769 ISIG(NCHN,2)=-I
35770 ISIG(NCHN,3)=1
35771 SIGH(NCHN)=HI*FACBW*HF
35772 320 CONTINUE
35773
35774 ELSEIF(ISUB.EQ.194) THEN
35775C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
35776C...Default final state is e+e-
35777 KFA=KFPR(ISUBSV,1)
35778 ALPRHT=2.16D0*(3D0/ITCM(1))
35779 HP=AEM**2*COMFAC
35780
35781 SN2W=2D0*SQRT(XW*XW1)
35782C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
35783C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
35784
35785 QUPD=2D0*RTCM(2)-1D0
35786 FAR=SQRT(AEM/ALPRHT)
35787 FAO=FAR*QUPD
35788 FZR=FAR*CT2W
35789 FZO=-FAO*TANW
35790C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35791 FZX=-FAR/SN2W*RTCM(47)
35792 SFAR=FAR**2
35793 SFAO=FAO**2
35794 SFZR=FZR**2
35795 SFZO=FZO**2
35796 SFZX=FZX**2
35797 CALL PYWIDT(23,SH,WDTP,WDTE)
35798 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35799 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35800 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35801 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35802 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35803 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35804 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35805C...Propagator including a_T^0
35806 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35807 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35808C...Add in techni-a contribution
35809 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35810 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35811 $ SFZX*SSMR*SSMO)/DETD/SH
35812 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35813 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35814
35815 XWRHT=1D0/(4D0*XW*(1D0-XW))
35816 KFF=IABS(KFPR(ISUB,1))
35817 EF=KCHG(KFF,1)/3D0
35818 AF=SIGN(1D0,EF+0.1D0)
35819 VF=AF-4D0*EF*XWV
35820 VALF=0.5D0*(VF+AF)
35821 VARF=0.5D0*(VF-AF)
35822 FCOF=1D0
35823 IF(KFF.LE.10) FCOF=3D0
35824
35825 WID2=1D0
35826 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
35827 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
35828 DZZ=DZZ*DCMPLX(XWRHT,0D0)
35829 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
35830
35831 DO 330 I=MMINA,MMAXA
35832 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
35833 EI=KCHG(IABS(I),1)/3D0
35834 AI=SIGN(1D0,EI+0.1D0)
35835 VI=AI-4D0*EI*XWV
35836 VALI=0.5D0*(VI+AI)
35837 VARI=0.5D0*(VI-AI)
35838 FCOI=FCOF
35839 IF(IABS(I).LE.10) FCOI=FCOI/3D0
35840 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
35841 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
35842 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
35843 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
35844 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
35845 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
35846 NCHN=NCHN+1
35847 ISIG(NCHN,1)=I
35848 ISIG(NCHN,2)=-I
35849 ISIG(NCHN,3)=1
35850 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
35851 330 CONTINUE
35852
35853 ELSEIF(ISUB.EQ.195) THEN
35854C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
35855 KFA=KFPR(ISUBSV,1)
35856 KFB=KFA+1
35857 ALPRHT=2.16D0*(3D0/ITCM(1))
35858 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
35859
35860 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
35861C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35862C
35863C...Propagator including a_T^+
35864 FWX=-FWR*RTCM(47)
35865 CALL PYWIDT(24,SH,WDTP,WDTE)
35866 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
35867 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
35868 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
35869 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
35870 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
35871 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
35872 & DCMPLX(FWX**2,0D0)*SSMR
35873 DWW=SSMR*SSMX/DETD/SH
35874 FCOF=1D0
35875 IF(KFA.LE.8) FCOF=3D0
35876 HP=FACTC*ABS(DWW)**2*FCOF
35877
35878 DO 350 I=MMIN1,MMAX1
35879 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
35880 IA=IABS(I)
35881 DO 340 J=MMIN2,MMAX2
35882 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
35883 JA=IABS(J)
35884 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
35885 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35886 & GOTO 340
35887 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35888 HI=HP
35889 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
35890 NCHN=NCHN+1
35891 ISIG(NCHN,1)=I
35892 ISIG(NCHN,2)=J
35893 ISIG(NCHN,3)=1
35894 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
35895 340 CONTINUE
35896 350 CONTINUE
35897 ENDIF
35898
35899 ELSEIF(ISUB.LE.380) THEN
35900 ALPRHT=2.16D0*(3D0/ITCM(1))
35901 IF(ISUB.EQ.361) THEN
35902 FAR=SQRT(AEM/ALPRHT)
35903 FAO=FAR*QUPD
35904 FZR=FAR*CT2W
35905 FZO=-FAO*TANW
35906C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
35907 FZX=-FAR/SN2W*RTCM(47)
35908 SFAR=FAR**2
35909 SFAO=FAO**2
35910 SFZR=FZR**2
35911 SFZO=FZO**2
35912 SFZX=FZX**2
35913 CALL PYWIDT(23,SH,WDTP,WDTE)
35914 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
35915 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
35916 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
35917 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
35918 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
35919 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
35920 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
35921 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
35922 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
35923C...Add in techni-a contribution
35924 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
35925 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
35926 $ SFZX*FAR*SSMO)/DETD/SH
35927 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
35928 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
35929 $ SFZX*FAO*SSMR)/DETD/SH
35930 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
35931 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
35932 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
35933 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
35934 $ SFZX*SSMR*SSMO)/DETD/SH
35935 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
35936 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
35937
35938C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
35939C...W+W-, W pi_tc, pi_T pi_T, etc.
35940 FACA=(SH**2*BE34**2-(TH-UH)**2)
35941 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
35942 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
35943 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
35944 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
35945 DO 370 I=MMINA,MMAXA
35946 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
35947 IA=IABS(I)
35948 EI=KCHG(IABS(I),1)/3D0
35949 AI=SIGN(1D0,EI+0.1D0)
35950 VI=AI-4D0*EI*XWV
35951 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
35952 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
35953C...........Eqs. (5) and (6) in LSTC-rates.pdf
35954 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
35955 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
35956 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
35957 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
35958 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
35959 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
35960 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
35961 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
35962 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
35963 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
35964 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
35965C...........Eqs. (5) and (7) in LSTC-rates.pdf
35966 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
35967 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
35968 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
35969 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
35970 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
35971 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
35972 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
35973C
35974C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
35975C
35976c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35977c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35978c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
35979c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
35980 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35981 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
35982 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
35983 HI=HI+HJ+HK
35984 IF(IA.LE.10) HI=HI/3D0
35985 NCHN=NCHN+1
35986 ISIG(NCHN,1)=I
35987 ISIG(NCHN,2)=-I
35988 ISIG(NCHN,3)=1
35989 IF(KFA.EQ.KFB) THEN
35990 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
35991 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
35992 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
35993 NCHN=NCHN+1
35994 ISIG(NCHN,1)=I
35995 ISIG(NCHN,2)=-I
35996 ISIG(NCHN,3)=2
35997 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
35998 ELSE
35999 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36000 ENDIF
36001 370 CONTINUE
36002
36003 ELSEIF(ISUB.EQ.370) THEN
36004C...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
36005C...f + fbar' -> gamma pi_tc, etc.
36006 FACA=(SH**2*BE34**2-(TH-UH)**2)
36007 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36008 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36009 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36010 ALPRHT=2.16D0*(3D0/ITCM(1))
36011 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36012 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36013C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36014 FWX=-FWR*RTCM(47)
36015 CALL PYWIDT(24,SH,WDTP,WDTE)
36016 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36017 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36018 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36019 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36020 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36021 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36022 & DCMPLX(FWX**2,0D0)*SSMR
36023 DWW=SSMR*SSMX/DETD/SH
36024 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36025 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36026 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36027 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36028C
36029C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36030C
36031c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36032 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36033C...Add in W_L Z_T axial and vector contributions.
36034 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36035 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36036 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36037 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36038 DO 410 I=MMIN1,MMAX1
36039 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36040 IA=IABS(I)
36041 DO 400 J=MMIN2,MMAX2
36042 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36043 JA=IABS(J)
36044 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36045 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36046 & GOTO 400
36047 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36048 HI=HP
36049 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36050 NCHN=NCHN+1
36051 ISIG(NCHN,1)=I
36052 ISIG(NCHN,2)=J
36053 ISIG(NCHN,3)=1
36054 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36055 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36056 ELSE
36057 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36058 & WIDS(PYCOMP(KFB),2)
36059 ENDIF
36060 400 CONTINUE
36061 410 CONTINUE
36062 ENDIF
36063
36064 ELSEIF(ISUB.LE.390) THEN
36065 IF(ISUB.EQ.381) THEN
36066C...f + f' -> f + f' (g exchange)
36067 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36068 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36069 & MSTP(34)*2D0/3D0*UH2*REDQST)
36070 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36071 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36072 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36073 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36074C...Modifications from contact interactions (compositeness)
36075 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36076 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36077 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36078 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36079 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36080 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36081 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36082 ELSEIF(ITCM(5).EQ.5) THEN
36083 FACCI1=FACQQ1
36084 FACCIB=FACQQB
36085 FACCI2=FACQQ2
36086 FACCI3=FACQQ1
36087CSM.......Check this change from
36088CSM RATCII=1D0
36089 RATCII=RATQQI
36090 ENDIF
36091 DO 430 I=MMIN1,MMAX1
36092 IA=IABS(I)
36093 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36094 DO 420 J=MMIN2,MMAX2
36095 JA=IABS(J)
36096 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36097 NCHN=NCHN+1
36098 ISIG(NCHN,1)=I
36099 ISIG(NCHN,2)=J
36100 ISIG(NCHN,3)=1
36101 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36102 & JA.GE.3))) THEN
36103 SIGH(NCHN)=FACQQ1
36104 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
36105 ELSE
36106 SIGH(NCHN)=FACCI1
36107 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
36108 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
36109 ENDIF
36110 IF(I.EQ.J) THEN
36111 NCHN=NCHN+1
36112 ISIG(NCHN,1)=I
36113 ISIG(NCHN,2)=J
36114 ISIG(NCHN,3)=2
36115 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
36116 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
36117 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
36118 ELSE
36119 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
36120 SIGH(NCHN)=0.5D0*FACCI2*RATCII
36121 ENDIF
36122 ENDIF
36123 420 CONTINUE
36124 430 CONTINUE
36125
36126 ELSEIF(ISUB.EQ.382) THEN
36127C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
36128 CALL PYWIDT(21,SH,WDTP,WDTE)
36129 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
36130 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36131 IF(ITCM(5).EQ.1) THEN
36132C...Modifications from contact interactions (compositeness)
36133 FACCIB=FACQQB
36134 DO 440 I=1,2
36135 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
36136 & WDTE(I,2)+WDTE(I,4))
36137 440 CONTINUE
36138 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
36139 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
36140 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36141 ELSEIF(ITCM(5).EQ.5) THEN
36142 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
36143 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
36144 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
36145 ENDIF
36146 DO 450 I=MMINA,MMAXA
36147 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36148 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
36149 NCHN=NCHN+1
36150 ISIG(NCHN,1)=I
36151 ISIG(NCHN,2)=-I
36152 ISIG(NCHN,3)=1
36153 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
36154 SIGH(NCHN)=FACQQB
36155 ELSEIF(ITCM(5).EQ.5) THEN
36156 SIGH(NCHN)=FACQQB
36157 NCHN=NCHN+1
36158 ISIG(NCHN,1)=I
36159 ISIG(NCHN,2)=-I
36160 ISIG(NCHN,3)=2
36161 SIGH(NCHN)=FACCIB
36162 ELSE
36163 SIGH(NCHN)=FACCIB
36164 ENDIF
36165 450 CONTINUE
36166
36167 ELSEIF(ISUB.EQ.383) THEN
36168C...f + fbar -> g + g (q + qbar -> g + g only)
36169 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36170 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36171 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36172 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
36173 IF(ITCM(5).EQ.5) THEN
36174 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36175 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36176 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36177 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
36178 ENDIF
36179 DO 460 I=MMINA,MMAXA
36180 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36181 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36182 NCHN=NCHN+1
36183 ISIG(NCHN,1)=I
36184 ISIG(NCHN,2)=-I
36185 ISIG(NCHN,3)=1
36186 SIGH(NCHN)=0.5D0*FACGG1
36187 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
36188 NCHN=NCHN+1
36189 ISIG(NCHN,1)=I
36190 ISIG(NCHN,2)=-I
36191 ISIG(NCHN,3)=2
36192 SIGH(NCHN)=0.5D0*FACGG2
36193 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
36194 460 CONTINUE
36195
36196 ELSEIF(ISUB.EQ.384) THEN
36197C...f + g -> f + g (q + g -> q + g only)
36198 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
36199 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
36200 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
36201 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
36202 DO 480 I=MMINA,MMAXA
36203 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
36204 DO 470 ISDE=1,2
36205 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
36206 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
36207 NCHN=NCHN+1
36208 ISIG(NCHN,ISDE)=I
36209 ISIG(NCHN,3-ISDE)=21
36210 ISIG(NCHN,3)=1
36211 SIGH(NCHN)=FACQG1
36212 NCHN=NCHN+1
36213 ISIG(NCHN,ISDE)=I
36214 ISIG(NCHN,3-ISDE)=21
36215 ISIG(NCHN,3)=2
36216 SIGH(NCHN)=FACQG2
36217 470 CONTINUE
36218 480 CONTINUE
36219
36220 ELSEIF(ISUB.EQ.385) THEN
36221C...g + g -> f + fbar (g + g -> q + qbar only)
36222 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
36223 IDC0=MDCY(21,2)-1
36224C...Begin by d, u, s flavours.
36225 FLAVWT=0D0
36226 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
36227 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
36228 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
36229 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
36230 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
36231 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
36232 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
36233 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36234 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
36235 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
36236 NCHN=NCHN+1
36237 ISIG(NCHN,1)=21
36238 ISIG(NCHN,2)=21
36239 ISIG(NCHN,3)=1
36240 SIGH(NCHN)=FACQQ1
36241 NCHN=NCHN+1
36242 ISIG(NCHN,1)=21
36243 ISIG(NCHN,2)=21
36244 ISIG(NCHN,3)=2
36245 SIGH(NCHN)=FACQQ2
36246C...Next c and b flavours: modified that and uhat for fixed
36247C...cos(theta-hat).
36248 DO 490 IFL=4,5
36249 SQMAVG=PMAS(IFL,1)**2
36250 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
36251 BE34=SQRT(1D0-4D0*SQMAVG/SH)
36252 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36253 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36254 THUHQ=THQ*UHQ-SQMAVG*SH
36255 IF(MSTP(34).EQ.0) THEN
36256 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36257 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36258 ELSE
36259 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36260 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36261 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36262 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36263 ENDIF
36264 IF(ITCM(5).GE.5) THEN
36265 IF(IFL.EQ.4) THEN
36266 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36267 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36268 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36269 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36270 ELSE
36271 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36272 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36273 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36274 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36275 ENDIF
36276 ENDIF
36277 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
36278 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
36279 NCHN=NCHN+1
36280 ISIG(NCHN,1)=21
36281 ISIG(NCHN,2)=21
36282 ISIG(NCHN,3)=1+2*(IFL-3)
36283 SIGH(NCHN)=FACQQ1
36284 NCHN=NCHN+1
36285 ISIG(NCHN,1)=21
36286 ISIG(NCHN,2)=21
36287 ISIG(NCHN,3)=2+2*(IFL-3)
36288 SIGH(NCHN)=FACQQ2
36289 ENDIF
36290 490 CONTINUE
36291 500 CONTINUE
36292
36293 ELSEIF(ISUB.EQ.386) THEN
36294C...g + g -> g + g
36295 IF(ITCM(5).LE.4) THEN
36296 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
36297 & 2D0*TH/SH+TH2/SH2)*FACA
36298 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
36299 & 2D0*SH/UH+SH2/UH2)*FACA
36300 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
36301 & 2D0*UH/TH+UH2/TH2)
36302 ELSE
36303 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
36304 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
36305 & 4D0*REDGST*(SH + 2D0*TH)*
36306 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
36307 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
36308 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
36309 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
36310 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
36311 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
36312 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
36313 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
36314 & 4D0*REDGSU*(SH + 2D0*UH)*
36315 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
36316 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
36317 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
36318 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
36319 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
36320 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
36321 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
36322 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
36323 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
36324 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
36325 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
36326 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
36327 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
36328 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
36329 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
36330 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
36331 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
36332 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
36333 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
36334 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
36335 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
36336 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
36337 ENDIF
36338 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
36339 NCHN=NCHN+1
36340 ISIG(NCHN,1)=21
36341 ISIG(NCHN,2)=21
36342 ISIG(NCHN,3)=1
36343 SIGH(NCHN)=0.5D0*FACGG1
36344 NCHN=NCHN+1
36345 ISIG(NCHN,1)=21
36346 ISIG(NCHN,2)=21
36347 ISIG(NCHN,3)=2
36348 SIGH(NCHN)=0.5D0*FACGG2
36349 NCHN=NCHN+1
36350 ISIG(NCHN,1)=21
36351 ISIG(NCHN,2)=21
36352 ISIG(NCHN,3)=3
36353 SIGH(NCHN)=0.5D0*FACGG3
36354 510 CONTINUE
36355
36356 ELSEIF(ISUB.EQ.387) THEN
36357C...q + qbar -> Q + Qbar
36358 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36359 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36360 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36361 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
36362 & 2D0*SQMAVG/SH)
36363 IF(ITCM(5).GE.5) THEN
36364 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36365 FACQQB=FACQQB*SH2*SQDQTS
36366 ELSE
36367 FACQQB=FACQQB*SH2*SQDQQS
36368 ENDIF
36369 ENDIF
36370 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
36371 WID2=1D0
36372 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36373 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36374 FACQQB=FACQQB*WID2
36375 DO 520 I=MMINA,MMAXA
36376 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36377 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
36378 NCHN=NCHN+1
36379 ISIG(NCHN,1)=I
36380 ISIG(NCHN,2)=-I
36381 ISIG(NCHN,3)=1
36382 SIGH(NCHN)=FACQQB
36383 520 CONTINUE
36384
36385 ELSEIF(ISUB.EQ.388) THEN
36386C...g + g -> Q + Qbar
36387 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
36388 THQ=-0.5D0*SH*(1D0-BE34*CTH)
36389 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
36390 THUHQ=THQ*UHQ-SQMAVG*SH
36391 IF(MSTP(34).EQ.0) THEN
36392 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
36393 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
36394 ELSE
36395 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36396 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
36397 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
36398 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
36399 ENDIF
36400 IF(ITCM(5).GE.5) THEN
36401 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
36402 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
36403 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36404 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
36405 & 2.25D0*THQ*UHQ/SH2*SQDHGS
36406 ELSE
36407 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
36408 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36409 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
36410 & 2.25D0*THQ*UHQ/SH2*SQDLGS
36411 ENDIF
36412 ENDIF
36413 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
36414 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
36415 IF(MSTP(35).GE.1) THEN
36416 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
36417 FACQQ1=FACQQ1*FATRE
36418 FACQQ2=FACQQ2*FATRE
36419 ENDIF
36420 WID2=1D0
36421 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
36422 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
36423 FACQQ1=FACQQ1*WID2
36424 FACQQ2=FACQQ2*WID2
36425 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
36426 NCHN=NCHN+1
36427 ISIG(NCHN,1)=21
36428 ISIG(NCHN,2)=21
36429 ISIG(NCHN,3)=1
36430 SIGH(NCHN)=FACQQ1
36431 NCHN=NCHN+1
36432 ISIG(NCHN,1)=21
36433 ISIG(NCHN,2)=21
36434 ISIG(NCHN,3)=2
36435 SIGH(NCHN)=FACQQ2
36436 530 CONTINUE
36437 ENDIF
36438 ENDIF
36439
36440CMRENNA--
36441
36442 RETURN
36443 END
36444
36445C*********************************************************************
36446
36447C...PYSGEX
36448C...Subprocess cross sections for assorted exotic processes,
36449C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
36450C...Auxiliary to PYSIGH.
36451
36452 SUBROUTINE PYSGEX(NCHN,SIGS)
36453
36454C...Double precision and integer declarations
36455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36456 IMPLICIT INTEGER(I-N)
36457 INTEGER PYK,PYCHGE,PYCOMP
36458C...Parameter statement to help give large particle numbers.
36459 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36460 &KEXCIT=4000000,KDIMEN=5000000)
36461C...Commonblocks
36462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36463 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36464 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36465 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36466 COMMON/PYINT1/MINT(400),VINT(400)
36467 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36468 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36469 COMMON/PYINT4/MWID(500),WIDS(500,5)
36470 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36471 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36472 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36473 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36474 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36475 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36476 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36477C...Local arrays
36478 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36479
36480C...Differential cross section expressions.
36481
36482 IF(ISUB.LE.160) THEN
36483 IF(ISUB.EQ.141) THEN
36484C...f + fbar -> gamma*/Z0/Z'0
36485 SQMZP=PMAS(32,1)**2
36486 MINT(61)=2
36487 CALL PYWIDT(32,SH,WDTP,WDTE)
36488 HP0=AEM/3D0*SH
36489 HP1=AEM/3D0*XWC*SH
36490 HP2=HP1
36491 HS=SHR*VINT(117)
36492 HSP=SHR*WDTP(0)
36493 FACZP=4D0*COMFAC*3D0
36494 DO 100 I=MMINA,MMAXA
36495 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
36496 EI=KCHG(IABS(I),1)/3D0
36497 AI=SIGN(1D0,EI)
36498 VI=AI-4D0*EI*XWV
36499 IA=IABS(I)
36500 IF(IA.LT.10) THEN
36501 IF(IA.LE.2) THEN
36502 VPI=PARU(123-2*MOD(IABS(I),2))
36503 API=PARU(124-2*MOD(IABS(I),2))
36504 ELSEIF(IA.LE.4) THEN
36505 VPI=PARJ(182-2*MOD(IABS(I),2))
36506 API=PARJ(183-2*MOD(IABS(I),2))
36507 ELSE
36508 VPI=PARJ(190-2*MOD(IABS(I),2))
36509 API=PARJ(191-2*MOD(IABS(I),2))
36510 ENDIF
36511 ELSE
36512 IF(IA.LE.12) THEN
36513 VPI=PARU(127-2*MOD(IABS(I),2))
36514 API=PARU(128-2*MOD(IABS(I),2))
36515 ELSEIF(IA.LE.14) THEN
36516 VPI=PARJ(186-2*MOD(IABS(I),2))
36517 API=PARJ(187-2*MOD(IABS(I),2))
36518 ELSE
36519 VPI=PARJ(194-2*MOD(IABS(I),2))
36520 API=PARJ(195-2*MOD(IABS(I),2))
36521 ENDIF
36522 ENDIF
36523 HI0=HP0
36524 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
36525 HI1=HP1
36526 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
36527 HI2=HP2
36528 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
36529 NCHN=NCHN+1
36530 ISIG(NCHN,1)=I
36531 ISIG(NCHN,2)=-I
36532 ISIG(NCHN,3)=1
36533 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
36534 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
36535 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
36536 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
36537 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
36538 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
36539 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
36540 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
36541 100 CONTINUE
36542
36543 ELSEIF(ISUB.EQ.142) THEN
36544C...f + fbar' -> W'+/-
36545 SQMWP=PMAS(34,1)**2
36546 CALL PYWIDT(34,SH,WDTP,WDTE)
36547 HS=SHR*WDTP(0)
36548 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
36549 HP=AEM/(24D0*XW)*SH
36550 DO 120 I=MMIN1,MMAX1
36551 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
36552 IA=IABS(I)
36553 DO 110 J=MMIN2,MMAX2
36554 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
36555 JA=IABS(J)
36556 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
36557 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36558 & GOTO 110
36559 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36560 HI=HP*(PARU(133)**2+PARU(134)**2)
36561 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
36562 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36563 NCHN=NCHN+1
36564 ISIG(NCHN,1)=I
36565 ISIG(NCHN,2)=J
36566 ISIG(NCHN,3)=1
36567 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
36568 SIGH(NCHN)=HI*FACBW*HF
36569 110 CONTINUE
36570 120 CONTINUE
36571
36572 ELSEIF(ISUB.EQ.144) THEN
36573C...f + fbar' -> R
36574 SQMR=PMAS(41,1)**2
36575 CALL PYWIDT(41,SH,WDTP,WDTE)
36576 HS=SHR*WDTP(0)
36577 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
36578 HP=AEM/(12D0*XW)*SH
36579 DO 140 I=MMIN1,MMAX1
36580 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
36581 IA=IABS(I)
36582 DO 130 J=MMIN2,MMAX2
36583 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
36584 JA=IABS(J)
36585 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
36586 HI=HP
36587 IF(IA.LE.10) HI=HI*FACA/3D0
36588 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
36589 NCHN=NCHN+1
36590 ISIG(NCHN,1)=I
36591 ISIG(NCHN,2)=J
36592 ISIG(NCHN,3)=1
36593 SIGH(NCHN)=HI*FACBW*HF
36594 130 CONTINUE
36595 140 CONTINUE
36596
36597 ELSEIF(ISUB.EQ.145) THEN
36598C...q + l -> LQ (leptoquark)
36599 SQMLQ=PMAS(42,1)**2
36600 CALL PYWIDT(42,SH,WDTP,WDTE)
36601 HS=SHR*WDTP(0)
36602 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
36603 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
36604 HP=AEM/4D0*SH
36605 KFLQQ=KFDP(MDCY(42,2),1)
36606 KFLQL=KFDP(MDCY(42,2),2)
36607 DO 160 I=MMIN1,MMAX1
36608 IF(KFAC(1,I).EQ.0) GOTO 160
36609 IA=IABS(I)
36610 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
36611 DO 150 J=MMIN2,MMAX2
36612 IF(KFAC(2,J).EQ.0) GOTO 150
36613 JA=IABS(J)
36614 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
36615 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
36616 IF(JA.EQ.IA) GOTO 150
36617 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
36618 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
36619 HI=HP*PARU(151)
36620 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
36621 NCHN=NCHN+1
36622 ISIG(NCHN,1)=I
36623 ISIG(NCHN,2)=J
36624 ISIG(NCHN,3)=1
36625 SIGH(NCHN)=HI*FACBW*HF
36626 150 CONTINUE
36627 160 CONTINUE
36628
36629 ELSEIF(ISUB.EQ.146) THEN
36630C...e + gamma* -> e* (excited lepton)
36631 KFQSTR=KFPR(ISUB,1)
36632 KCQSTR=PYCOMP(KFQSTR)
36633 KFQEXC=MOD(KFQSTR,KEXCIT)
36634 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36635 HS=SHR*WDTP(0)
36636 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36637 QF=-RTCM(43)/2D0-RTCM(44)/2D0
36638 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
36639 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36640 & FACBW=0D0
36641 HP=SH
36642 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
36643 DO 170 ISDE=1,2
36644 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
36645 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
36646 HI=HP
36647 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36648 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36649 NCHN=NCHN+1
36650 ISIG(NCHN,ISDE)=I
36651 ISIG(NCHN,3-ISDE)=22
36652 ISIG(NCHN,3)=1
36653 SIGH(NCHN)=HI*FACBW*HF
36654 170 CONTINUE
36655 180 CONTINUE
36656
36657 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
36658C...d + g -> d* and u + g -> u* (excited quarks)
36659 KFQSTR=KFPR(ISUB,1)
36660 KCQSTR=PYCOMP(KFQSTR)
36661 KFQEXC=MOD(KFQSTR,KEXCIT)
36662 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
36663 HS=SHR*WDTP(0)
36664 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
36665 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
36666 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
36667 & FACBW=0D0
36668 HP=SH
36669 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
36670 DO 190 ISDE=1,2
36671 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
36672 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
36673 HI=HP
36674 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36675 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
36676 NCHN=NCHN+1
36677 ISIG(NCHN,ISDE)=I
36678 ISIG(NCHN,3-ISDE)=21
36679 ISIG(NCHN,3)=1
36680 SIGH(NCHN)=HI*FACBW*HF
36681 190 CONTINUE
36682 200 CONTINUE
36683 ENDIF
36684
36685 ELSEIF(ISUB.LE.190) THEN
36686 IF(ISUB.EQ.162) THEN
36687C...q + g -> LQ + lbar; LQ=leptoquark
36688 SQMLQ=PMAS(42,1)**2
36689 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
36690 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
36691 KFLQQ=KFDP(MDCY(42,2),1)
36692 DO 220 I=MMINA,MMAXA
36693 IF(IABS(I).NE.KFLQQ) GOTO 220
36694 KCHLQ=ISIGN(1,I)
36695 DO 210 ISDE=1,2
36696 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
36697 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
36698 NCHN=NCHN+1
36699 ISIG(NCHN,ISDE)=I
36700 ISIG(NCHN,3-ISDE)=21
36701 ISIG(NCHN,3)=1
36702 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
36703 210 CONTINUE
36704 220 CONTINUE
36705
36706 ELSEIF(ISUB.EQ.163) THEN
36707C...g + g -> LQ + LQbar; LQ=leptoquark
36708 SQMLQ=PMAS(42,1)**2
36709 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
36710 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
36711 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
36712 & ((TH-SQMLQ)*(UH-SQMLQ)))
36713 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
36714 NCHN=NCHN+1
36715 ISIG(NCHN,1)=21
36716 ISIG(NCHN,2)=21
36717C...Since don't know proper colour flow, randomize between alternatives
36718 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
36719 SIGH(NCHN)=FACLQ
36720 230 CONTINUE
36721
36722 ELSEIF(ISUB.EQ.164) THEN
36723C...q + qbar -> LQ + LQbar; LQ=leptoquark
36724 DELTA=0.25D0*(SQM3-SQM4)**2/SH
36725 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
36726 TH=TH-DELTA
36727 UH=UH-DELTA
36728C SQMLQ=PMAS(42,1)**2
36729 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
36730 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
36731 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
36732 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
36733 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
36734 KFLQQ=KFDP(MDCY(42,2),1)
36735 DO 240 I=MMINA,MMAXA
36736 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36737 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
36738 NCHN=NCHN+1
36739 ISIG(NCHN,1)=I
36740 ISIG(NCHN,2)=-I
36741 ISIG(NCHN,3)=1
36742 SIGH(NCHN)=FACLQA
36743 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
36744 240 CONTINUE
36745
36746 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
36747C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
36748 KFQSTR=KFPR(ISUB,2)
36749 KCQSTR=PYCOMP(KFQSTR)
36750 KFQEXC=MOD(KFQSTR,KEXCIT)
36751 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
36752 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36753 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36754C...Propagators: as simulated in PYOFSH and as desired
36755 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36756 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36757 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36758 GMMQC=SQRT(SQM4)*WDTP(0)
36759 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36760 FACQSA=FACQSA*HBW4C/HBW4
36761 FACQSB=FACQSB*HBW4C/HBW4
36762C...Branching ratios.
36763 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36764 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36765 DO 260 I=MMIN1,MMAX1
36766 IA=IABS(I)
36767 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
36768 DO 250 J=MMIN2,MMAX2
36769 JA=IABS(J)
36770 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
36771 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
36772 NCHN=NCHN+1
36773 ISIG(NCHN,1)=I
36774 ISIG(NCHN,2)=J
36775 ISIG(NCHN,3)=1
36776 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36777 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36778 NCHN=NCHN+1
36779 ISIG(NCHN,1)=I
36780 ISIG(NCHN,2)=J
36781 ISIG(NCHN,3)=2
36782 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
36783 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
36784 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
36785 NCHN=NCHN+1
36786 ISIG(NCHN,1)=I
36787 ISIG(NCHN,2)=J
36788 ISIG(NCHN,3)=1
36789 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36790 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
36791 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
36792 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
36793 NCHN=NCHN+1
36794 ISIG(NCHN,1)=I
36795 ISIG(NCHN,2)=J
36796 ISIG(NCHN,3)=1
36797 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36798 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36799 NCHN=NCHN+1
36800 ISIG(NCHN,1)=I
36801 ISIG(NCHN,2)=J
36802 ISIG(NCHN,3)=2
36803 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
36804 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
36805 ELSEIF(I.EQ.-J) THEN
36806 NCHN=NCHN+1
36807 ISIG(NCHN,1)=I
36808 ISIG(NCHN,2)=J
36809 ISIG(NCHN,3)=1
36810 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36811 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36812 NCHN=NCHN+1
36813 ISIG(NCHN,1)=I
36814 ISIG(NCHN,2)=J
36815 ISIG(NCHN,3)=2
36816 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36817 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36818 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
36819 NCHN=NCHN+1
36820 ISIG(NCHN,1)=I
36821 ISIG(NCHN,2)=J
36822 ISIG(NCHN,3)=1
36823 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
36824 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
36825 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
36826 ENDIF
36827 250 CONTINUE
36828 260 CONTINUE
36829
36830 ELSEIF(ISUB.EQ.169) THEN
36831C...q + qbar -> e + e* (excited lepton)
36832 KFQSTR=KFPR(ISUB,2)
36833 KCQSTR=PYCOMP(KFQSTR)
36834 KFQEXC=MOD(KFQSTR,KEXCIT)
36835 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
36836 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
36837C...Propagators: as simulated in PYOFSH and as desired
36838 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
36839 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
36840 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
36841 GMMQC=SQRT(SQM4)*WDTP(0)
36842 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
36843 FACQSB=FACQSB*HBW4C/HBW4
36844C...Branching ratios.
36845 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
36846 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
36847 DO 270 I=MMIN1,MMAX1
36848 IA=IABS(I)
36849 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
36850 J=-I
36851 JA=IABS(J)
36852 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
36853 NCHN=NCHN+1
36854 ISIG(NCHN,1)=I
36855 ISIG(NCHN,2)=J
36856 ISIG(NCHN,3)=1
36857 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36858 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36859 NCHN=NCHN+1
36860 ISIG(NCHN,1)=I
36861 ISIG(NCHN,2)=J
36862 ISIG(NCHN,3)=2
36863 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
36864 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
36865 270 CONTINUE
36866 ENDIF
36867
36868 ELSEIF(ISUB.LE.360) THEN
36869 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
36870C...l + l -> H_L++/-- or H_R++/--.
36871 KFRES=KFPR(ISUB,1)
36872 KFREC=PYCOMP(KFRES)
36873 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
36874 HS=SHR*WDTP(0)
36875 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
36876 DO 290 I=MMIN1,MMAX1
36877 IA=IABS(I)
36878 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
36879 & GOTO 290
36880 DO 280 J=MMIN2,MMAX2
36881 JA=IABS(J)
36882 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
36883 & GOTO 280
36884 IF(I*J.LT.0) GOTO 280
36885 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36886 NCHN=NCHN+1
36887 ISIG(NCHN,1)=I
36888 ISIG(NCHN,2)=J
36889 ISIG(NCHN,3)=1
36890 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
36891 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
36892 SIGH(NCHN)=HI*FACBW*HF
36893 280 CONTINUE
36894 290 CONTINUE
36895
36896 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
36897C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
36898 KFRES=KFPR(ISUB,1)
36899 KFREC=PYCOMP(KFRES)
36900C...Propagators: as simulated in PYOFSH and as desired
36901 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
36902 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
36903 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36904 GMMC=SQRT(SQM3)*WDTP(0)
36905 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
36906 FHCC=COMFAC*AEM*HBW3C/HBW3
36907 DO 310 I=MMINA,MMAXA
36908 IA=IABS(I)
36909 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
36910 SQML=PMAS(IA,1)**2
36911 J=ISIGN(KFPR(ISUB,2),-I)
36912 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
36913 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
36914 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
36915 & (UH-SQM3)**2
36916 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
36917 & (TH-SQM4)*SH)/(TH-SQM4)**2
36918 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
36919 & SH)/(SH-SQML)**2
36920 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
36921 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
36922 & ((UH-SQM3)*(TH-SQM4))
36923 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
36924 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
36925 & ((UH-SQM3)*(SH-SQML))
36926 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
36927 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
36928 & ((SH-SQML)*(TH-SQM4))
36929 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
36930 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
36931 DO 300 ISDE=1,2
36932 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
36933 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
36934 NCHN=NCHN+1
36935 ISIG(NCHN,ISDE)=I
36936 ISIG(NCHN,3-ISDE)=22
36937 ISIG(NCHN,3)=0
36938 SIGH(NCHN)=FHCC*SMM*WIDSC
36939 300 CONTINUE
36940 310 CONTINUE
36941
36942 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
36943C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
36944 KFRES=KFPR(ISUB,1)
36945 KFREC=PYCOMP(KFRES)
36946 SQMH=PMAS(KFREC,1)**2
36947 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
36948C...Propagators: H++/-- as simulated in PYOFSH and as desired
36949 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
36950 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
36951 GMMH3=SQRT(SQM3)*WDTP(0)
36952 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
36953 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
36954 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
36955 GMMH4=SQRT(SQM4)*WDTP(0)
36956 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
36957C...Kinematical and coupling functions
36958 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
36959 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
36960C...Loop over allowed flavours
36961 DO 320 I=MMINA,MMAXA
36962 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36963 EI=KCHG(IABS(I),1)/3D0
36964 AI=SIGN(1D0,EI+0.1D0)
36965 VI=AI-4D0*EI*XWV
36966 FCOI=1D0
36967 IF(IABS(I).LE.10) FCOI=FACA/3D0
36968 IF(ISUB.EQ.349) THEN
36969 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
36970 IF(IABS(I).LT.10) THEN
36971 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36972 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36973 & (VI**2+AI**2)*XWHH**2*HBWZ)
36974 ELSE
36975 IAOFF=181+3*((IABS(I)-11)/2)
36976 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36977 & (4D0*PARU(1))
36978 DSIGHH=8D0*AEM**2*(EI**2/SH2+
36979 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
36980 & (VI**2+AI**2)*XWHH**2*HBWZ)+
36981 & 8D0*AEM*(EI*HSUM/(SH*TH)+
36982 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
36983 & 4D0*HSUM**2/TH2
36984 ENDIF
36985 ELSE
36986 IF(IABS(I).LT.10) THEN
36987 DSIGHH=8D0*AEM**2*EI**2/SH2
36988 ELSE
36989 IAOFF=181+3*((IABS(I)-11)/2)
36990 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
36991 & (4D0*PARU(1))
36992 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
36993 & 4D0*HSUM**2/TH2
36994 ENDIF
36995 ENDIF
36996 NCHN=NCHN+1
36997 ISIG(NCHN,1)=I
36998 ISIG(NCHN,2)=-I
36999 ISIG(NCHN,3)=1
37000 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37001 320 CONTINUE
37002
37003 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37004C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37005 KFRES=KFPR(ISUB,1)
37006 KFREC=PYCOMP(KFRES)
37007 SQMH=PMAS(KFREC,1)**2
37008 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37009 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37010 & PMAS(PYCOMP(9900024),1)**2
37011 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37012 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37013 & (VINT(209)**2-VINT(216)))
37014 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37015 & (VINT(209)**2+2D0*VINT(218)))
37016 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37017 HS=SHR*WDTP(0)
37018 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37019 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37020 & FACBW=0D0
37021 DO 340 I=MMIN1,MMAX1
37022 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37023 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37024 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37025 DO 330 J=MMIN2,MMAX2
37026 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37027 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37028 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37029 KCHH=KCHWI+KCHWJ
37030 IF(IABS(KCHH).NE.2) GOTO 330
37031 FACLR=VINT(180+I)*VINT(180+J)
37032 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37033 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37034 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37035 ELSE
37036 FACPRP=FACPRT**2
37037 ENDIF
37038 NCHN=NCHN+1
37039 ISIG(NCHN,1)=I
37040 ISIG(NCHN,2)=J
37041 ISIG(NCHN,3)=1
37042 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37043 330 CONTINUE
37044 340 CONTINUE
37045
37046 ELSEIF(ISUB.EQ.353) THEN
37047C...f + fbar -> Z_R0
37048 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37049 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37050 HS=SHR*WDTP(0)
37051 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37052 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37053 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37054 DO 350 I=MMINA,MMAXA
37055 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37056 IF(IABS(I).LE.8) THEN
37057 EI=KCHG(IABS(I),1)/3D0
37058 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37059 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37060 ELSE
37061 AI=-(1D0-2D0*XW)
37062 VI=-1D0+4D0*XW
37063 ENDIF
37064 HI=HP*(VI**2+AI**2)
37065 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37066 NCHN=NCHN+1
37067 ISIG(NCHN,1)=I
37068 ISIG(NCHN,2)=-I
37069 ISIG(NCHN,3)=1
37070 SIGH(NCHN)=HI*FACBW*HF
37071 350 CONTINUE
37072
37073 ELSEIF(ISUB.EQ.354) THEN
37074C...f + fbar' -> W_R+/-
37075 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37076 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37077 HS=SHR*WDTP(0)
37078 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
37079 HP=AEM/(24D0*XW)*SH
37080 DO 370 I=MMIN1,MMAX1
37081 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
37082 IA=IABS(I)
37083 DO 360 J=MMIN2,MMAX2
37084 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
37085 JA=IABS(J)
37086 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
37087 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37088 & GOTO 360
37089 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37090 HI=HP*2D0
37091 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37092 NCHN=NCHN+1
37093 ISIG(NCHN,1)=I
37094 ISIG(NCHN,2)=J
37095 ISIG(NCHN,3)=1
37096 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37097 SIGH(NCHN)=HI*FACBW*HF
37098 360 CONTINUE
37099 370 CONTINUE
37100 ENDIF
37101
37102 ELSEIF(ISUB.LE.400) THEN
37103 IF(ISUB.EQ.391) THEN
37104C...f + fbar -> G*.
37105 KFGSTR=KFPR(ISUB,1)
37106 KCGSTR=PYCOMP(KFGSTR)
37107 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37108 HS=SHR*WDTP(0)
37109 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37110 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
37111 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37112C...Modify cross section in wings of peak.
37113 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37114 DO 380 I=MMINA,MMAXA
37115 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
37116 HI=1D0
37117 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37118 NCHN=NCHN+1
37119 ISIG(NCHN,1)=I
37120 ISIG(NCHN,2)=-I
37121 ISIG(NCHN,3)=1
37122 SIGH(NCHN)=FACG*HI
37123 380 CONTINUE
37124
37125 ELSEIF(ISUB.EQ.392) THEN
37126C...g + g -> G*.
37127 KFGSTR=KFPR(ISUB,1)
37128 KCGSTR=PYCOMP(KFGSTR)
37129 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
37130 HS=SHR*WDTP(0)
37131 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37132 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
37133 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
37134C...Modify cross section in wings of peak.
37135 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
37136 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
37137 NCHN=NCHN+1
37138 ISIG(NCHN,1)=21
37139 ISIG(NCHN,2)=21
37140 ISIG(NCHN,3)=1
37141 SIGH(NCHN)=FACG
37142 390 CONTINUE
37143
37144 ELSEIF(ISUB.EQ.393) THEN
37145C...q + qbar -> g + G*.
37146 KFGSTR=KFPR(ISUB,2)
37147 KCGSTR=PYCOMP(KFGSTR)
37148 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
37149 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
37150 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
37151 & 2D0*SH2/(TH*UH))
37152C...Propagators: as simulated in PYOFSH and as desired
37153 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37154 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37155 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37156 HS=SQRT(SQM4)*WDTP(0)
37157 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37158 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37159 FACG=FACG*HBW4C/HBW4
37160 DO 400 I=MMINA,MMAXA
37161 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37162 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
37163 NCHN=NCHN+1
37164 ISIG(NCHN,1)=I
37165 ISIG(NCHN,2)=-I
37166 ISIG(NCHN,3)=1
37167 SIGH(NCHN)=FACG
37168 400 CONTINUE
37169
37170 ELSEIF(ISUB.EQ.394) THEN
37171C...q + g -> q + G*.
37172 KFGSTR=KFPR(ISUB,2)
37173 KCGSTR=PYCOMP(KFGSTR)
37174 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
37175 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
37176 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
37177 & 2D0*TH2*TH/(UH*SH2))
37178C...Propagators: as simulated in PYOFSH and as desired
37179 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37180 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37181 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37182 HS=SQRT(SQM4)*WDTP(0)
37183 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37184 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37185 FACG=FACG*HBW4C/HBW4
37186 DO 420 I=MMINA,MMAXA
37187 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
37188 DO 410 ISDE=1,2
37189 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
37190 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
37191 NCHN=NCHN+1
37192 ISIG(NCHN,ISDE)=I
37193 ISIG(NCHN,3-ISDE)=21
37194 ISIG(NCHN,3)=1
37195 SIGH(NCHN)=FACG
37196 410 CONTINUE
37197 420 CONTINUE
37198
37199 ELSEIF(ISUB.EQ.395) THEN
37200C...g + g -> g + G*.
37201 KFGSTR=KFPR(ISUB,2)
37202 KCGSTR=PYCOMP(KFGSTR)
37203 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
37204 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
37205 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
37206C...Propagators: as simulated in PYOFSH and as desired
37207 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
37208 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
37209 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
37210 HS=SQRT(SQM4)*WDTP(0)
37211 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37212 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
37213 FACG=FACG*HBW4C/HBW4
37214 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
37215 NCHN=NCHN+1
37216 ISIG(NCHN,1)=21
37217 ISIG(NCHN,2)=21
37218 ISIG(NCHN,3)=1
37219 SIGH(NCHN)=FACG
37220 ENDIF
37221 ENDIF
37222 ENDIF
37223
37224 RETURN
37225 END
37226
37227C*********************************************************************
37228
37229C...PYPDFU
37230C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
37231C...parton distributions according to a few different parametrizations.
37232C...Note that what is coded is x times the probability distribution,
37233C...i.e. xq(x,Q2) etc.
37234
37235 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
37236
37237C...Double precision and integer declarations.
37238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37239 IMPLICIT INTEGER(I-N)
37240 INTEGER PYK,PYCHGE,PYCOMP
37241C...Commonblocks.
37242 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
37243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37244 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37245 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37246 COMMON/PYINT1/MINT(400),VINT(400)
37247 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
37248 &XPDIR(-6:6)
37249 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
37250 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
37251 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
37252 & XMI(2,240),PT2MI(240),IMISEP(0:240)
37253 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
37254 &/PYINT9/,/PYINTM/
37255C...Local arrays.
37256 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
37257 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
37258 SAVE PPAR
37259
37260C...Interface to PDFLIB.
37261 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
37262 SAVE /W50513/
37263 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
37264 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
37265 CHARACTER*20 PARM(20)
37266 DATA VALUE/20*0D0/,PARM/20*' '/
37267
37268C...Data related to Schuler-Sjostrand photon distributions.
37269 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
37270
37271C...Valence PDF momentum integral parametrizations PER PARTON!
37272 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
37273 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
37274 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
37275 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
37276
37277C...Reset parton distributions.
37278 MINT(92)=0
37279 DO 100 KFL=-25,25
37280 XPQ(KFL)=0D0
37281 100 CONTINUE
37282 DO 110 KFL=-6,6
37283 XPVAL(KFL)=0D0
37284 110 CONTINUE
37285
37286C...Check x and particle species.
37287 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37288 WRITE(MSTU(11),5000) X
37289 GOTO 9999
37290 ENDIF
37291 KFA=IABS(KF)
37292 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
37293 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
37294 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
37295 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
37296 &KFA.NE.310.AND.KFA.NE.130) THEN
37297 WRITE(MSTU(11),5100) KF
37298 GOTO 9999
37299 ENDIF
37300
37301C...Electron (or muon or tau) parton distribution call.
37302 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
37303 CALL PYPDEL(KFA,X,Q2,XPEL)
37304 DO 120 KFL=-25,25
37305 XPQ(KFL)=XPEL(KFL)
37306 120 CONTINUE
37307
37308C...Photon parton distribution call (VDM+anomalous).
37309 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
37310 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
37311 CALL PYPDGA(X,Q2,XPGA)
37312 DO 130 KFL=-6,6
37313 XPQ(KFL)=XPGA(KFL)
37314 130 CONTINUE
37315 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37316 XPVAL(1)=XPVU/4D0
37317 XPVAL(2)=XPVU
37318 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37319 XPVAL(4)=MIN(XPQ(4),XPVU)
37320 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37321 XPVAL(-1)=XPVAL(1)
37322 XPVAL(-2)=XPVAL(2)
37323 XPVAL(-3)=XPVAL(3)
37324 XPVAL(-4)=XPVAL(4)
37325 XPVAL(-5)=XPVAL(5)
37326 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
37327 Q2MX=Q2
37328 P2MX=0.36D0
37329 IF(MSTP(55).GE.7) P2MX=4.0D0
37330 IF(MSTP(57).EQ.0) Q2MX=P2MX
37331 P2=0D0
37332 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37333 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37334 DO 140 KFL=-6,6
37335 XPQ(KFL)=XPGA(KFL)
37336 XPVAL(KFL)=VXPDGM(KFL)
37337 140 CONTINUE
37338 VINT(231)=P2MX
37339 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
37340 Q2MX=Q2
37341 P2MX=0.36D0
37342 IF(MSTP(55).GE.11) P2MX=4.0D0
37343 IF(MSTP(57).EQ.0) Q2MX=P2MX
37344 P2=0D0
37345 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37346 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37347 DO 150 KFL=-6,6
37348 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37349 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
37350 150 CONTINUE
37351 VINT(231)=P2MX
37352 ELSEIF(MSTP(56).EQ.2) THEN
37353C...Call PDFLIB parton distributions.
37354 PARM(1)='NPTYPE'
37355 VALUE(1)=3
37356 PARM(2)='NGROUP'
37357 VALUE(2)=MSTP(55)/1000
37358 PARM(3)='NSET'
37359 VALUE(3)=MOD(MSTP(55),1000)
37360 IF(MINT(93).NE.3000000+MSTP(55)) THEN
37361 CALL PDFSET(PARM,VALUE)
37362 MINT(93)=3000000+MSTP(55)
37363 ENDIF
37364 XX=X
37365 QQ2=MAX(0D0,Q2MIN,Q2)
37366 IF(MSTP(57).EQ.0) QQ2=Q2MIN
37367 P2=0D0
37368 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37369 IP2=MSTP(60)
37370 IF(MSTP(55).EQ.5004) THEN
37371 IF(5D0*P2.LT.QQ2.AND.
37372 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
37373 & P2.GE.0D0.AND.P2.LT.10D0.AND.
37374 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
37375 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37376 & BOT,TOP,GLU)
37377 ELSE
37378 UPV=0D0
37379 DNV=0D0
37380 USEA=0D0
37381 DSEA=0D0
37382 STR=0D0
37383 CHM=0D0
37384 BOT=0D0
37385 TOP=0D0
37386 GLU=0D0
37387 ENDIF
37388 ELSE
37389 IF(P2.LT.QQ2) THEN
37390 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
37391 & BOT,TOP,GLU)
37392 ELSE
37393 UPV=0D0
37394 DNV=0D0
37395 USEA=0D0
37396 DSEA=0D0
37397 STR=0D0
37398 CHM=0D0
37399 BOT=0D0
37400 TOP=0D0
37401 GLU=0D0
37402 ENDIF
37403 ENDIF
37404 VINT(231)=Q2MIN
37405 XPQ(0)=GLU
37406 XPQ(1)=DNV
37407 XPQ(-1)=DNV
37408 XPQ(2)=UPV
37409 XPQ(-2)=UPV
37410 XPQ(3)=STR
37411 XPQ(-3)=STR
37412 XPQ(4)=CHM
37413 XPQ(-4)=CHM
37414 XPQ(5)=BOT
37415 XPQ(-5)=BOT
37416 XPQ(6)=TOP
37417 XPQ(-6)=TOP
37418 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
37419 XPVAL(1)=XPVU/4D0
37420 XPVAL(2)=XPVU
37421 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
37422 XPVAL(4)=MIN(XPQ(4),XPVU)
37423 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
37424 XPVAL(-1)=XPVAL(1)
37425 XPVAL(-2)=XPVAL(2)
37426 XPVAL(-3)=XPVAL(3)
37427 XPVAL(-4)=XPVAL(4)
37428 XPVAL(-5)=XPVAL(5)
37429 ELSE
37430 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
37431 ENDIF
37432
37433C...Pion/gammaVDM parton distribution call.
37434 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
37435 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37436 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
37437 & MSTP(55).LE.12) THEN
37438 ISET=1+MOD(MSTP(55)-1,4)
37439 Q2MX=Q2
37440 P2MX=0.36D0
37441 IF(ISET.GE.3) P2MX=4.0D0
37442 IF(MSTP(57).EQ.0) Q2MX=P2MX
37443 P2=0D0
37444 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37445 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
37446 DO 160 KFL=-6,6
37447 XPQ(KFL)=XPVMD(KFL)
37448 XPVAL(KFL)=VXPVMD(KFL)
37449 160 CONTINUE
37450 VINT(231)=P2MX
37451 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
37452 CALL PYPDPI(X,Q2,XPPI)
37453 DO 170 KFL=-6,6
37454 XPQ(KFL)=XPPI(KFL)
37455 170 CONTINUE
37456 XPVAL(2)=XPQ(2)-XPQ(-2)
37457 XPVAL(-1)=XPQ(-1)-XPQ(1)
37458 ELSEIF(MSTP(54).EQ.2) THEN
37459C...Call PDFLIB parton distributions.
37460 PARM(1)='NPTYPE'
37461 VALUE(1)=2
37462 PARM(2)='NGROUP'
37463 VALUE(2)=MSTP(53)/1000
37464 PARM(3)='NSET'
37465 VALUE(3)=MOD(MSTP(53),1000)
37466 IF(MINT(93).NE.2000000+MSTP(53)) THEN
37467 CALL PDFSET(PARM,VALUE)
37468 MINT(93)=2000000+MSTP(53)
37469 ENDIF
37470 XX=X
37471 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37472 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37473 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37474 VINT(231)=Q2MIN
37475 XPQ(0)=GLU
37476 XPQ(1)=DSEA
37477 XPQ(-1)=UPV+DSEA
37478 XPQ(2)=UPV+USEA
37479 XPQ(-2)=USEA
37480 XPQ(3)=STR
37481 XPQ(-3)=STR
37482 XPQ(4)=CHM
37483 XPQ(-4)=CHM
37484 XPQ(5)=BOT
37485 XPQ(-5)=BOT
37486 XPQ(6)=TOP
37487 XPQ(-6)=TOP
37488 XPVAL(2)=UPV
37489 XPVAL(-1)=UPV
37490 ELSE
37491 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
37492 ENDIF
37493
37494C...Anomalous photon parton distribution call.
37495 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
37496 Q2MX=Q2
37497 P2MX=PARP(15)**2
37498 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
37499 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
37500 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
37501 IF(MSTP(57).EQ.0) Q2MX=P2MX
37502 P2=0D0
37503 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37504 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37505 DO 180 KFL=-6,6
37506 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
37507 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
37508 180 CONTINUE
37509 VINT(231)=P2MX
37510 ELSEIF(MSTP(56).EQ.1) THEN
37511 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
37512 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
37513 IF(MSTP(57).EQ.0) Q2MX=P2MX
37514 P2=0D0
37515 IF(VINT(120).LT.0D0) P2=VINT(120)**2
37516 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
37517 DO 190 KFL=-6,6
37518 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37519 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
37520 190 CONTINUE
37521 VINT(231)=P2MX
37522 ELSEIF(MSTP(56).EQ.2) THEN
37523 IF(MSTP(57).EQ.0) Q2MX=P2MX
37524 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
37525 DO 200 KFL=-6,6
37526 XPQ(KFL)=XPGA(KFL)
37527 XPVAL(KFL)=VXPGA(KFL)
37528 200 CONTINUE
37529 VINT(231)=P2MX
37530 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
37531 IF(MSTP(57).EQ.0) Q2MX=P2MX
37532 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37533 DO 210 KFL=-6,6
37534 XPQ(KFL)=XPGA(KFL)
37535 XPVAL(KFL)=VXPGA(KFL)
37536 210 CONTINUE
37537 VINT(231)=P2MX
37538 ELSE
37539 220 RKF=11D0*PYR(0)
37540 KFR=1
37541 IF(RKF.GT.1D0) KFR=2
37542 IF(RKF.GT.5D0) KFR=3
37543 IF(RKF.GT.6D0) KFR=4
37544 IF(RKF.GT.10D0) KFR=5
37545 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
37546 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
37547 IF(MSTP(57).EQ.0) Q2MX=P2MX
37548 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
37549 DO 230 KFL=-6,6
37550 XPQ(KFL)=XPGA(KFL)
37551 XPVAL(KFL)=VXPGA(KFL)
37552 230 CONTINUE
37553 VINT(231)=P2MX
37554 ENDIF
37555
37556C...Proton parton distribution call.
37557 ELSE
37558 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
37559 CALL PYPDPR(X,Q2,XPPR)
37560 DO 240 KFL=-6,6
37561 XPQ(KFL)=XPPR(KFL)
37562 240 CONTINUE
37563 XPVAL(1)=XPQ(1)-XPQ(-1)
37564 XPVAL(2)=XPQ(2)-XPQ(-2)
37565 ELSEIF(MSTP(52).EQ.2) THEN
37566C...Call PDFLIB parton distributions.
37567 PARM(1)='NPTYPE'
37568 VALUE(1)=1
37569 PARM(2)='NGROUP'
37570 VALUE(2)=MSTP(51)/1000
37571 PARM(3)='NSET'
37572 VALUE(3)=MOD(MSTP(51),1000)
37573 IF(MINT(93).NE.1000000+MSTP(51)) THEN
37574 CALL PDFSET(PARM,VALUE)
37575 MINT(93)=1000000+MSTP(51)
37576 ENDIF
37577 XX=X
37578 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
37579 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
37580 CALL STRUCTM_ALICE
37581 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
37582 VINT(231)=Q2MIN
37583 XPQ(0)=GLU
37584 XPQ(1)=DNV+DSEA
37585 XPQ(-1)=DSEA
37586 XPQ(2)=UPV+USEA
37587 XPQ(-2)=USEA
37588 XPQ(3)=STR
37589 XPQ(-3)=STR
37590 XPQ(4)=CHM
37591 XPQ(-4)=CHM
37592 XPQ(5)=BOT
37593 XPQ(-5)=BOT
37594 XPQ(6)=TOP
37595 XPQ(-6)=TOP
37596 XPVAL(1)=DNV
37597 XPVAL(2)=UPV
37598 ELSE
37599 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
37600 ENDIF
37601 ENDIF
37602
37603C...Isospin average for pi0/gammaVDM.
37604 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
37605 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
37606 XPV=XPQ(2)-XPQ(1)
37607 XPQ(2)=XPQ(1)
37608 XPQ(-2)=XPQ(-1)
37609 ELSE
37610 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37611 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37612 XPQ(2)=XPS
37613 XPQ(-1)=XPS
37614 ENDIF
37615 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
37616 & XPVAL(3)+XPVAL(4)+XPVAL(5)
37617 DO 250 KFL=-6,6
37618 XPVAL(KFL)=0D0
37619 250 CONTINUE
37620 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
37621 XPQ(1)=XPQ(1)+0.2D0*XPV
37622 XPQ(2)=XPQ(2)+0.8D0*XPV
37623 XPVAL(1)=0.2D0*XPVL
37624 XPVAL(2)=0.8D0*XPVL
37625 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
37626 XPQ(3)=XPQ(3)+XPV
37627 XPVAL(3)=XPVL
37628 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
37629 XPQ(4)=XPQ(4)+XPV
37630 XPVAL(4)=XPVL
37631 IF(MSTP(55).GE.9) THEN
37632 DO 260 KFL=-6,6
37633 XPQ(KFL)=0D0
37634 260 CONTINUE
37635 ENDIF
37636 ELSE
37637 XPQ(1)=XPQ(1)+0.5D0*XPV
37638 XPQ(2)=XPQ(2)+0.5D0*XPV
37639 XPVAL(1)=0.5D0*XPVL
37640 XPVAL(2)=0.5D0*XPVL
37641 ENDIF
37642 DO 270 KFL=1,6
37643 XPQ(-KFL)=XPQ(KFL)
37644 XPVAL(-KFL)=XPVAL(KFL)
37645 270 CONTINUE
37646
37647C...Rescale for gammaVDM by effective gamma -> rho coupling.
37648C+++Do not rescale?
37649 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
37650 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
37651 DO 280 KFL=-6,6
37652 XPQ(KFL)=VINT(281)*XPQ(KFL)
37653 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
37654 280 CONTINUE
37655 VINT(232)=VINT(281)*XPV
37656 ENDIF
37657
37658C...Simple recipes for kaons.
37659 ELSEIF(KFA.EQ.321) THEN
37660 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
37661 XPQ(-1)=XPQ(1)
37662 XPVAL(-3)=XPVAL(-1)
37663 XPVAL(-1)=0D0
37664 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
37665 XPS=0.5D0*(XPQ(1)+XPQ(-2))
37666 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
37667 XPQ(2)=XPS
37668 XPQ(-1)=XPS
37669 XPQ(1)=XPQ(1)+0.5D0*XPV
37670 XPQ(-1)=XPQ(-1)+0.5D0*XPV
37671 XPQ(3)=XPQ(3)+0.5D0*XPV
37672 XPQ(-3)=XPQ(-3)+0.5D0*XPV
37673 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
37674 XPVAL(2)=0D0
37675 XPVAL(-1)=0D0
37676 XPVAL(1)=0.5D0*XPV
37677 XPVAL(-1)=0.5D0*XPV
37678 XPVAL(3)=0.5D0*XPV
37679 XPVAL(-3)=0.5D0*XPV
37680
37681C...Isospin conjugation for neutron.
37682 ELSEIF(KFA.EQ.2112) THEN
37683 XPSV=XPQ(1)
37684 XPQ(1)=XPQ(2)
37685 XPQ(2)=XPSV
37686 XPSV=XPQ(-1)
37687 XPQ(-1)=XPQ(-2)
37688 XPQ(-2)=XPSV
37689 XPSV=XPVAL(1)
37690 XPVAL(1)=XPVAL(2)
37691 XPVAL(2)=XPSV
37692
37693C...Simple recipes for hyperon (average valence parton distribution).
37694 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
37695 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
37696 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
37697 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
37698 XPQ(1)=XPS
37699 XPQ(2)=XPS
37700 XPQ(-1)=XPS
37701 XPQ(-2)=XPS
37702 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
37703 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
37704 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
37705 XPV=(XPVAL(1)+XPVAL(2))/3D0
37706 XPVAL(1)=0D0
37707 XPVAL(2)=0D0
37708 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
37709 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
37710 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
37711 ENDIF
37712
37713C...Charge conjugation for antiparticle.
37714 IF(KF.LT.0) THEN
37715 DO 290 KFL=1,25
37716 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
37717 XPSV=XPQ(KFL)
37718 XPQ(KFL)=XPQ(-KFL)
37719 XPQ(-KFL)=XPSV
37720 290 CONTINUE
37721 DO 300 KFL=1,6
37722 XPSV=XPVAL(KFL)
37723 XPVAL(KFL)=XPVAL(-KFL)
37724 XPVAL(-KFL)=XPSV
37725 300 CONTINUE
37726 ENDIF
37727
37728C...MULTIPLE INTERACTIONS - PDF RESHAPING.
37729C...Set side.
37730 JS=MINT(30)
37731C...Only reshape PDFs for the non-first interactions;
37732C...But need valence/sea separation already from first interaction.
37733 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
37734 KFVSEL=KFIVAL(JS,1)
37735C...If valence quark kicked out of pi0 or gamma then that decides
37736C...whether we should consider state as d dbar, u ubar, s sbar, etc.
37737 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
37738 XPVL=0D0
37739 DO 310 KFL=1,6
37740 XPVL=XPVL+XPVAL(KFL)
37741 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
37742 XPVAL(KFL)=0D0
37743 310 CONTINUE
37744 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
37745 XPVAL(IABS(KFVSEL))=XPVL
37746 DO 320 KFL=1,6
37747 XPQ(-KFL)=XPQ(KFL)
37748 XPVAL(-KFL)=XPVAL(KFL)
37749 320 CONTINUE
37750
37751C...If valence quark kicked out of K0S or K0S then that decides whether
37752C...we should consider state as d sbar or s dbar.
37753 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
37754 KFS=1
37755 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
37756 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37757 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37758 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37759 XPVAL(-KFS)=0D0
37760 KFS=-3*KFS
37761 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
37762 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
37763 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
37764 XPVAL(-KFS)=0D0
37765 ENDIF
37766
37767C...XPQ distributions are nominal for a (signed) beam particle
37768C...of KF type, with 1-Sum(x_prev) rescaled to 1.
37769 CMPFAC=1D0
37770 NRESC=0
37771 345 NRESC=NRESC+1
37772 PVCTOT(JS,-1)=0D0
37773 PVCTOT(JS, 0)=0D0
37774 PVCTOT(JS, 1)=0D0
37775 DO 350 IFL=-6,6
37776 IF(IFL.EQ.0) GOTO 350
37777
37778C...Count up number of original IFL valence quarks.
37779 IVORG=0
37780 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
37781 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
37782 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
37783C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
37784C...bookkeep as if d dbar (for total momentum sum in valence sector).
37785 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
37786C...Count down number of remaining IFL valence quarks. Skip current
37787C...interaction initiator.
37788 IVREM=IVORG
37789 DO 330 I1=1,NMI(JS)
37790 IF (I1.EQ.MINT(36)) GOTO 330
37791 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
37792 & IVREM=IVREM-1
37793 330 CONTINUE
37794
37795C...Separate out original VALENCE and SEA content.
37796 VAL=XPVAL(IFL)
37797 SEA=MAX(0D0,XPQ(IFL)-VAL)
37798 XPSVC(IFL,0)=VAL
37799 XPSVC(IFL,-1)=SEA
37800
37801C...Rescale valence content if changed.
37802 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
37803 & (VAL*IVREM)/IVORG
37804
37805C...Momentum integrals of original and removed valence quarks.
37806 IF(IVORG.NE.0) THEN
37807C...For p/n/pbar/nbar beams can split into d_val and u_val.
37808C...Isospin conjugation for neutrons
37809 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
37810 IAFLP=IABS(IFL)
37811 IF (KFA.EQ.2112) IAFLP=3-IAFLP
37812 VPAVG=PAVG(IAFLP,Q2)
37813C...For other baryons average d_val and u_val, like for PDFs.
37814 ELSEIF(KFA.GT.1000) THEN
37815 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
37816C...For mesons and photon average d_val and u_val and scale by 3/2.
37817C...Very crude, especially for photon.
37818 ELSE
37819 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
37820 ENDIF
37821 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
37822 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
37823 ENDIF
37824
37825C...Now add companions (at X with partner having been at Z=XASSOC).
37826C...NOTE: due to the assumed simple x scaling, the partner was at what
37827C...corresponds to a higher Z than XASSOC, if there were intermediate
37828C...scatterings. Nothing done about that for the moment.
37829 DO 340 IVC=1,NVC(JS,IFL)
37830C...Skip companions that have been kicked out
37831 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
37832 XPSVC(IFL,IVC)=0D0
37833 GOTO 340
37834 ELSE
37835C...Momentum fraction of the partner quark.
37836C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
37837 XS=XASSOC(JS,IFL,IVC)
37838 XREM=VINT(142+JS)
37839 YS=XS/(XREM+XS)
37840C...Momentum fraction of the companion quark.
37841C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
37842 Y=X*(1D0-YS)
37843 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
37844C...Add to momentum sum, with rescaling compensation factor.
37845 XCFAC=(XREM+XS)/XREM*CMPFAC
37846 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
37847 ENDIF
37848 340 CONTINUE
37849 350 CONTINUE
37850
37851C...Wait until all flavours treated, then rescale seas and gluon.
37852 XPSVC(0,-1)=XPQ(0)
37853 XPSVC(0,0)=0D0
37854 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
37855 IF (RSFAC.LE.0D0) THEN
37856C...First calculate factor needed to exactly restore pz cons.
37857 IF (NRESC.EQ.1) CMPFAC =
37858 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
37859C...Add a bit of headroom
37860 CMPFAC=0.99*CMPFAC
37861C...Try a few times if more headroom is needed, then print error message.
37862 IF (NRESC.LE.10) GOTO 345
37863 CALL PYERRM(15,
37864 & '(PYPDFU:) Negative reshaping factor persists!')
37865 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
37866 RSFAC=0D0
37867 ENDIF
37868 DO 370 IFL=-6,6
37869 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
37870C...Also store resulting distributions in XPQ
37871 XPQ(IFL)=0D0
37872 DO 360 ISVC=-1,NVC(JS,IFL)
37873 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
37874 360 CONTINUE
37875 370 CONTINUE
37876C...Save companion reweighting factor for PYPTIS.
37877 VINT(140)=CMPFAC
37878 ENDIF
37879
37880
37881C...Allow gluon also in position 21.
37882 XPQ(21)=XPQ(0)
37883
37884C...Check positivity and reset above maximum allowed flavour.
37885 DO 380 KFL=-25,25
37886 XPQ(KFL)=MAX(0D0,XPQ(KFL))
37887 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
37888 380 CONTINUE
37889
37890C...Formats for error printouts.
37891 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
37892 5100 FORMAT(' Error: illegal particle code for parton distribution;',
37893 &' KF =',I5)
37894 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
37895 &3I5)
37896 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
37897 & ' Removed valence momentum fraction : ',F6.3/
37898 & ' Added companion momentum fraction : ',F6.3/
37899 & ' Resulting rescale factor : ',F6.3)
37900
37901C...Reset side pointer and return
37902 9999 MINT(30)=0
37903
37904 RETURN
37905 END
37906
37907C*********************************************************************
37908
37909C...PYPDFL
37910C...Gives proton parton distribution at small x and/or Q^2 according to
37911C...correct limiting behaviour.
37912
37913 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
37914
37915C...Double precision and integer declarations.
37916 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37917 IMPLICIT INTEGER(I-N)
37918 INTEGER PYK,PYCHGE,PYCOMP
37919C...Commonblocks.
37920 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37921 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37923 COMMON/PYINT1/MINT(400),VINT(400)
37924 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
37925C...Local arrays.
37926 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
37927 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
37928
37929C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
37930 MINT(92)=0
37931 KFA=IABS(KF)
37932 IACC=0
37933 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
37934 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
37935 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
37936 IF(IACC.EQ.0) THEN
37937 CALL PYPDFU(KF,X,Q2,XPQ)
37938 RETURN
37939 ENDIF
37940
37941C...Reset. Check x.
37942 DO 100 KFL=-25,25
37943 XPQ(KFL)=0D0
37944 100 CONTINUE
37945 IF(X.LE.0D0.OR.X.GE.1D0) THEN
37946 WRITE(MSTU(11),5000) X
37947 RETURN
37948 ENDIF
37949
37950C...Define valence content.
37951 KFC=KF
37952 NV1=2
37953 NV2=1
37954 IF(KF.EQ.2212) THEN
37955 KFV1=2
37956 KFV2=1
37957 ELSEIF(KF.EQ.-2212) THEN
37958 KFV1=-2
37959 KFV2=-1
37960 ELSEIF(KF.EQ.2112) THEN
37961 KFV1=1
37962 KFV2=2
37963 ELSEIF(KF.EQ.-2112) THEN
37964 KFV1=-1
37965 KFV2=-2
37966 ELSEIF(KF.EQ.211) THEN
37967 NV1=1
37968 KFV1=2
37969 KFV2=-1
37970 ELSEIF(KF.EQ.-211) THEN
37971 NV1=1
37972 KFV1=-2
37973 KFV2=1
37974 ELSEIF(MINT(105).LE.223) THEN
37975 KFV1=1
37976 WTV1=0.2D0
37977 KFV2=2
37978 WTV2=0.8D0
37979 ELSEIF(MINT(105).EQ.333) THEN
37980 KFV1=3
37981 WTV1=1.0D0
37982 KFV2=1
37983 WTV2=0.0D0
37984 ELSEIF(MINT(105).EQ.443) THEN
37985 KFV1=4
37986 WTV1=1.0D0
37987 KFV2=1
37988 WTV2=0.0D0
37989 ENDIF
37990
37991C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
37992 MINT30=MINT(30)
37993 CALL PYPDFU(KFC,X,Q2,XPA)
37994 Q2MN=MAX(3D0,VINT(231))
37995 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
37996 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
37997
37998C...Large Q2 and large x: naive call is enough.
37999 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38000 DO 110 KFL=-25,25
38001 XPQ(KFL)=XPA(KFL)
38002 110 CONTINUE
38003 MINT(92)=1
38004
38005C...Small Q2 and large x: dampen boundary value.
38006 ELSEIF(X.GT.XMN) THEN
38007
38008C...Evaluate at boundary and define dampening factors.
38009 MINT(30)=MINT30
38010 CALL PYPDFU(KFC,X,Q2MN,XPA)
38011 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38012 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38013
38014C...Separate valence and sea parts of parton distribution.
38015 IF(KFA.NE.22) THEN
38016 XFV1=XPA(KFV1)-XPA(-KFV1)
38017 XPA(KFV1)=XPA(-KFV1)
38018 XFV2=XPA(KFV2)-XPA(-KFV2)
38019 XPA(KFV2)=XPA(-KFV2)
38020 ELSE
38021 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38022 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38023 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38024 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38025 ENDIF
38026
38027C...Dampen valence and sea separately. Put back together.
38028 DO 120 KFL=-25,25
38029 XPQ(KFL)=FS*XPA(KFL)
38030 120 CONTINUE
38031 IF(KFA.NE.22) THEN
38032 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38033 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38034 ELSE
38035 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38036 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38037 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38038 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38039 ENDIF
38040 MINT(92)=2
38041
38042C...Large Q2 and small x: interpolate behaviour.
38043 ELSEIF(Q2.GT.Q2MN) THEN
38044
38045C...Evaluate at extremes and define coefficients for interpolation.
38046 MINT(30)=MINT30
38047 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38048 VI232A=VINT(232)
38049 MINT(30)=MINT30
38050 CALL PYPDFU(KFC,X,Q2B,XPB)
38051 VI232B=VINT(232)
38052 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38053 FVA=(X/XMN)**0.45D0*FLA
38054 FSA=(X/XMN)**(-0.08D0)*FLA
38055 FB=1D0-FLA
38056
38057C...Separate valence and sea parts of parton distribution.
38058 IF(KFA.NE.22) THEN
38059 XFVA1=XPA(KFV1)-XPA(-KFV1)
38060 XPA(KFV1)=XPA(-KFV1)
38061 XFVA2=XPA(KFV2)-XPA(-KFV2)
38062 XPA(KFV2)=XPA(-KFV2)
38063 XFVB1=XPB(KFV1)-XPB(-KFV1)
38064 XPB(KFV1)=XPB(-KFV1)
38065 XFVB2=XPB(KFV2)-XPB(-KFV2)
38066 XPB(KFV2)=XPB(-KFV2)
38067 ELSE
38068 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38069 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38070 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38071 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38072 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38073 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38074 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38075 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
38076 ENDIF
38077
38078C...Interpolate for valence and sea. Put back together.
38079 DO 130 KFL=-25,25
38080 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
38081 130 CONTINUE
38082 IF(KFA.NE.22) THEN
38083 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
38084 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
38085 ELSE
38086 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38087 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
38088 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38089 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
38090 ENDIF
38091 MINT(92)=3
38092
38093C...Small Q2 and small x: dampen boundary value and add term.
38094 ELSE
38095
38096C...Evaluate at boundary and define dampening factors.
38097 MINT(30)=MINT30
38098 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38099 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
38100 FA=1D0-FB
38101 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
38102 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
38103 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
38104 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
38105 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
38106 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
38107
38108C...Separate valence and sea parts of parton distribution.
38109 IF(KFA.NE.22) THEN
38110 XFV1=XPA(KFV1)-XPA(-KFV1)
38111 XPA(KFV1)=XPA(-KFV1)
38112 XFV2=XPA(KFV2)-XPA(-KFV2)
38113 XPA(KFV2)=XPA(-KFV2)
38114 ELSE
38115 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38116 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38117 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38118 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38119 ENDIF
38120
38121C...Dampen valence and sea separately. Add constant terms.
38122C...Put back together.
38123 DO 140 KFL=-25,25
38124 XPQ(KFL)=FSA*XPA(KFL)
38125 140 CONTINUE
38126 IF(KFA.NE.22) THEN
38127 DO 150 KFL=-3,3
38128 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
38129 150 CONTINUE
38130 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
38131 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
38132 ELSE
38133 DO 160 KFL=-3,3
38134 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
38135 160 CONTINUE
38136 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38137 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
38138 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38139 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
38140 ENDIF
38141 XPQ(21)=XPQ(0)
38142 MINT(92)=4
38143 ENDIF
38144
38145C...Format for error printout.
38146 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38147
38148 RETURN
38149 END
38150
38151C*********************************************************************
38152
38153C...PYPDEL
38154C...Gives electron (or muon, or tau) parton distribution.
38155
38156 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
38157
38158C...Double precision and integer declarations.
38159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38160 IMPLICIT INTEGER(I-N)
38161 INTEGER PYK,PYCHGE,PYCOMP
38162C...Commonblocks.
38163 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38164 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38165 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38166 COMMON/PYINT1/MINT(400),VINT(400)
38167 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38168C...Local arrays.
38169 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
38170
38171C...Interface to PDFLIB.
38172 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38173 SAVE /W50513/
38174 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38175 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38176 CHARACTER*20 PARM(20)
38177 DATA VALUE/20*0D0/,PARM/20*' '/
38178
38179C...Some common constants.
38180 DO 100 KFL=-25,25
38181 XPEL(KFL)=0D0
38182 100 CONTINUE
38183 AEM=PARU(101)
38184 PME=PMAS(11,1)
38185 IF(KFA.EQ.13) PME=PMAS(13,1)
38186 IF(KFA.EQ.15) PME=PMAS(15,1)
38187 XL=LOG(MAX(1D-10,X))
38188 X1L=LOG(MAX(1D-10,1D0-X))
38189 HLE=LOG(MAX(3D0,Q2/PME**2))
38190 HBE2=(AEM/PARU(1))*(HLE-1D0)
38191
38192C...Electron inside electron, see R. Kleiss et al., in Z physics at
38193C...LEP 1, CERN 89-08, p. 34
38194 IF(MSTP(59).LE.1) THEN
38195 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
38196 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
38197 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
38198 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
38199 & 4D0*XL/(1D0-X)-5D0-X)
38200 ELSE
38201 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
38202 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
38203 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
38204 ENDIF
38205C...Zero distribution for very large x and rescale it for intermediate.
38206 IF(X.GT.1D0-1D-10) THEN
38207 HEE=0D0
38208 ELSEIF(X.GT.1D0-1D-7) THEN
38209 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
38210 ENDIF
38211 XPEL(KFA)=X*HEE
38212
38213C...Photon and (transverse) W- inside electron.
38214 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
38215 IF(MSTP(13).LE.1) THEN
38216 HLG=HLE
38217 ELSE
38218 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
38219 ENDIF
38220 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
38221 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
38222 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
38223
38224C...Electron or positron inside photon inside electron.
38225 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
38226 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
38227 & 2D0*X*(1D0+X)*XL)
38228 XPEL(11)=XPEL(11)+XFSEA
38229 XPEL(-11)=XFSEA
38230
38231C...Initialize PDFLIB photon parton distributions.
38232 IF(MSTP(56).EQ.2) THEN
38233 PARM(1)='NPTYPE'
38234 VALUE(1)=3
38235 PARM(2)='NGROUP'
38236 VALUE(2)=MSTP(55)/1000
38237 PARM(3)='NSET'
38238 VALUE(3)=MOD(MSTP(55),1000)
38239 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38240 CALL PDFSET(PARM,VALUE)
38241 MINT(93)=3000000+MSTP(55)
38242 ENDIF
38243 ENDIF
38244
38245C...Quarks and gluons inside photon inside electron:
38246C...numerical convolution required.
38247 DO 110 KFL=0,6
38248 SXP(KFL)=0D0
38249 110 CONTINUE
38250 SUMXPP=0D0
38251 ITER=-1
38252 120 ITER=ITER+1
38253 SUMXP=SUMXPP
38254 NSTP=2**(ITER-1)
38255 IF(ITER.EQ.0) NSTP=2
38256 DO 130 KFL=0,6
38257 SXP(KFL)=0.5D0*SXP(KFL)
38258 130 CONTINUE
38259 WTSTP=0.5D0/NSTP
38260 IF(ITER.EQ.0) WTSTP=0.5D0
38261C...Pick grid of x_{gamma} values logarithmically even.
38262 DO 150 ISTP=1,NSTP
38263 IF(ITER.EQ.0) THEN
38264 XLE=XL*(ISTP-1)
38265 ELSE
38266 XLE=XL*(ISTP-0.5D0)/NSTP
38267 ENDIF
38268 XE=MIN(1D0-1D-10,EXP(XLE))
38269 XG=MIN(1D0-1D-10,X/XE)
38270C...Evaluate photon inside electron parton distribution for convolution.
38271 XPGP=1D0+(1D0-XE)**2
38272 IF(MSTP(13).LE.1) THEN
38273 XPGP=XPGP*HLE
38274 ELSE
38275 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
38276 ENDIF
38277C...Evaluate photon parton distributions for convolution.
38278 IF(MSTP(56).EQ.1) THEN
38279 IF(MSTP(55).EQ.1) THEN
38280 CALL PYPDGA(XG,Q2,XPGA)
38281 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38282 Q2MX=Q2
38283 P2MX=0.36D0
38284 IF(MSTP(55).GE.7) P2MX=4.0D0
38285 IF(MSTP(57).EQ.0) Q2MX=P2MX
38286 P2=0D0
38287 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38288 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38289 VINT(231)=P2MX
38290 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38291 Q2MX=Q2
38292 P2MX=0.36D0
38293 IF(MSTP(55).GE.11) P2MX=4.0D0
38294 IF(MSTP(57).EQ.0) Q2MX=P2MX
38295 P2=0D0
38296 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38297 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38298 VINT(231)=P2MX
38299 ENDIF
38300 DO 140 KFL=0,5
38301 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
38302 140 CONTINUE
38303 ELSEIF(MSTP(56).EQ.2) THEN
38304C...Call PDFLIB parton distributions.
38305 XX=XG
38306 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38307 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38308 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38309 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
38310 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
38311 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
38312 SXP(3)=SXP(3)+WTSTP*XPGP*STR
38313 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
38314 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
38315 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
38316 ENDIF
38317 150 CONTINUE
38318 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
38319 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
38320 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
38321
38322C...Put convolution into output arrays.
38323 FCONV=AEMP*(-XL)
38324 XPEL(0)=FCONV*SXP(0)
38325 DO 160 KFL=1,6
38326 XPEL(KFL)=FCONV*SXP(KFL)
38327 XPEL(-KFL)=XPEL(KFL)
38328 160 CONTINUE
38329 ENDIF
38330
38331 RETURN
38332 END
38333
38334C*********************************************************************
38335
38336C...PYPDGA
38337C...Gives photon parton distribution.
38338
38339 SUBROUTINE PYPDGA(X,Q2,XPGA)
38340
38341C...Double precision and integer declarations.
38342 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38343 IMPLICIT INTEGER(I-N)
38344 INTEGER PYK,PYCHGE,PYCOMP
38345C...Commonblocks.
38346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38347 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38348 COMMON/PYINT1/MINT(400),VINT(400)
38349 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
38350C...Local arrays.
38351 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
38352 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
38353 &DGCS(4,3),DGDS(4,3),DGES(4,3)
38354
38355C...The following data lines are coefficients needed in the
38356C...Drees and Grassie photon parton distribution parametrization.
38357 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
38358 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
38359 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
38360 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
38361 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
38362 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
38363 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
38364 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
38365 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
38366 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
38367 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
38368 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
38369 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
38370 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
38371 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
38372 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
38373 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
38374 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
38375 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
38376 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
38377 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
38378 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
38379 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
38380 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
38381 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
38382 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
38383
38384C...Photon parton distribution from Drees and Grassie.
38385C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
38386 DO 100 KFL=-6,6
38387 XPGA(KFL)=0D0
38388 100 CONTINUE
38389 VINT(231)=1D0
38390 IF(MSTP(57).LE.0) THEN
38391 T=LOG(1D0/0.16D0)
38392 ELSE
38393 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
38394 ENDIF
38395 X1=1D0-X
38396 NF=3
38397 IF(Q2.GT.25D0) NF=4
38398 IF(Q2.GT.300D0) NF=5
38399 NFE=NF-2
38400 AEM=PARU(101)
38401
38402C...Evaluate gluon content.
38403 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
38404 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
38405 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
38406 XPGL=DGA*X**DGB*X1**DGC
38407
38408C...Evaluate up- and down-type quark content.
38409 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
38410 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
38411 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
38412 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
38413 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
38414 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38415 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
38416 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
38417 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
38418 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
38419 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
38420 DGF=9D0
38421 IF(NF.EQ.4) DGF=10D0
38422 IF(NF.EQ.5) DGF=55D0/6D0
38423 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
38424 IF(NF.LE.3) THEN
38425 XPQU=(XPQS+9D0*XPQN)/6D0
38426 XPQD=(XPQS-4.5D0*XPQN)/6D0
38427 ELSEIF(NF.EQ.4) THEN
38428 XPQU=(XPQS+6D0*XPQN)/8D0
38429 XPQD=(XPQS-6D0*XPQN)/8D0
38430 ELSE
38431 XPQU=(XPQS+7.5D0*XPQN)/10D0
38432 XPQD=(XPQS-5D0*XPQN)/10D0
38433 ENDIF
38434
38435C...Put into output arrays.
38436 XPGA(0)=AEM*XPGL
38437 XPGA(1)=AEM*XPQD
38438 XPGA(2)=AEM*XPQU
38439 XPGA(3)=AEM*XPQD
38440 IF(NF.GE.4) XPGA(4)=AEM*XPQU
38441 IF(NF.GE.5) XPGA(5)=AEM*XPQD
38442 DO 110 KFL=1,6
38443 XPGA(-KFL)=XPGA(KFL)
38444 110 CONTINUE
38445
38446 RETURN
38447 END
38448
38449C*********************************************************************
38450
38451C...PYGGAM
38452C...Constructs the F2 and parton distributions of the photon
38453C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
38454C...For F2, c and b are included by the Bethe-Heitler formula;
38455C...in the 'MSbar' scheme additionally a Cgamma term is added.
38456C...Contains the SaS sets 1D, 1M, 2D and 2M.
38457C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38458
38459 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
38460
38461C...Double precision and integer declarations.
38462 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38463 IMPLICIT INTEGER(I-N)
38464 INTEGER PYK,PYCHGE,PYCOMP
38465C...Commonblocks.
38466 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38467 &XPDIR(-6:6)
38468 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38469 SAVE /PYINT8/,/PYINT9/
38470C...Local arrays.
38471 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
38472C...Charm and bottom masses (low to compensate for J/psi etc.).
38473 DATA PMC/1.3D0/, PMB/4.6D0/
38474C...alpha_em and alpha_em/(2*pi).
38475 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
38476C...Lambda value for 4 flavours.
38477 DATA ALAM/0.20D0/
38478C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
38479 DATA FRACU/0.8D0/
38480C...VMD couplings f_V**2/(4*pi).
38481 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
38482C...Masses for rho (=omega) and phi.
38483 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
38484C...Number of points in integration for IP2=1.
38485 DATA NSTEP/100/
38486
38487C...Reset output.
38488 F2GM=0D0
38489 DO 100 KFL=-6,6
38490 XPDFGM(KFL)=0D0
38491 XPVMD(KFL)=0D0
38492 XPANL(KFL)=0D0
38493 XPANH(KFL)=0D0
38494 XPBEH(KFL)=0D0
38495 XPDIR(KFL)=0D0
38496 VXPVMD(KFL)=0D0
38497 VXPANL(KFL)=0D0
38498 VXPANH(KFL)=0D0
38499 VXPDGM(KFL)=0D0
38500 100 CONTINUE
38501
38502C...Set Q0 cut-off parameter as function of set used.
38503 IF(ISET.LE.2) THEN
38504 Q0=0.6D0
38505 ELSE
38506 Q0=2D0
38507 ENDIF
38508 Q02=Q0**2
38509
38510C...Scale choice for off-shell photon; common factors.
38511 Q2A=Q2
38512 FACNOR=1D0
38513 IF(IP2.EQ.1) THEN
38514 P2MX=P2+Q02
38515 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38516 FACNOR=LOG(Q2/Q02)/NSTEP
38517 ELSEIF(IP2.EQ.2) THEN
38518 P2MX=MAX(P2,Q02)
38519 ELSEIF(IP2.EQ.3) THEN
38520 P2MX=P2+Q02
38521 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
38522 ELSEIF(IP2.EQ.4) THEN
38523 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38524 & ((Q2+P2)*(Q02+P2)))
38525 ELSEIF(IP2.EQ.5) THEN
38526 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38527 & ((Q2+P2)*(Q02+P2)))
38528 P2MX=Q0*SQRT(P2MXA)
38529 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
38530 ELSEIF(IP2.EQ.6) THEN
38531 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38532 & ((Q2+P2)*(Q02+P2)))
38533 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38534 ELSE
38535 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
38536 & ((Q2+P2)*(Q02+P2)))
38537 P2MX=Q0*SQRT(P2MXA)
38538 P2MXB=P2MX
38539 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
38540 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
38541 IF(ABS(Q2-Q02).GT.1D-6) THEN
38542 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
38543 ELSEIF(P2.LT.Q02) THEN
38544 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
38545 ELSE
38546 FACNOR=1D0
38547 ENDIF
38548 ENDIF
38549
38550C...Call VMD parametrization for d quark and use to give rho, omega,
38551C...phi. Note dipole dampening for off-shell photon.
38552 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38553 XFVAL=VXPGA(1)
38554 XPGA(1)=XPGA(2)
38555 XPGA(-1)=XPGA(-2)
38556 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
38557 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
38558 DO 110 KFL=-5,5
38559 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
38560 110 CONTINUE
38561 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
38562 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
38563 XPVMD(3)=XPVMD(3)+FACS*XFVAL
38564 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
38565 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
38566 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
38567 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
38568 VXPVMD(2)=FRACU*FACUD*XFVAL
38569 VXPVMD(3)=FACS*XFVAL
38570 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
38571 VXPVMD(-2)=FRACU*FACUD*XFVAL
38572 VXPVMD(-3)=FACS*XFVAL
38573
38574 IF(IP2.NE.1) THEN
38575C...Anomalous parametrizations for different strategies
38576C...for off-shell photons; except full integration.
38577
38578C...Call anomalous parametrization for d + u + s.
38579 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38580 DO 120 KFL=-5,5
38581 XPANL(KFL)=FACNOR*XPGA(KFL)
38582 VXPANL(KFL)=FACNOR*VXPGA(KFL)
38583 120 CONTINUE
38584
38585C...Call anomalous parametrization for c and b.
38586 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38587 DO 130 KFL=-5,5
38588 XPANH(KFL)=FACNOR*XPGA(KFL)
38589 VXPANH(KFL)=FACNOR*VXPGA(KFL)
38590 130 CONTINUE
38591 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
38592 DO 140 KFL=-5,5
38593 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
38594 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
38595 140 CONTINUE
38596
38597 ELSE
38598C...Special option: loop over flavours and integrate over k2.
38599 DO 170 KF=1,5
38600 DO 160 ISTEP=1,NSTEP
38601 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
38602 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
38603 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
38604 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
38605 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
38606 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
38607 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
38608 DO 150 KFL=-5,5
38609 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
38610 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
38611 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
38612 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
38613 150 CONTINUE
38614 160 CONTINUE
38615 170 CONTINUE
38616 ENDIF
38617
38618C...Call Bethe-Heitler term expression for charm and bottom.
38619 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
38620 XPBEH(4)=XPBH
38621 XPBEH(-4)=XPBH
38622 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
38623 XPBEH(5)=XPBH
38624 XPBEH(-5)=XPBH
38625
38626C...For MSbar subtraction call C^gamma term expression for d, u, s.
38627 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
38628 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
38629 DO 180 KFL=-5,5
38630 XPDIR(KFL)=XPGA(KFL)
38631 180 CONTINUE
38632 ENDIF
38633
38634C...Store result in output array.
38635 DO 190 KFL=-5,5
38636 CHSQ=1D0/9D0
38637 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
38638 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38639 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
38640 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
38641 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
38642 190 CONTINUE
38643
38644 RETURN
38645 END
38646
38647C*********************************************************************
38648
38649C...PYGVMD
38650C...Evaluates the VMD parton distributions of a photon,
38651C...evolved homogeneously from an initial scale P2 to Q2.
38652C...Does not include dipole suppression factor.
38653C...ISET is parton distribution set, see above;
38654C...additionally ISET=0 is used for the evolution of an anomalous photon
38655C...which branched at a scale P2 and then evolved homogeneously to Q2.
38656C...ALAM is the 4-flavour Lambda, which is automatically converted
38657C...to 3- and 5-flavour equivalents as needed.
38658C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38659
38660 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38661
38662C...Double precision and integer declarations.
38663 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38664 IMPLICIT INTEGER(I-N)
38665 INTEGER PYK,PYCHGE,PYCOMP
38666C...Local arrays and data.
38667 DIMENSION XPGA(-6:6), VXPGA(-6:6)
38668 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38669
38670C...Reset output.
38671 DO 100 KFL=-6,6
38672 XPGA(KFL)=0D0
38673 VXPGA(KFL)=0D0
38674 100 CONTINUE
38675 KFA=IABS(KF)
38676
38677C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38678 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
38679 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
38680 P2EFF=MAX(P2,1.2D0*ALAM3**2)
38681 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38682 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38683 Q2EFF=MAX(Q2,P2EFF)
38684
38685C...Find number of flavours at lower and upper scale.
38686 NFP=4
38687 IF(P2EFF.LT.PMC**2) NFP=3
38688 IF(P2EFF.GT.PMB**2) NFP=5
38689 NFQ=4
38690 IF(Q2EFF.LT.PMC**2) NFQ=3
38691 IF(Q2EFF.GT.PMB**2) NFQ=5
38692
38693C...Find s as sum of 3-, 4- and 5-flavour parts.
38694 S=0D0
38695 IF(NFP.EQ.3) THEN
38696 Q2DIV=PMC**2
38697 IF(NFQ.EQ.3) Q2DIV=Q2EFF
38698 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
38699 ENDIF
38700 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
38701 P2DIV=P2EFF
38702 IF(NFP.EQ.3) P2DIV=PMC**2
38703 Q2DIV=Q2EFF
38704 IF(NFQ.EQ.5) Q2DIV=PMB**2
38705 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
38706 ENDIF
38707 IF(NFQ.EQ.5) THEN
38708 P2DIV=PMB**2
38709 IF(NFP.EQ.5) P2DIV=P2EFF
38710 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
38711 ENDIF
38712
38713C...Calculate frequent combinations of x and s.
38714 X1=1D0-X
38715 XL=-LOG(X)
38716 S2=S**2
38717 S3=S**3
38718 S4=S**4
38719
38720C...Evaluate homogeneous anomalous parton distributions below or
38721C...above threshold.
38722 IF(ISET.EQ.0) THEN
38723 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38724 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38725 XVAL = X * 1.5D0 * (X**2+X1**2)
38726 XGLU = 0D0
38727 XSEA = 0D0
38728 ELSE
38729 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
38730 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
38731 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
38732 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
38733 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
38734 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
38735 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
38736 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
38737 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
38738 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
38739 & (2D0*X-1D0)*X*XL**2)
38740 ENDIF
38741
38742C...Evaluate set 1D parton distributions below or above threshold.
38743 ELSEIF(ISET.EQ.1) THEN
38744 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38745 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38746 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
38747 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
38748 XSEA = 0.100D0 * X1**3.76D0
38749 ELSE
38750 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
38751 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
38752 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
38753 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
38754 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
38755 & X**0.40D0 * X1**(1.76D0+3D0*S)
38756 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
38757 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
38758 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
38759 XSEA0 = 0.100D0 * X1**3.76D0
38760 ENDIF
38761
38762C...Evaluate set 1M parton distributions below or above threshold.
38763 ELSEIF(ISET.EQ.2) THEN
38764 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38765 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38766 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
38767 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
38768 XSEA = 0D0
38769 ELSE
38770 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
38771 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
38772 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
38773 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
38774 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
38775 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
38776 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
38777 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
38778 & XL**(2.8D0*S)
38779 XSEA0 = 0D0
38780 ENDIF
38781
38782C...Evaluate set 2D parton distributions below or above threshold.
38783 ELSEIF(ISET.EQ.3) THEN
38784 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38785 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38786 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
38787 XGLU = 1.925D0 * X1**2
38788 XSEA = 0.242D0 * X1**4
38789 ELSE
38790 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
38791 & X**(0.46D0+0.25D0*S) *
38792 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
38793 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
38794 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
38795 & EXP(-18.67D0*S) *
38796 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
38797 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
38798 & XL**(9.3D0*S/(1D0+1.7D0*S))
38799 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
38800 & (1D0-0.607D0*S+21.95D0*S2) *
38801 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
38802 XSEA0 = 0.242D0 * X1**4
38803 ENDIF
38804
38805C...Evaluate set 2M parton distributions below or above threshold.
38806 ELSEIF(ISET.EQ.4) THEN
38807 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
38808 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
38809 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
38810 XGLU = 1.808D0 * X1**2
38811 XSEA = 0.209D0 * X1**4
38812 ELSE
38813 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
38814 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
38815 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
38816 & XL**(5.15D0*S/(1D0+2D0*S)) +
38817 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
38818 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
38819 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
38820 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
38821 & XL**(10.9D0*S/(1D0+2.5D0*S))
38822 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
38823 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
38824 & X1**(4D0+S) * XL**(0.45D0*S)
38825 XSEA0 = 0.209D0 * X1**4
38826 ENDIF
38827 ENDIF
38828
38829C...Threshold factors for c and b sea.
38830 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
38831 XCHM=0D0
38832 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38833 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38834 IF(ISET.EQ.0) THEN
38835 XCHM=XSEA*(1D0-(SCH/SLL)**2)
38836 ELSE
38837 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
38838 ENDIF
38839 ENDIF
38840 XBOT=0D0
38841 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
38842 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
38843 IF(ISET.EQ.0) THEN
38844 XBOT=XSEA*(1D0-(SBT/SLL)**2)
38845 ELSE
38846 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
38847 ENDIF
38848 ENDIF
38849
38850C...Fill parton distributions.
38851 XPGA(0)=XGLU
38852 XPGA(1)=XSEA
38853 XPGA(2)=XSEA
38854 XPGA(3)=XSEA
38855 XPGA(4)=XCHM
38856 XPGA(5)=XBOT
38857 XPGA(KFA)=XPGA(KFA)+XVAL
38858 DO 110 KFL=1,5
38859 XPGA(-KFL)=XPGA(KFL)
38860 110 CONTINUE
38861 VXPGA(KFA)=XVAL
38862 VXPGA(-KFA)=XVAL
38863
38864 RETURN
38865 END
38866
38867C*********************************************************************
38868
38869C...PYGANO
38870C...Evaluates the parton distributions of the anomalous photon,
38871C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
38872C...KF=0 gives the sum over (up to) 5 flavours,
38873C...KF<0 limits to flavours up to abs(KF),
38874C...KF>0 is for flavour KF only.
38875C...ALAM is the 4-flavour Lambda, which is automatically converted
38876C...to 3- and 5-flavour equivalents as needed.
38877C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
38878
38879 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
38880
38881C...Double precision and integer declarations.
38882 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38883 IMPLICIT INTEGER(I-N)
38884 INTEGER PYK,PYCHGE,PYCOMP
38885C...Local arrays and data.
38886 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
38887 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
38888
38889C...Reset output.
38890 DO 100 KFL=-6,6
38891 XPGA(KFL)=0D0
38892 VXPGA(KFL)=0D0
38893 100 CONTINUE
38894 IF(Q2.LE.P2) RETURN
38895 KFA=IABS(KF)
38896
38897C...Calculate Lambda; protect against unphysical Q2 and P2 input.
38898 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
38899 ALAMSQ(4)=ALAM**2
38900 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
38901 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
38902 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
38903 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
38904 Q2EFF=MAX(Q2,P2EFF)
38905 XL=-LOG(X)
38906
38907C...Find number of flavours at lower and upper scale.
38908 NFP=4
38909 IF(P2EFF.LT.PMC**2) NFP=3
38910 IF(P2EFF.GT.PMB**2) NFP=5
38911 NFQ=4
38912 IF(Q2EFF.LT.PMC**2) NFQ=3
38913 IF(Q2EFF.GT.PMB**2) NFQ=5
38914
38915C...Define range of flavour loop.
38916 IF(KF.EQ.0) THEN
38917 KFLMN=1
38918 KFLMX=5
38919 ELSEIF(KF.LT.0) THEN
38920 KFLMN=1
38921 KFLMX=KFA
38922 ELSE
38923 KFLMN=KFA
38924 KFLMX=KFA
38925 ENDIF
38926
38927C...Loop over flavours the photon can branch into.
38928 DO 110 KFL=KFLMN,KFLMX
38929
38930C...Light flavours: calculate t range and (approximate) s range.
38931 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
38932 TDIFF=LOG(Q2EFF/P2EFF)
38933 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38934 & LOG(P2EFF/ALAMSQ(NFQ)))
38935 IF(NFQ.GT.NFP) THEN
38936 Q2DIV=PMB**2
38937 IF(NFQ.EQ.4) Q2DIV=PMC**2
38938 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38939 & LOG(P2EFF/ALAMSQ(NFQ)))
38940 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38941 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38942 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38943 ENDIF
38944 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
38945 Q2DIV=PMC**2
38946 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
38947 & LOG(P2EFF/ALAMSQ(4)))
38948 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
38949 & LOG(P2EFF/ALAMSQ(3)))
38950 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
38951 ENDIF
38952
38953C...u and s quark do not need a separate treatment when d has been done.
38954 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
38955
38956C...Charm: as above, but only include range above c threshold.
38957 ELSEIF(KFL.EQ.4) THEN
38958 IF(Q2.LE.PMC**2) GOTO 110
38959 P2EFF=MAX(P2EFF,PMC**2)
38960 Q2EFF=MAX(Q2EFF,P2EFF)
38961 TDIFF=LOG(Q2EFF/P2EFF)
38962 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38963 & LOG(P2EFF/ALAMSQ(NFQ)))
38964 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
38965 Q2DIV=PMB**2
38966 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
38967 & LOG(P2EFF/ALAMSQ(NFQ)))
38968 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
38969 & LOG(P2EFF/ALAMSQ(NFQ-1)))
38970 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
38971 ENDIF
38972
38973C...Bottom: as above, but only include range above b threshold.
38974 ELSEIF(KFL.EQ.5) THEN
38975 IF(Q2.LE.PMB**2) GOTO 110
38976 P2EFF=MAX(P2EFF,PMB**2)
38977 Q2EFF=MAX(Q2,P2EFF)
38978 TDIFF=LOG(Q2EFF/P2EFF)
38979 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
38980 & LOG(P2EFF/ALAMSQ(NFQ)))
38981 ENDIF
38982
38983C...Evaluate flavour-dependent prefactor (charge^2 etc.).
38984 CHSQ=1D0/9D0
38985 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
38986 FAC=AEM2PI*2D0*CHSQ*TDIFF
38987
38988C...Evaluate parton distributions (normalized to unit momentum sum).
38989 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
38990 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
38991 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
38992 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
38993 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
38994 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
38995 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
38996 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
38997 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
38998 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
38999 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39000 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39001
39002C...Threshold factors for c and b sea.
39003 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39004 XCHM=0D0
39005 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39006 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39007 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39008 ENDIF
39009 XBOT=0D0
39010 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39011 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39012 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39013 ENDIF
39014 ENDIF
39015
39016C...Add contribution of each valence flavour.
39017 XPGA(0)=XPGA(0)+FAC*XGLU
39018 XPGA(1)=XPGA(1)+FAC*XSEA
39019 XPGA(2)=XPGA(2)+FAC*XSEA
39020 XPGA(3)=XPGA(3)+FAC*XSEA
39021 XPGA(4)=XPGA(4)+FAC*XCHM
39022 XPGA(5)=XPGA(5)+FAC*XBOT
39023 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39024 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39025 110 CONTINUE
39026 DO 120 KFL=1,5
39027 XPGA(-KFL)=XPGA(KFL)
39028 VXPGA(-KFL)=VXPGA(KFL)
39029 120 CONTINUE
39030
39031 RETURN
39032 END
39033
39034
39035C*********************************************************************
39036
39037C...PYGBEH
39038C...Evaluates the Bethe-Heitler cross section for heavy flavour
39039C...production.
39040C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39041
39042 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39043
39044C...Double precision and integer declarations.
39045 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39046 IMPLICIT INTEGER(I-N)
39047 INTEGER PYK,PYCHGE,PYCOMP
39048
39049C...Local data.
39050 DATA AEM2PI/0.0011614D0/
39051
39052C...Reset output.
39053 XPBH=0D0
39054 SIGBH=0D0
39055
39056C...Check kinematics limits.
39057 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39058 W2=Q2*(1D0-X)/X-P2
39059 BETA2=1D0-4D0*PM2/W2
39060 IF(BETA2.LT.1D-10) RETURN
39061 BETA=SQRT(BETA2)
39062 RMQ=4D0*PM2/Q2
39063
39064C...Simple case: P2 = 0.
39065 IF(P2.LT.1D-4) THEN
39066 IF(BETA.LT.0.99D0) THEN
39067 XBL=LOG((1D0+BETA)/(1D0-BETA))
39068 ELSE
39069 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39070 ENDIF
39071 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39072 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39073
39074C...Complicated case: P2 > 0, based on approximation of
39075C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
39076 ELSE
39077 RPQ=1D0-4D0*X**2*P2/Q2
39078 IF(RPQ.GT.1D-10) THEN
39079 RPBE=SQRT(RPQ*BETA2)
39080 IF(RPBE.LT.0.99D0) THEN
39081 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
39082 XBI=2D0*RPBE/(1D0-RPBE**2)
39083 ELSE
39084 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
39085 XBL=LOG((1D0+RPBE)**2/RPBESN)
39086 XBI=2D0*RPBE/RPBESN
39087 ENDIF
39088 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
39089 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
39090 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
39091 ENDIF
39092 ENDIF
39093
39094C...Multiply by charge-squared etc. to get parton distribution.
39095 CHSQ=1D0/9D0
39096 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
39097 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
39098
39099 RETURN
39100 END
39101
39102C*********************************************************************
39103
39104C...PYGDIR
39105C...Evaluates the direct contribution, i.e. the C^gamma term,
39106C...as needed in MSbar parametrizations.
39107C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39108
39109 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
39110
39111C...Double precision and integer declarations.
39112 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39113 IMPLICIT INTEGER(I-N)
39114 INTEGER PYK,PYCHGE,PYCOMP
39115C...Local array and data.
39116 DIMENSION XPGA(-6:6)
39117 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
39118
39119C...Reset output.
39120 DO 100 KFL=-6,6
39121 XPGA(KFL)=0D0
39122 100 CONTINUE
39123
39124C...Evaluate common x-dependent expression.
39125 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
39126 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
39127
39128C...d, u, s part by simple charge factor.
39129 XPGA(1)=(1D0/9D0)*CGAM
39130 XPGA(2)=(4D0/9D0)*CGAM
39131 XPGA(3)=(1D0/9D0)*CGAM
39132
39133C...Also fill for antiquarks.
39134 DO 110 KF=1,5
39135 XPGA(-KF)=XPGA(KF)
39136 110 CONTINUE
39137
39138 RETURN
39139 END
39140
39141C*********************************************************************
39142
39143C...PYPDPI
39144C...Gives pi+ parton distribution according to two different
39145C...parametrizations.
39146
39147 SUBROUTINE PYPDPI(X,Q2,XPPI)
39148
39149C...Double precision and integer declarations.
39150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39151 IMPLICIT INTEGER(I-N)
39152 INTEGER PYK,PYCHGE,PYCOMP
39153C...Commonblocks.
39154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39155 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39156 COMMON/PYINT1/MINT(400),VINT(400)
39157 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39158C...Local arrays.
39159 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
39160
39161C...The following data lines are coefficients needed in the
39162C...Owens pion parton distribution parametrizations, see below.
39163C...Expansion coefficients for up and down valence quark distributions.
39164 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
39165 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39166 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39167 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39168 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
39169 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39170 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
39171 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
39172C...Expansion coefficients for gluon distribution.
39173 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
39174 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
39175 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
39176 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
39177 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
39178 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
39179 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
39180 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
39181C...Expansion coefficients for (up+down+strange) quark sea distribution.
39182 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
39183 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39184 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
39185 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
39186 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
39187 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
39188 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
39189 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
39190C...Expansion coefficients for charm quark sea distribution.
39191 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
39192 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
39193 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
39194 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
39195 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
39196 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
39197 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
39198 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
39199
39200C...Euler's beta function, requires ordinary Gamma function
39201 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
39202
39203C...Reset output array.
39204 DO 100 KFL=-6,6
39205 XPPI(KFL)=0D0
39206 100 CONTINUE
39207
39208 IF(MSTP(53).LE.2) THEN
39209C...Pion parton distributions from Owens.
39210C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
39211
39212C...Determine set, Lambda and s expansion variable.
39213 NSET=MSTP(53)
39214 IF(NSET.EQ.1) ALAM=0.2D0
39215 IF(NSET.EQ.2) ALAM=0.4D0
39216 VINT(231)=4D0
39217 IF(MSTP(57).LE.0) THEN
39218 SD=0D0
39219 ELSE
39220 Q2IN=MIN(2D3,MAX(4D0,Q2))
39221 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
39222 ENDIF
39223
39224C...Calculate parton distributions.
39225 DO 120 KFL=1,4
39226 DO 110 IS=1,5
39227 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
39228 & COW(3,IS,KFL,NSET)*SD**2
39229 110 CONTINUE
39230 IF(KFL.EQ.1) THEN
39231 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
39232 ELSE
39233 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
39234 & TS(5)*X**2)
39235 ENDIF
39236 120 CONTINUE
39237
39238C...Put into output array.
39239 XPPI(0)=XQ(2)
39240 XPPI(1)=XQ(3)/6D0
39241 XPPI(2)=XQ(1)+XQ(3)/6D0
39242 XPPI(3)=XQ(3)/6D0
39243 XPPI(4)=XQ(4)
39244 XPPI(-1)=XQ(1)+XQ(3)/6D0
39245 XPPI(-2)=XQ(3)/6D0
39246 XPPI(-3)=XQ(3)/6D0
39247 XPPI(-4)=XQ(4)
39248
39249C...Leading order pion parton distributions from Glueck, Reya and Vogt.
39250C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
39251C...10^-5 < x < 1.
39252 ELSE
39253
39254C...Determine s expansion variable and some x expressions.
39255 VINT(231)=0.25D0
39256 IF(MSTP(57).LE.0) THEN
39257 SD=0D0
39258 ELSE
39259 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
39260 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
39261 ENDIF
39262 SD2=SD**2
39263 XL=-LOG(X)
39264 XS=SQRT(X)
39265
39266C...Evaluate valence, gluon and sea distributions.
39267 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
39268 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
39269 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
39270 & SD-0.175D0*SD2)+
39271 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
39272 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
39273 & XL)))*
39274 & (1D0-X)**(0.390D0+1.053D0*SD)
39275 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
39276 & X)**3.359D0*
39277 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
39278 & XL))/
39279 & XL**(2.538D0-0.763D0*SD)
39280 IF(SD.LE.0.888D0) THEN
39281 XFCHM=0D0
39282 ELSE
39283 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
39284 & 0.771D0*SD)*
39285 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
39286 & XL))
39287 ENDIF
39288 IF(SD.LE.1.351D0) THEN
39289 XFBOT=0D0
39290 ELSE
39291 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
39292 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
39293 & XL))
39294 ENDIF
39295
39296C...Put into output array.
39297 XPPI(0)=XFGLU
39298 XPPI(1)=XFSEA
39299 XPPI(2)=XFSEA
39300 XPPI(3)=XFSEA
39301 XPPI(4)=XFCHM
39302 XPPI(5)=XFBOT
39303 DO 130 KFL=1,5
39304 XPPI(-KFL)=XPPI(KFL)
39305 130 CONTINUE
39306 XPPI(2)=XPPI(2)+XFVAL
39307 XPPI(-1)=XPPI(-1)+XFVAL
39308 ENDIF
39309
39310 RETURN
39311 END
39312
39313C*********************************************************************
39314
39315C...PYPDPR
39316C...Gives proton parton distributions according to a few different
39317C...parametrizations.
39318
39319 SUBROUTINE PYPDPR(X,Q2,XPPR)
39320
39321C...Double precision and integer declarations.
39322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39323 IMPLICIT INTEGER(I-N)
39324 INTEGER PYK,PYCHGE,PYCOMP
39325C...Commonblocks.
39326 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39327 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39328 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39329 COMMON/PYINT1/MINT(400),VINT(400)
39330 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39331C...Arrays and data.
39332 DIMENSION XPPR(-6:6),Q2MIN(16)
39333 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
39334 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
39335
39336C...Reset output array.
39337 DO 100 KFL=-6,6
39338 XPPR(KFL)=0D0
39339 100 CONTINUE
39340
39341C...Common preliminaries.
39342 NSET=MAX(1,MIN(16,MSTP(51)))
39343 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
39344 VINT(231)=Q2MIN(NSET)
39345 IF(MSTP(57).EQ.0) THEN
39346 Q2L=Q2MIN(NSET)
39347 ELSE
39348 Q2L=MAX(Q2MIN(NSET),Q2)
39349 ENDIF
39350
39351 IF(NSET.GE.1.AND.NSET.LE.3) THEN
39352C...Interface to the CTEQ 3 parton distributions.
39353 QRT=SQRT(MAX(1D0,Q2L))
39354
39355C...Loop over flavours.
39356 DO 110 I=-6,6
39357 IF(I.LE.0) THEN
39358 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
39359 ELSEIF(I.LE.2) THEN
39360 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
39361 ELSE
39362 XPPR(I)=XPPR(-I)
39363 ENDIF
39364 110 CONTINUE
39365
39366 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
39367C...Interface to the GRV 94 distributions.
39368 IF(NSET.EQ.4) THEN
39369 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39370 ELSEIF(NSET.EQ.5) THEN
39371 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39372 ELSE
39373 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39374 ENDIF
39375
39376C...Put into output array.
39377 XPPR(0)=GL
39378 XPPR(-1)=0.5D0*(UDB+DEL)
39379 XPPR(-2)=0.5D0*(UDB-DEL)
39380 XPPR(-3)=SB
39381 XPPR(-4)=CHM
39382 XPPR(-5)=BOT
39383 XPPR(1)=DV+XPPR(-1)
39384 XPPR(2)=UV+XPPR(-2)
39385 XPPR(3)=SB
39386 XPPR(4)=CHM
39387 XPPR(5)=BOT
39388
39389 ELSEIF(NSET.EQ.7) THEN
39390C...Interface to the CTEQ 5L parton distributions.
39391C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
39392C...freezing x*f(x,Q2) at borders.
39393 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39394 XIN=MAX(1D-6,MIN(1D0,X))
39395
39396C...Loop over flavours (with u <-> d notation mismatch).
39397 SUMUDB=PYCT5L(-1,XIN,QRT)
39398 RATUDB=PYCT5L(-2,XIN,QRT)
39399 DO 120 I=-5,2
39400 IF(I.EQ.1) THEN
39401 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
39402 ELSEIF(I.EQ.2) THEN
39403 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
39404 ELSEIF(I.EQ.-1) THEN
39405 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39406 ELSEIF(I.EQ.-2) THEN
39407 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39408 ELSE
39409 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
39410 IF(I.LT.0) XPPR(-I)=XPPR(I)
39411 ENDIF
39412 120 CONTINUE
39413
39414 ELSEIF(NSET.EQ.8) THEN
39415C...Interface to the CTEQ 5M1 parton distributions.
39416 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
39417 XIN=MAX(1D-6,MIN(1D0,X))
39418
39419C...Loop over flavours (with u <-> d notation mismatch).
39420 SUMUDB=PYCT5M(-1,XIN,QRT)
39421 RATUDB=PYCT5M(-2,XIN,QRT)
39422 DO 130 I=-5,2
39423 IF(I.EQ.1) THEN
39424 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
39425 ELSEIF(I.EQ.2) THEN
39426 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
39427 ELSEIF(I.EQ.-1) THEN
39428 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
39429 ELSEIF(I.EQ.-2) THEN
39430 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
39431 ELSE
39432 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
39433 IF(I.LT.0) XPPR(-I)=XPPR(I)
39434 ENDIF
39435 130 CONTINUE
39436
39437 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
39438C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
39439C...obsolete but offers backwards compatibility.
39440 CALL PYPDPO(X,Q2L,XPPR)
39441
39442C...Symmetric choice for debugging only
39443 ELSEIF(NSET.EQ.16) THEN
39444 XPPR(0)=.5D0/X
39445 XPPR(1)=.05D0/X
39446 XPPR(2)=.05D0/X
39447 XPPR(3)=.05D0/X
39448 XPPR(4)=.05D0/X
39449 XPPR(5)=.05D0/X
39450 XPPR(-1)=.05D0/X
39451 XPPR(-2)=.05D0/X
39452 XPPR(-3)=.05D0/X
39453 XPPR(-4)=.05D0/X
39454 XPPR(-5)=.05D0/X
39455
39456 ENDIF
39457
39458 RETURN
39459 END
39460
39461C*********************************************************************
39462
39463C...PYCTEQ
39464C...Gives the CTEQ 3 parton distribution function sets in
39465C...parametrized form, of October 24, 1994.
39466C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
39467C...J. Qiu, W.K. Tung and H. Weerts.
39468
39469 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
39470
39471C...Double precision declaration.
39472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39473 IMPLICIT INTEGER(I-N)
39474
39475C...Data on Lambda values of fits, minimum Q and quark masses.
39476 DIMENSION ALM(3), QMS(4:6)
39477 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
39478 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
39479
39480C....Check flavour thresholds. Set up QI for SB.
39481 IP = IABS(IPRT)
39482 IF(IP .GE. 4) THEN
39483 IF(Q .LE. QMS(IP)) THEN
39484 PYCTEQ = 0D0
39485 RETURN
39486 ENDIF
39487 QI = QMS(IP)
39488 ELSE
39489 QI = QMN
39490 ENDIF
39491
39492C...Use "standard lambda" of parametrization program for expansion.
39493 ALAM = ALM (ISET)
39494 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
39495 SB = LOG (SBL)
39496 SB2 = SB*SB
39497 SB3 = SB2*SB
39498
39499C...Expansion for CTEQ3L.
39500 IF(ISET .EQ. 1) THEN
39501 IF(IPRT .EQ. 2) THEN
39502 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
39503 & 0.3171D+00*SB3)
39504 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
39505 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
39506 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
39507 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
39508 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
39509 ELSEIF(IPRT .EQ. 1) THEN
39510 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
39511 & 0.7728D+00*SB3)
39512 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
39513 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
39514 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
39515 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
39516 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
39517 ELSEIF(IPRT .EQ. 0) THEN
39518 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
39519 & 0.5343D+00*SB3)
39520 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
39521 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
39522 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
39523 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
39524 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
39525 ELSEIF(IPRT .EQ. -1) THEN
39526 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
39527 & 0.2031D+01*SB3)
39528 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
39529 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
39530 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
39531 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
39532 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
39533 ELSEIF(IPRT .EQ. -2) THEN
39534 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
39535 & 0.9872D-01*SB3)
39536 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
39537 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
39538 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
39539 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
39540 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
39541 ELSEIF(IPRT .EQ. -3) THEN
39542 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
39543 & 0.8390D+00*SB3)
39544 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
39545 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
39546 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
39547 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
39548 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
39549 ELSEIF(IPRT .EQ. -4) THEN
39550 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
39551 & 0.1651D-01*SB2)
39552 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
39553 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
39554 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
39555 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
39556 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
39557 ELSEIF(IPRT .EQ. -5) THEN
39558 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
39559 & 0.3702D+01*SB2)
39560 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
39561 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
39562 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
39563 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
39564 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
39565 ELSEIF(IPRT .EQ. -6) THEN
39566 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
39567 & 0.6943D+00*SB2)
39568 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
39569 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
39570 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
39571 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
39572 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
39573 ENDIF
39574
39575C...Expansion for CTEQ3M.
39576 ELSEIF(ISET .EQ. 2) THEN
39577 IF(IPRT .EQ. 2) THEN
39578 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
39579 & 0.2935D+00*SB3)
39580 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
39581 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
39582 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
39583 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
39584 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
39585 ELSEIF(IPRT .EQ. 1) THEN
39586 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
39587 & 0.4305D-01*SB3)
39588 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
39589 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
39590 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
39591 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
39592 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
39593 ELSEIF(IPRT .EQ. 0) THEN
39594 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
39595 & 0.1037D-01*SB3)
39596 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
39597 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
39598 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
39599 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
39600 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
39601 ELSEIF(IPRT .EQ. -1) THEN
39602 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
39603 & 0.1602D+01*SB3)
39604 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
39605 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
39606 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
39607 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
39608 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
39609 ELSEIF(IPRT .EQ. -2) THEN
39610 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
39611 & 0.2496D+00*SB3)
39612 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
39613 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
39614 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
39615 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
39616 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
39617 ELSEIF(IPRT .EQ. -3) THEN
39618 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
39619 & 0.1936D+01*SB3)
39620 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
39621 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
39622 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
39623 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
39624 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
39625 ELSEIF(IPRT .EQ. -4) THEN
39626 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
39627 & 0.5348D+00*SB2)
39628 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
39629 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
39630 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
39631 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
39632 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
39633 ELSEIF(IPRT .EQ. -5) THEN
39634 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
39635 & 0.1569D+01*SB2)
39636 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
39637 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
39638 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
39639 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
39640 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
39641 ELSEIF(IPRT .EQ. -6) THEN
39642 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
39643 & 0.8838D+01*SB2)
39644 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
39645 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
39646 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
39647 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
39648 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
39649 ENDIF
39650
39651C...Expansion for CTEQ3D.
39652 ELSEIF(ISET .EQ. 3) THEN
39653 IF(IPRT .EQ. 2) THEN
39654 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
39655 & 0.2902D+00*SB3)
39656 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
39657 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
39658 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
39659 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
39660 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
39661 ELSEIF(IPRT .EQ. 1) THEN
39662 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
39663 & 0.7257D+00*SB3)
39664 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
39665 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
39666 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
39667 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
39668 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
39669 ELSEIF(IPRT .EQ. 0) THEN
39670 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
39671 & 0.2734D-04*SB3)
39672 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
39673 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
39674 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
39675 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
39676 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
39677 ELSEIF(IPRT .EQ. -1) THEN
39678 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
39679 & 0.1671D+01*SB3)
39680 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
39681 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
39682 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
39683 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
39684 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
39685 ELSEIF(IPRT .EQ. -2) THEN
39686 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
39687 & 0.2223D+00*SB3)
39688 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
39689 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
39690 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
39691 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
39692 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
39693 ELSEIF(IPRT .EQ. -3) THEN
39694 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
39695 & 0.1937D+01*SB3)
39696 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
39697 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
39698 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
39699 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
39700 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
39701 ELSEIF(IPRT .EQ. -4) THEN
39702 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
39703 & 0.5137D+00*SB2)
39704 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
39705 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
39706 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
39707 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
39708 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
39709 ELSEIF(IPRT .EQ. -5) THEN
39710 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
39711 & 0.2143D+01*SB2)
39712 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
39713 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
39714 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
39715 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
39716 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
39717 ELSEIF(IPRT .EQ. -6) THEN
39718 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
39719 & 0.9998D+01*SB2)
39720 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
39721 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
39722 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
39723 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
39724 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
39725 ENDIF
39726 ENDIF
39727
39728C...Calculation of x * f(x, Q).
39729 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
39730 & *(LOG(1D0+1D0/X))**A5 )
39731
39732 RETURN
39733 END
39734
39735C*********************************************************************
39736
39737C...PYGRVL
39738C...Gives the GRV 94 L (leading order) parton distribution function set
39739C...in parametrized form.
39740C...Authors: M. Glueck, E. Reya and A. Vogt.
39741
39742 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39743
39744C...Double precision declaration.
39745 IMPLICIT DOUBLE PRECISION (A - Z)
39746
39747C...Common expressions.
39748 MU2 = 0.23D0
39749 LAM2 = 0.2322D0 * 0.2322D0
39750 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39751 DS = SQRT (S)
39752 S2 = S * S
39753 S3 = S2 * S
39754
39755C...uv :
39756 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
39757 AKU = 0.590D0 - 0.024D0 * S
39758 BKU = 0.131D0 + 0.063D0 * S
39759 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
39760 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
39761 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
39762 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
39763 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39764
39765C...dv :
39766 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
39767 AKD = 0.376D0
39768 BKD = 0.486D0 + 0.062D0 * S
39769 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
39770 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
39771 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
39772 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
39773 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39774
39775C...del :
39776 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
39777 AKE = 0.409D0 - 0.005D0 * S
39778 BKE = 0.799D0 + 0.071D0 * S
39779 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
39780 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
39781 CE = 0.0D0
39782 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
39783 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39784
39785C...udb :
39786 ALX = 1.451D0
39787 BEX = 0.271D0
39788 AKX = 0.410D0 - 0.232D0 * S
39789 BKX = 0.534D0 - 0.457D0 * S
39790 AGX = 0.890D0 - 0.140D0 * S
39791 BGX = -0.981D0
39792 CX = 0.320D0 + 0.683D0 * S
39793 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
39794 EX = 4.119D0 + 1.713D0 * S
39795 ESX = 0.682D0 + 2.978D0 * S
39796 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39797 & DX, EX, ESX)
39798
39799C...sb :
39800 STS = 0D0
39801 ALS = 0.914D0
39802 BES = 0.577D0
39803 AKS = 1.798D0 - 0.596D0 * S
39804 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
39805 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
39806 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
39807 EST = 3.981D0 + 1.638D0 * S
39808 ESS = 6.402D0
39809 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39810
39811C...cb :
39812 STC = 0.888D0
39813 ALC = 1.01D0
39814 BEC = 0.37D0
39815 AKC = 0D0
39816 AC = 0D0
39817 BC = 4.24D0 - 0.804D0 * S
39818 DCT = 3.46D0 - 1.076D0 * S
39819 ECT = 4.61D0 + 1.49D0 * S
39820 ESC = 2.555D0 + 1.961D0 * S
39821 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39822
39823C...bb :
39824 STB = 1.351D0
39825 ALB = 1.00D0
39826 BEB = 0.51D0
39827 AKB = 0D0
39828 AB = 0D0
39829 BB = 1.848D0
39830 DBT = 2.929D0 + 1.396D0 * S
39831 EBT = 4.71D0 + 1.514D0 * S
39832 ESB = 4.02D0 + 1.239D0 * S
39833 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39834
39835C...gl :
39836 ALG = 0.524D0
39837 BEG = 1.088D0
39838 AKG = 1.742D0 - 0.930D0 * S
39839 BKG = - 0.399D0 * S2
39840 AG = 7.486D0 - 2.185D0 * S
39841 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
39842 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
39843 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
39844 EG = 0.807D0 + 2.005D0 * S
39845 ESG = 3.841D0 + 0.316D0 * S
39846 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
39847 & DG, EG, ESG)
39848
39849 RETURN
39850 END
39851
39852C*********************************************************************
39853
39854C...PYGRVM
39855C...Gives the GRV 94 M (MSbar) parton distribution function set
39856C...in parametrized form.
39857C...Authors: M. Glueck, E. Reya and A. Vogt.
39858
39859 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39860
39861C...Double precision declaration.
39862 IMPLICIT DOUBLE PRECISION (A - Z)
39863
39864C...Common expressions.
39865 MU2 = 0.34D0
39866 LAM2 = 0.248D0 * 0.248D0
39867 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39868 DS = SQRT (S)
39869 S2 = S * S
39870 S3 = S2 * S
39871
39872C...uv :
39873 NU = 1.304D0 + 0.863D0 * S
39874 AKU = 0.558D0 - 0.020D0 * S
39875 BKU = 0.183D0 * S
39876 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
39877 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
39878 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
39879 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
39880 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39881
39882C...dv :
39883 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
39884 AKD = 0.270D0 - 0.019D0 * S
39885 BKD = 0.260D0
39886 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
39887 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
39888 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
39889 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
39890 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
39891
39892C...del :
39893 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
39894 AKE = 0.409D0 - 0.007D0 * S
39895 BKE = 0.782D0 + 0.082D0 * S
39896 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
39897 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
39898 CE = 0.0D0
39899 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
39900 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
39901
39902C...udb :
39903 ALX = 0.877D0
39904 BEX = 0.561D0
39905 AKX = 0.275D0
39906 BKX = 0.0D0
39907 AGX = 0.997D0
39908 BGX = 3.210D0 - 1.866D0 * S
39909 CX = 7.300D0
39910 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
39911 EX = 3.077D0 + 1.446D0 * S
39912 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
39913 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
39914 & DX, EX, ESX)
39915
39916C...sb :
39917 STS = 0D0
39918 ALS = 0.756D0
39919 BES = 0.216D0
39920 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
39921 AS = -4.329D0 + 1.131D0 * S
39922 BS = 9.568D0 - 1.744D0 * S
39923 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
39924 EST = 3.031D0 + 1.639D0 * S
39925 ESS = 5.837D0 + 0.815D0 * S
39926 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
39927
39928C...cb :
39929 STC = 0.820D0
39930 ALC = 0.98D0
39931 BEC = 0D0
39932 AKC = -0.625D0 - 0.523D0 * S
39933 AC = 0D0
39934 BC = 1.896D0 + 1.616D0 * S
39935 DCT = 4.12D0 + 0.683D0 * S
39936 ECT = 4.36D0 + 1.328D0 * S
39937 ESC = 0.677D0 + 0.679D0 * S
39938 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
39939
39940C...bb :
39941 STB = 1.297D0
39942 ALB = 0.99D0
39943 BEB = 0D0
39944 AKB = - 0.193D0 * S
39945 AB = 0D0
39946 BB = 0D0
39947 DBT = 3.447D0 + 0.927D0 * S
39948 EBT = 4.68D0 + 1.259D0 * S
39949 ESB = 1.892D0 + 2.199D0 * S
39950 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
39951
39952C...gl :
39953 ALG = 1.014D0
39954 BEG = 1.738D0
39955 AKG = 1.724D0 + 0.157D0 * S
39956 BKG = 0.800D0 + 1.016D0 * S
39957 AG = 7.517D0 - 2.547D0 * S
39958 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
39959 CG = 4.039D0 + 1.491D0 * S
39960 DG = 3.404D0 + 0.830D0 * S
39961 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
39962 ESG = 3.256D0 - 0.436D0 * S
39963 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
39964
39965 RETURN
39966 END
39967
39968C*********************************************************************
39969
39970C...PYGRVD
39971C...Gives the GRV 94 D (DIS) parton distribution function set
39972C...in parametrized form.
39973C...Authors: M. Glueck, E. Reya and A. Vogt.
39974
39975 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
39976
39977C...Double precision declaration.
39978 IMPLICIT DOUBLE PRECISION (A - Z)
39979
39980C...Common expressions.
39981 MU2 = 0.34D0
39982 LAM2 = 0.248D0 * 0.248D0
39983 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
39984 DS = SQRT (S)
39985 S2 = S * S
39986 S3 = S2 * S
39987
39988C...uv :
39989 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
39990 AKU = 0.563D0 - 0.025D0 * S
39991 BKU = 0.054D0 + 0.154D0 * S
39992 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
39993 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
39994 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
39995 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
39996 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
39997
39998C...dv :
39999 ND = 0.156D0 - 0.017D0 * S
40000 AKD = 0.299D0 - 0.022D0 * S
40001 BKD = 0.259D0 - 0.015D0 * S
40002 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40003 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40004 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40005 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40006 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40007
40008C...del :
40009 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40010 AKE = 0.419D0 - 0.013D0 * S
40011 BKE = 1.064D0 - 0.038D0 * S
40012 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40013 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40014 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40015 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40016 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40017
40018C...udb :
40019 ALX = 1.215D0
40020 BEX = 0.466D0
40021 AKX = 0.326D0 + 0.150D0 * S
40022 BKX = 0.956D0 + 0.405D0 * S
40023 AGX = 0.272D0
40024 BGX = 3.794D0 - 2.359D0 * DS
40025 CX = 2.014D0
40026 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40027 EX = 3.049D0 + 1.597D0 * S
40028 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40029 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40030 & DX, EX, ESX)
40031
40032C...sb :
40033 STS = 0D0
40034 ALS = 0.175D0
40035 BES = 0.344D0
40036 AKS = 1.415D0 - 0.641D0 * DS
40037 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40038 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40039 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40040 EST = 4.546D0 + 0.372D0 * S2
40041 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40042 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40043
40044C...cb :
40045 STC = 0.820D0
40046 ALC = 0.98D0
40047 BEC = 0D0
40048 AKC = -0.625D0 - 0.523D0 * S
40049 AC = 0D0
40050 BC = 1.896D0 + 1.616D0 * S
40051 DCT = 4.12D0 + 0.683D0 * S
40052 ECT = 4.36D0 + 1.328D0 * S
40053 ESC = 0.677D0 + 0.679D0 * S
40054 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40055
40056C...bb :
40057 STB = 1.297D0
40058 ALB = 0.99D0
40059 BEB = 0D0
40060 AKB = - 0.193D0 * S
40061 AB = 0D0
40062 BB = 0D0
40063 DBT = 3.447D0 + 0.927D0 * S
40064 EBT = 4.68D0 + 1.259D0 * S
40065 ESB = 1.892D0 + 2.199D0 * S
40066 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40067
40068C...gl :
40069 ALG = 1.258D0
40070 BEG = 1.846D0
40071 AKG = 2.423D0
40072 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40073 AG = 25.09D0 - 7.935D0 * S
40074 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
40075 CG = 590.3D0 - 173.8D0 * S
40076 DG = 5.196D0 + 1.857D0 * S
40077 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
40078 ESG = 3.232D0 - 0.542D0 * S
40079 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40080
40081 RETURN
40082 END
40083
40084C*********************************************************************
40085
40086C...PYGRVV
40087C...Auxiliary for the GRV 94 parton distribution functions
40088C...for u and d valence and d-u sea.
40089C...Authors: M. Glueck, E. Reya and A. Vogt.
40090
40091 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
40092
40093C...Double precision declaration.
40094 IMPLICIT DOUBLE PRECISION (A - Z)
40095
40096C...Evaluation.
40097 DX = SQRT (X)
40098 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
40099 & (1D0- X)**D
40100
40101 RETURN
40102 END
40103
40104C*********************************************************************
40105
40106C...PYGRVW
40107C...Auxiliary for the GRV 94 parton distribution functions
40108C...for d+u sea and gluon.
40109C...Authors: M. Glueck, E. Reya and A. Vogt.
40110
40111 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
40112
40113C...Double precision declaration.
40114 IMPLICIT DOUBLE PRECISION (A - Z)
40115
40116C...Evaluation.
40117 LX = LOG (1D0/X)
40118 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
40119 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
40120
40121 RETURN
40122 END
40123
40124C*********************************************************************
40125
40126C...PYGRVS
40127C...Auxiliary for the GRV 94 parton distribution functions
40128C...for s, c and b sea.
40129C...Authors: M. Glueck, E. Reya and A. Vogt.
40130
40131 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
40132
40133C...Double precision declaration.
40134 IMPLICIT DOUBLE PRECISION (A - Z)
40135
40136C...Evaluation.
40137 IF(S.LE.STH) THEN
40138 PYGRVS = 0D0
40139 ELSE
40140 DX = SQRT (X)
40141 LX = LOG (1D0/X)
40142 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
40143 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
40144 ENDIF
40145
40146 RETURN
40147 END
40148
40149C*********************************************************************
40150
40151C...PYCT5L
40152C...Auxiliary function for parametrization of CTEQ5L.
40153C...Author: J. Pumplin 9/99.
40154
40155C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
40156C...in Parametrized Form
40157C... September 15, 1999
40158C
40159C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
40160C... CTEQ5 PPARTON DISTRIBUTIONS"
40161C...hep-ph/9903282
40162
40163C...The CTEQ5M1 set given here is an updated version of the original
40164C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
40165C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
40166C...almost all applications.
40167C...The improvement is in the QCD evolution which is now more
40168C...accurate, and which agrees completely with the benchmark work
40169C...of the HERA 96/97 Workshop.
40170C...The differences between the parametrized and the corresponding
40171C...table versions (on which it is based) are of similar order as
40172C...between the two version.
40173
40174C...!! Because accurate parametrizations over a wide range of (x,Q)
40175C...is hard to obtain, only the most widely used sets CTEQ5M and
40176C...CTEQ5L are available in parametrized form for now.
40177
40178C...These parametrizations were obtained by Jon Pumplin.
40179
40180C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
40181C -------------------------------------------------------------------
40182C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
40183C 3 CTEQ5L Leading Order 0.127 192 146
40184C -------------------------------------------------------------------
40185C...Note the Qcd-lambda values given for CTEQ5L is for the leading
40186C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
40187C...calibration.
40188
40189C...The two Iset value are adopted to agree with the standard table
40190C...versions.
40191
40192C...Range of validity:
40193C...The range of (x, Q) covered by this parametrization of the QCD
40194C...evolved parton distributions is 1E-6 < x < 1 ;
40195C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
40196C...data only in a subset of that region; and the assumed DGLAP
40197C...evolution is unlikely to be valid for all of it either.
40198
40199C...The range of (x, Q) used in the CTEQ5 round of global analysis is
40200C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
40201C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
40202C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
40203
40204 FUNCTION PYCT5L(IFL,X,Q)
40205
40206C...Double precision declaration.
40207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40208 IMPLICIT INTEGER(I-N)
40209
40210 PARAMETER (NEX=8, NLF=2)
40211 DIMENSION AM(0:NEX,0:NLF,-5:2)
40212 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40213 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40214 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40215 DIMENSION AF(0:NEX)
40216
40217 DATA MEXVEC( 2) / 8 /
40218 DATA MLFVEC( 2) / 2 /
40219 DATA UT1VEC( 2) / 0.4971265E+01 /
40220 DATA UT2VEC( 2) / -0.1105128E+01 /
40221 DATA ALFVEC( 2) / 0.2987216E+00 /
40222 DATA QMAVEC( 2) / 0.0000000E+00 /
40223 DATA (AM( 0,K, 2),K=0, 2)
40224 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
40225 DATA (AM( 1,K, 2),K=0, 2)
40226 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
40227 DATA (AM( 2,K, 2),K=0, 2)
40228 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
40229 DATA (AM( 3,K, 2),K=0, 2)
40230 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
40231 DATA (AM( 4,K, 2),K=0, 2)
40232 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
40233 DATA (AM( 5,K, 2),K=0, 2)
40234 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
40235 DATA (AM( 6,K, 2),K=0, 2)
40236 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
40237 DATA (AM( 7,K, 2),K=0, 2)
40238 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
40239 DATA (AM( 8,K, 2),K=0, 2)
40240 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
40241
40242 DATA MEXVEC( 1) / 8 /
40243 DATA MLFVEC( 1) / 2 /
40244 DATA UT1VEC( 1) / 0.2612618E+01 /
40245 DATA UT2VEC( 1) / -0.1258304E+06 /
40246 DATA ALFVEC( 1) / 0.3407552E+00 /
40247 DATA QMAVEC( 1) / 0.0000000E+00 /
40248 DATA (AM( 0,K, 1),K=0, 2)
40249 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
40250 DATA (AM( 1,K, 1),K=0, 2)
40251 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
40252 DATA (AM( 2,K, 1),K=0, 2)
40253 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
40254 DATA (AM( 3,K, 1),K=0, 2)
40255 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
40256 DATA (AM( 4,K, 1),K=0, 2)
40257 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
40258 DATA (AM( 5,K, 1),K=0, 2)
40259 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
40260 DATA (AM( 6,K, 1),K=0, 2)
40261 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
40262 DATA (AM( 7,K, 1),K=0, 2)
40263 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
40264 DATA (AM( 8,K, 1),K=0, 2)
40265 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
40266
40267 DATA MEXVEC( 0) / 8 /
40268 DATA MLFVEC( 0) / 2 /
40269 DATA UT1VEC( 0) / -0.4656819E+00 /
40270 DATA UT2VEC( 0) / -0.2742390E+03 /
40271 DATA ALFVEC( 0) / 0.4491863E+00 /
40272 DATA QMAVEC( 0) / 0.0000000E+00 /
40273 DATA (AM( 0,K, 0),K=0, 2)
40274 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
40275 DATA (AM( 1,K, 0),K=0, 2)
40276 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
40277 DATA (AM( 2,K, 0),K=0, 2)
40278 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
40279 DATA (AM( 3,K, 0),K=0, 2)
40280 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
40281 DATA (AM( 4,K, 0),K=0, 2)
40282 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
40283 DATA (AM( 5,K, 0),K=0, 2)
40284 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
40285 DATA (AM( 6,K, 0),K=0, 2)
40286 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
40287 DATA (AM( 7,K, 0),K=0, 2)
40288 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
40289 DATA (AM( 8,K, 0),K=0, 2)
40290 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
40291
40292 DATA MEXVEC(-1) / 8 /
40293 DATA MLFVEC(-1) / 2 /
40294 DATA UT1VEC(-1) / 0.3862583E+01 /
40295 DATA UT2VEC(-1) / -0.1265969E+01 /
40296 DATA ALFVEC(-1) / 0.2457668E+00 /
40297 DATA QMAVEC(-1) / 0.0000000E+00 /
40298 DATA (AM( 0,K,-1),K=0, 2)
40299 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
40300 DATA (AM( 1,K,-1),K=0, 2)
40301 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
40302 DATA (AM( 2,K,-1),K=0, 2)
40303 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
40304 DATA (AM( 3,K,-1),K=0, 2)
40305 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
40306 DATA (AM( 4,K,-1),K=0, 2)
40307 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
40308 DATA (AM( 5,K,-1),K=0, 2)
40309 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
40310 DATA (AM( 6,K,-1),K=0, 2)
40311 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
40312 DATA (AM( 7,K,-1),K=0, 2)
40313 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
40314 DATA (AM( 8,K,-1),K=0, 2)
40315 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
40316
40317 DATA MEXVEC(-2) / 7 /
40318 DATA MLFVEC(-2) / 2 /
40319 DATA UT1VEC(-2) / 0.1895615E+00 /
40320 DATA UT2VEC(-2) / -0.3069097E+01 /
40321 DATA ALFVEC(-2) / 0.5293999E+00 /
40322 DATA QMAVEC(-2) / 0.0000000E+00 /
40323 DATA (AM( 0,K,-2),K=0, 2)
40324 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
40325 DATA (AM( 1,K,-2),K=0, 2)
40326 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
40327 DATA (AM( 2,K,-2),K=0, 2)
40328 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
40329 DATA (AM( 3,K,-2),K=0, 2)
40330 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
40331 DATA (AM( 4,K,-2),K=0, 2)
40332 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
40333 DATA (AM( 5,K,-2),K=0, 2)
40334 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
40335 DATA (AM( 6,K,-2),K=0, 2)
40336 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
40337 DATA (AM( 7,K,-2),K=0, 2)
40338 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
40339
40340 DATA MEXVEC(-3) / 7 /
40341 DATA MLFVEC(-3) / 2 /
40342 DATA UT1VEC(-3) / 0.3753257E+01 /
40343 DATA UT2VEC(-3) / -0.1113085E+01 /
40344 DATA ALFVEC(-3) / 0.3713141E+00 /
40345 DATA QMAVEC(-3) / 0.0000000E+00 /
40346 DATA (AM( 0,K,-3),K=0, 2)
40347 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
40348 DATA (AM( 1,K,-3),K=0, 2)
40349 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
40350 DATA (AM( 2,K,-3),K=0, 2)
40351 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
40352 DATA (AM( 3,K,-3),K=0, 2)
40353 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
40354 DATA (AM( 4,K,-3),K=0, 2)
40355 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
40356 DATA (AM( 5,K,-3),K=0, 2)
40357 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
40358 DATA (AM( 6,K,-3),K=0, 2)
40359 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
40360 DATA (AM( 7,K,-3),K=0, 2)
40361 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
40362
40363 DATA MEXVEC(-4) / 7 /
40364 DATA MLFVEC(-4) / 2 /
40365 DATA UT1VEC(-4) / 0.4400772E+01 /
40366 DATA UT2VEC(-4) / -0.1356116E+01 /
40367 DATA ALFVEC(-4) / 0.3712017E-01 /
40368 DATA QMAVEC(-4) / 0.1300000E+01 /
40369 DATA (AM( 0,K,-4),K=0, 2)
40370 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
40371 DATA (AM( 1,K,-4),K=0, 2)
40372 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
40373 DATA (AM( 2,K,-4),K=0, 2)
40374 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
40375 DATA (AM( 3,K,-4),K=0, 2)
40376 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
40377 DATA (AM( 4,K,-4),K=0, 2)
40378 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
40379 DATA (AM( 5,K,-4),K=0, 2)
40380 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
40381 DATA (AM( 6,K,-4),K=0, 2)
40382 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
40383 DATA (AM( 7,K,-4),K=0, 2)
40384 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
40385
40386 DATA MEXVEC(-5) / 6 /
40387 DATA MLFVEC(-5) / 2 /
40388 DATA UT1VEC(-5) / 0.5562568E+01 /
40389 DATA UT2VEC(-5) / -0.1801317E+01 /
40390 DATA ALFVEC(-5) / 0.4952010E-02 /
40391 DATA QMAVEC(-5) / 0.4500000E+01 /
40392 DATA (AM( 0,K,-5),K=0, 2)
40393 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
40394 DATA (AM( 1,K,-5),K=0, 2)
40395 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
40396 DATA (AM( 2,K,-5),K=0, 2)
40397 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
40398 DATA (AM( 3,K,-5),K=0, 2)
40399 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
40400 DATA (AM( 4,K,-5),K=0, 2)
40401 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
40402 DATA (AM( 5,K,-5),K=0, 2)
40403 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
40404 DATA (AM( 6,K,-5),K=0, 2)
40405 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
40406
40407 IF(Q .LE. QMAVEC(IFL)) THEN
40408 PYCT5L = 0.D0
40409 RETURN
40410 ENDIF
40411
40412 IF(X .GE. 1.D0) THEN
40413 PYCT5L = 0.D0
40414 RETURN
40415 ENDIF
40416
40417 TMP = LOG(Q/ALFVEC(IFL))
40418 IF(TMP .LE. 0.D0) THEN
40419 PYCT5L = 0.D0
40420 RETURN
40421 ENDIF
40422
40423 SB = LOG(TMP)
40424 SB1 = SB - 1.2D0
40425 SB2 = SB1*SB1
40426
40427 DO 110 I = 0, NEX
40428 AF(I) = 0.D0
40429 SBX = 1.D0
40430 DO 100 K = 0, MLFVEC(IFL)
40431 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40432 SBX = SB1*SBX
40433 100 CONTINUE
40434 110 CONTINUE
40435
40436 Y = -LOG(X)
40437 U = LOG(X/0.00001D0)
40438
40439 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40440 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40441 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40442 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40443 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40444
40445 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40446
40447C...Include threshold factor.
40448 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
40449
40450 RETURN
40451 END
40452
40453C*********************************************************************
40454
40455C...PYCT5M
40456C...Auxiliary function for parametrization of CTEQ5M1.
40457C...Author: J. Pumplin 9/99.
40458
40459 FUNCTION PYCT5M(IFL,X,Q)
40460
40461C...Double precision declaration.
40462 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40463 IMPLICIT INTEGER(I-N)
40464
40465 PARAMETER (NEX=8, NLF=2)
40466 DIMENSION AM(0:NEX,0:NLF,-5:2)
40467 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
40468 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
40469 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
40470 DIMENSION AF(0:NEX)
40471
40472 DATA MEXVEC( 2) / 8 /
40473 DATA MLFVEC( 2) / 2 /
40474 DATA UT1VEC( 2) / 0.5141718E+01 /
40475 DATA UT2VEC( 2) / -0.1346944E+01 /
40476 DATA ALFVEC( 2) / 0.5260555E+00 /
40477 DATA QMAVEC( 2) / 0.0000000E+00 /
40478 DATA (AM( 0,K, 2),K=0, 2)
40479 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
40480 DATA (AM( 1,K, 2),K=0, 2)
40481 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
40482 DATA (AM( 2,K, 2),K=0, 2)
40483 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
40484 DATA (AM( 3,K, 2),K=0, 2)
40485 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
40486 DATA (AM( 4,K, 2),K=0, 2)
40487 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
40488 DATA (AM( 5,K, 2),K=0, 2)
40489 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
40490 DATA (AM( 6,K, 2),K=0, 2)
40491 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
40492 DATA (AM( 7,K, 2),K=0, 2)
40493 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
40494 DATA (AM( 8,K, 2),K=0, 2)
40495 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
40496
40497 DATA MEXVEC( 1) / 8 /
40498 DATA MLFVEC( 1) / 2 /
40499 DATA UT1VEC( 1) / 0.4138426E+01 /
40500 DATA UT2VEC( 1) / -0.3221374E+01 /
40501 DATA ALFVEC( 1) / 0.4960962E+00 /
40502 DATA QMAVEC( 1) / 0.0000000E+00 /
40503 DATA (AM( 0,K, 1),K=0, 2)
40504 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
40505 DATA (AM( 1,K, 1),K=0, 2)
40506 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
40507 DATA (AM( 2,K, 1),K=0, 2)
40508 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
40509 DATA (AM( 3,K, 1),K=0, 2)
40510 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
40511 DATA (AM( 4,K, 1),K=0, 2)
40512 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
40513 DATA (AM( 5,K, 1),K=0, 2)
40514 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
40515 DATA (AM( 6,K, 1),K=0, 2)
40516 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
40517 DATA (AM( 7,K, 1),K=0, 2)
40518 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
40519 DATA (AM( 8,K, 1),K=0, 2)
40520 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
40521
40522 DATA MEXVEC( 0) / 8 /
40523 DATA MLFVEC( 0) / 2 /
40524 DATA UT1VEC( 0) / -0.1026789E+01 /
40525 DATA UT2VEC( 0) / -0.9051707E+01 /
40526 DATA ALFVEC( 0) / 0.9462977E+00 /
40527 DATA QMAVEC( 0) / 0.0000000E+00 /
40528 DATA (AM( 0,K, 0),K=0, 2)
40529 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
40530 DATA (AM( 1,K, 0),K=0, 2)
40531 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
40532 DATA (AM( 2,K, 0),K=0, 2)
40533 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
40534 DATA (AM( 3,K, 0),K=0, 2)
40535 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
40536 DATA (AM( 4,K, 0),K=0, 2)
40537 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
40538 DATA (AM( 5,K, 0),K=0, 2)
40539 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
40540 DATA (AM( 6,K, 0),K=0, 2)
40541 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
40542 DATA (AM( 7,K, 0),K=0, 2)
40543 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
40544 DATA (AM( 8,K, 0),K=0, 2)
40545 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
40546
40547 DATA MEXVEC(-1) / 8 /
40548 DATA MLFVEC(-1) / 2 /
40549 DATA UT1VEC(-1) / 0.5243571E+01 /
40550 DATA UT2VEC(-1) / -0.2870513E+01 /
40551 DATA ALFVEC(-1) / 0.6701448E+00 /
40552 DATA QMAVEC(-1) / 0.0000000E+00 /
40553 DATA (AM( 0,K,-1),K=0, 2)
40554 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
40555 DATA (AM( 1,K,-1),K=0, 2)
40556 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
40557 DATA (AM( 2,K,-1),K=0, 2)
40558 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
40559 DATA (AM( 3,K,-1),K=0, 2)
40560 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
40561 DATA (AM( 4,K,-1),K=0, 2)
40562 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
40563 DATA (AM( 5,K,-1),K=0, 2)
40564 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
40565 DATA (AM( 6,K,-1),K=0, 2)
40566 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
40567 DATA (AM( 7,K,-1),K=0, 2)
40568 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
40569 DATA (AM( 8,K,-1),K=0, 2)
40570 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
40571
40572 DATA MEXVEC(-2) / 7 /
40573 DATA MLFVEC(-2) / 2 /
40574 DATA UT1VEC(-2) / 0.4782210E+01 /
40575 DATA UT2VEC(-2) / -0.1976856E+02 /
40576 DATA ALFVEC(-2) / 0.7558374E+00 /
40577 DATA QMAVEC(-2) / 0.0000000E+00 /
40578 DATA (AM( 0,K,-2),K=0, 2)
40579 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
40580 DATA (AM( 1,K,-2),K=0, 2)
40581 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
40582 DATA (AM( 2,K,-2),K=0, 2)
40583 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
40584 DATA (AM( 3,K,-2),K=0, 2)
40585 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
40586 DATA (AM( 4,K,-2),K=0, 2)
40587 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
40588 DATA (AM( 5,K,-2),K=0, 2)
40589 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
40590 DATA (AM( 6,K,-2),K=0, 2)
40591 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
40592 DATA (AM( 7,K,-2),K=0, 2)
40593 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
40594
40595 DATA MEXVEC(-3) / 7 /
40596 DATA MLFVEC(-3) / 2 /
40597 DATA UT1VEC(-3) / 0.4518239E+01 /
40598 DATA UT2VEC(-3) / -0.2690590E+01 /
40599 DATA ALFVEC(-3) / 0.6124079E+00 /
40600 DATA QMAVEC(-3) / 0.0000000E+00 /
40601 DATA (AM( 0,K,-3),K=0, 2)
40602 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
40603 DATA (AM( 1,K,-3),K=0, 2)
40604 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
40605 DATA (AM( 2,K,-3),K=0, 2)
40606 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
40607 DATA (AM( 3,K,-3),K=0, 2)
40608 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
40609 DATA (AM( 4,K,-3),K=0, 2)
40610 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
40611 DATA (AM( 5,K,-3),K=0, 2)
40612 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
40613 DATA (AM( 6,K,-3),K=0, 2)
40614 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
40615 DATA (AM( 7,K,-3),K=0, 2)
40616 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
40617
40618 DATA MEXVEC(-4) / 7 /
40619 DATA MLFVEC(-4) / 2 /
40620 DATA UT1VEC(-4) / 0.2783230E+01 /
40621 DATA UT2VEC(-4) / -0.1746328E+01 /
40622 DATA ALFVEC(-4) / 0.1115653E+01 /
40623 DATA QMAVEC(-4) / 0.1300000E+01 /
40624 DATA (AM( 0,K,-4),K=0, 2)
40625 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
40626 DATA (AM( 1,K,-4),K=0, 2)
40627 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
40628 DATA (AM( 2,K,-4),K=0, 2)
40629 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
40630 DATA (AM( 3,K,-4),K=0, 2)
40631 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
40632 DATA (AM( 4,K,-4),K=0, 2)
40633 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
40634 DATA (AM( 5,K,-4),K=0, 2)
40635 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
40636 DATA (AM( 6,K,-4),K=0, 2)
40637 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
40638 DATA (AM( 7,K,-4),K=0, 2)
40639 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
40640
40641 DATA MEXVEC(-5) / 6 /
40642 DATA MLFVEC(-5) / 2 /
40643 DATA UT1VEC(-5) / 0.1619654E+02 /
40644 DATA UT2VEC(-5) / -0.3367346E+01 /
40645 DATA ALFVEC(-5) / 0.5109891E-02 /
40646 DATA QMAVEC(-5) / 0.4500000E+01 /
40647 DATA (AM( 0,K,-5),K=0, 2)
40648 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
40649 DATA (AM( 1,K,-5),K=0, 2)
40650 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
40651 DATA (AM( 2,K,-5),K=0, 2)
40652 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
40653 DATA (AM( 3,K,-5),K=0, 2)
40654 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
40655 DATA (AM( 4,K,-5),K=0, 2)
40656 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
40657 DATA (AM( 5,K,-5),K=0, 2)
40658 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
40659 DATA (AM( 6,K,-5),K=0, 2)
40660 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
40661
40662 IF(Q .LE. QMAVEC(IFL)) THEN
40663 PYCT5M = 0.D0
40664 RETURN
40665 ENDIF
40666
40667 IF(X .GE. 1.D0) THEN
40668 PYCT5M = 0.D0
40669 RETURN
40670 ENDIF
40671
40672 TMP = LOG(Q/ALFVEC(IFL))
40673 IF(TMP .LE. 0.D0) THEN
40674 PYCT5M = 0.D0
40675 RETURN
40676 ENDIF
40677
40678 SB = LOG(TMP)
40679 SB1 = SB - 1.2D0
40680 SB2 = SB1*SB1
40681
40682 DO 110 I = 0, NEX
40683 AF(I) = 0.D0
40684 SBX = 1.D0
40685 DO 100 K = 0, MLFVEC(IFL)
40686 AF(I) = AF(I) + SBX*AM(I,K,IFL)
40687 SBX = SB1*SBX
40688 100 CONTINUE
40689 110 CONTINUE
40690
40691 Y = -LOG(X)
40692 U = LOG(X/0.00001D0)
40693
40694 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
40695 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
40696 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
40697 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
40698 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
40699
40700 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
40701
40702C...Include threshold factor.
40703 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
40704
40705 RETURN
40706 END
40707
40708C*********************************************************************
40709
40710C...PYPDPO
40711C...Auxiliary to PYPDPR. Gives proton parton distributions according to
40712C...a few older parametrizations, now obsolete but convenient for
40713C...backwards checks.
40714
40715 SUBROUTINE PYPDPO(X,Q2,XPPR)
40716
40717C...Double precision and integer declarations.
40718 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40719 IMPLICIT INTEGER(I-N)
40720 INTEGER PYK,PYCHGE,PYCOMP
40721C...Commonblocks.
40722 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40723 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40724 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40725 COMMON/PYINT1/MINT(400),VINT(400)
40726 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40727 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
40728 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
40729
40730
40731C...The following data lines are coefficients needed in the
40732C...Eichten, Hinchliffe, Lane, Quigg proton structure function
40733C...parametrizations, see below.
40734C...Powers of 1-x in different cases.
40735 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
40736C...Expansion coefficients for up valence quark distribution.
40737 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
40738 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
40739 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
40740 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
40741 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
40742 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
40743 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
40744 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
40745 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
40746 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
40747 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
40748 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
40749 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
40750 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
40751 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
40752 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
40753 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
40754 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
40755 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
40756 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
40757 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
40758 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
40759 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
40760 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
40761 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
40762 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
40763C...Expansion coefficients for down valence quark distribution.
40764 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
40765 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
40766 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
40767 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
40768 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
40769 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
40770 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
40771 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
40772 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
40773 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
40774 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
40775 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
40776 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
40777 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
40778 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
40779 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
40780 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
40781 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
40782 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
40783 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
40784 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
40785 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
40786 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
40787 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
40788 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
40789 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
40790C...Expansion coefficients for up and down sea quark distributions.
40791 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
40792 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
40793 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
40794 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
40795 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
40796 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
40797 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
40798 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
40799 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
40800 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
40801 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
40802 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
40803 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
40804 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
40805 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
40806 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
40807 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
40808 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
40809 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
40810 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
40811 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
40812 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
40813 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
40814 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
40815 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
40816 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
40817C...Expansion coefficients for gluon distribution.
40818 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
40819 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
40820 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
40821 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
40822 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
40823 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
40824 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
40825 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
40826 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
40827 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
40828 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
40829 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
40830 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
40831 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
40832 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
40833 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
40834 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
40835 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
40836 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
40837 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
40838 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
40839 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
40840 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
40841 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
40842 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
40843 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
40844C...Expansion coefficients for strange sea quark distribution.
40845 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
40846 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
40847 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
40848 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
40849 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
40850 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
40851 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
40852 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
40853 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
40854 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
40855 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
40856 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
40857 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
40858 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
40859 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
40860 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
40861 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
40862 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
40863 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
40864 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
40865 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
40866 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
40867 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
40868 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
40869 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
40870 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
40871C...Expansion coefficients for charm sea quark distribution.
40872 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
40873 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
40874 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
40875 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
40876 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
40877 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
40878 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
40879 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
40880 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
40881 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
40882 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
40883 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
40884 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
40885 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
40886 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
40887 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
40888 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
40889 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
40890 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
40891 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
40892 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
40893 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
40894 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
40895 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
40896 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
40897 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
40898C...Expansion coefficients for bottom sea quark distribution.
40899 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
40900 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
40901 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
40902 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
40903 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
40904 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
40905 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
40906 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
40907 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
40908 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
40909 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
40910 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
40911 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
40912 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
40913 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
40914 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
40915 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
40916 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
40917 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
40918 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
40919 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
40920 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
40921 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
40922 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
40923 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
40924 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
40925C...Expansion coefficients for top sea quark distribution.
40926 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
40927 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
40928 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
40929 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
40930 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40931 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
40932 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40933 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
40934 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
40935 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
40936 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
40937 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
40938 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
40939 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
40940 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
40941 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
40942 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
40943 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
40944 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
40945 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
40946 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
40947 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
40948 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
40949 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
40950 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
40951 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
40952
40953C...The following data lines are coefficients needed in the
40954C...Duke, Owens proton structure function parametrizations, see below.
40955C...Expansion coefficients for (up+down) valence quark distribution.
40956 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
40957 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40958 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40959 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40960 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
40961 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40962 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40963 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
40964C...Expansion coefficients for down valence quark distribution.
40965 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
40966 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40967 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40968 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40969 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
40970 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40971 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
40972 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
40973C...Expansion coefficients for (up+down+strange) sea quark distribution.
40974 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
40975 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40976 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
40977 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
40978 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
40979 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40980 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
40981 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
40982C...Expansion coefficients for charm sea quark distribution.
40983 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
40984 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40985 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
40986 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
40987 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
40988 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
40989 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
40990 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
40991C...Expansion coefficients for gluon distribution.
40992 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
40993 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40994 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
40995 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
40996 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
40997 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
40998 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
40999 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41000
41001C...Euler's beta function, requires ordinary Gamma function
41002 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41003
41004C...Leading order proton parton distributions from Glueck, Reya and
41005C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41006C...10^-5 < x < 1.
41007 IF(MSTP(51).EQ.11) THEN
41008
41009C...Determine s expansion variable and some x expressions.
41010 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41011 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41012 SD2=SD**2
41013 XL=-LOG(X)
41014 XS=SQRT(X)
41015
41016C...Evaluate valence, gluon and sea distributions.
41017 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41018 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41019 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41020 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41021 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41022 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41023 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41024 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41025 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41026 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41027 & SQRT(4.066D0*SD**1.218D0*XL)))*
41028 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41029 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41030 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41031 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41032 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41033 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41034 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41035 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41036 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41037 IF(SD.LE.0.888D0) THEN
41038 XFCHM=0D0
41039 ELSE
41040 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41041 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41042 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41043 ENDIF
41044 IF(SD.LE.1.351D0) THEN
41045 XFBOT=0D0
41046 ELSE
41047 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41048 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41049 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41050 ENDIF
41051
41052C...Put into output array.
41053 XPPR(0)=XFGLU
41054 XPPR(1)=XFVDD+XFSEA
41055 XPPR(2)=XFVUD-XFVDD+XFSEA
41056 XPPR(3)=XFSTR
41057 XPPR(4)=XFCHM
41058 XPPR(5)=XFBOT
41059 XPPR(-1)=XFSEA
41060 XPPR(-2)=XFSEA
41061 XPPR(-3)=XFSTR
41062 XPPR(-4)=XFCHM
41063 XPPR(-5)=XFBOT
41064
41065C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41066C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41067 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41068
41069C...Determine set, Lambda and x and t expansion variables.
41070 NSET=MSTP(51)-11
41071 IF(NSET.EQ.1) ALAM=0.2D0
41072 IF(NSET.EQ.2) ALAM=0.29D0
41073 TMIN=LOG(5D0/ALAM**2)
41074 TMAX=LOG(1D8/ALAM**2)
41075 T=LOG(MAX(1D0,Q2/ALAM**2))
41076 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41077 NX=1
41078 IF(X.LE.0.1D0) NX=2
41079 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
41080 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
41081
41082C...Chebyshev polynomials for x and t expansion.
41083 TX(1)=1D0
41084 TX(2)=VX
41085 TX(3)=2D0*VX**2-1D0
41086 TX(4)=4D0*VX**3-3D0*VX
41087 TX(5)=8D0*VX**4-8D0*VX**2+1D0
41088 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
41089 TT(1)=1D0
41090 TT(2)=VT
41091 TT(3)=2D0*VT**2-1D0
41092 TT(4)=4D0*VT**3-3D0*VT
41093 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41094 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41095
41096C...Calculate structure functions.
41097 DO 120 KFL=1,6
41098 XQSUM=0D0
41099 DO 110 IT=1,6
41100 DO 100 IX=1,6
41101 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
41102 100 CONTINUE
41103 110 CONTINUE
41104 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
41105 120 CONTINUE
41106
41107C...Put into output array.
41108 XPPR(0)=XQ(4)
41109 XPPR(1)=XQ(2)+XQ(3)
41110 XPPR(2)=XQ(1)+XQ(3)
41111 XPPR(3)=XQ(5)
41112 XPPR(4)=XQ(6)
41113 XPPR(-1)=XQ(3)
41114 XPPR(-2)=XQ(3)
41115 XPPR(-3)=XQ(5)
41116 XPPR(-4)=XQ(6)
41117
41118C...Special expansion for bottom (threshold effects).
41119 IF(MSTP(58).GE.5) THEN
41120 IF(NSET.EQ.1) TMIN=8.1905D0
41121 IF(NSET.EQ.2) TMIN=7.4474D0
41122 IF(T.GT.TMIN) THEN
41123 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41124 TT(1)=1D0
41125 TT(2)=VT
41126 TT(3)=2D0*VT**2-1D0
41127 TT(4)=4D0*VT**3-3D0*VT
41128 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41129 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41130 XQSUM=0D0
41131 DO 140 IT=1,6
41132 DO 130 IX=1,6
41133 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
41134 130 CONTINUE
41135 140 CONTINUE
41136 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
41137 XPPR(-5)=XPPR(5)
41138 ENDIF
41139 ENDIF
41140
41141C...Special expansion for top (threshold effects).
41142 IF(MSTP(58).GE.6) THEN
41143 IF(NSET.EQ.1) TMIN=11.5528D0
41144 IF(NSET.EQ.2) TMIN=10.8097D0
41145 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
41146 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
41147 IF(T.GT.TMIN) THEN
41148 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
41149 TT(1)=1D0
41150 TT(2)=VT
41151 TT(3)=2D0*VT**2-1D0
41152 TT(4)=4D0*VT**3-3D0*VT
41153 TT(5)=8D0*VT**4-8D0*VT**2+1D0
41154 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
41155 XQSUM=0D0
41156 DO 160 IT=1,6
41157 DO 150 IX=1,6
41158 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
41159 150 CONTINUE
41160 160 CONTINUE
41161 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
41162 XPPR(-6)=XPPR(6)
41163 ENDIF
41164 ENDIF
41165
41166C...Proton parton distributions from Duke, Owens.
41167C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
41168 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
41169
41170C...Determine set, Lambda and s expansion parameter.
41171 NSET=MSTP(51)-13
41172 IF(NSET.EQ.1) ALAM=0.2D0
41173 IF(NSET.EQ.2) ALAM=0.4D0
41174 Q2IN=MIN(1D6,MAX(4D0,Q2))
41175 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
41176
41177C...Calculate structure functions.
41178 DO 180 KFL=1,5
41179 DO 170 IS=1,6
41180 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
41181 & CDO(3,IS,KFL,NSET)*SD**2
41182 170 CONTINUE
41183 IF(KFL.LE.2) THEN
41184 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
41185 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
41186 ELSE
41187 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
41188 & TS(5)*X**2+TS(6)*X**3)
41189 ENDIF
41190 180 CONTINUE
41191
41192C...Put into output arrays.
41193 XPPR(0)=XQ(5)
41194 XPPR(1)=XQ(2)+XQ(3)/6D0
41195 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
41196 XPPR(3)=XQ(3)/6D0
41197 XPPR(4)=XQ(4)
41198 XPPR(-1)=XQ(3)/6D0
41199 XPPR(-2)=XQ(3)/6D0
41200 XPPR(-3)=XQ(3)/6D0
41201 XPPR(-4)=XQ(4)
41202
41203 ENDIF
41204
41205 RETURN
41206 END
41207
41208C*********************************************************************
41209
41210C...PYHFTH
41211C...Gives threshold attractive/repulsive factor for heavy flavour
41212C...production.
41213
41214 FUNCTION PYHFTH(SH,SQM,FRATT)
41215
41216C...Double precision and integer declarations.
41217 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41218 IMPLICIT INTEGER(I-N)
41219 INTEGER PYK,PYCHGE,PYCOMP
41220C...Commonblocks.
41221 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41222 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41223 COMMON/PYINT1/MINT(400),VINT(400)
41224 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
41225
41226C...Value for alpha_strong.
41227 IF(MSTP(35).LE.1) THEN
41228 ALSSG=PARP(35)
41229 ELSE
41230 MST115=MSTU(115)
41231 MSTU(115)=MSTP(36)
41232 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
41233 & PARP(36)**2)))
41234 ALSSG=PYALPS(Q2BN)
41235 MSTU(115)=MST115
41236 ENDIF
41237
41238C...Evaluate attractive and repulsive factors.
41239 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41240 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
41241 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
41242 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
41243 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
41244 VINT(138)=PYHFTH
41245
41246 RETURN
41247 END
41248
41249C*********************************************************************
41250
41251C...PYSPLI
41252C...Splits a hadron remnant into two (partons or hadron + parton)
41253C...in case it is more complicated than just a quark or a diquark.
41254
41255 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
41256
41257C...Double precision and integer declarations.
41258 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41259 IMPLICIT INTEGER(I-N)
41260 INTEGER PYK,PYCHGE,PYCOMP
41261C...Commonblocks. PYDAT1 temporary
41262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41263 COMMON/PYINT1/MINT(400),VINT(400)
41264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41265 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
41266C...Local array.
41267 DIMENSION KFL(3)
41268
41269C...Preliminaries. Parton composition.
41270 KFA=IABS(KF)
41271 KFS=ISIGN(1,KF)
41272 KFL(1)=MOD(KFA/1000,10)
41273 KFL(2)=MOD(KFA/100,10)
41274 KFL(3)=MOD(KFA/10,10)
41275 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
41276 KFL(2)=INT(1.5D0+PYR(0))
41277 IF(MINT(105).EQ.333) KFL(2)=3
41278 IF(MINT(105).EQ.443) KFL(2)=4
41279 KFL(3)=KFL(2)
41280 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
41281 KFL(2)=2
41282 KFL(3)=2
41283 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
41284 KFL(2)=1
41285 KFL(3)=1
41286 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
41287 KFL(2)=MOD(KFA/10,10)
41288 KFL(3)=MOD(KFA/100,10)
41289 ENDIF
41290 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
41291 KFLR=KFLIN*KFS
41292 ELSE
41293 KFLR=KFLIN
41294 ENDIF
41295 KFLCH=0
41296
41297C...Subdivide lepton.
41298 IF(KFA.GE.11.AND.KFA.LE.18) THEN
41299 IF(KFLR.EQ.KFA) THEN
41300 KFLSP=KFS*22
41301 ELSEIF(KFLR.EQ.22) THEN
41302 KFLSP=KFA
41303 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
41304 KFLSP=KFA+1
41305 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
41306 KFLSP=KFA-1
41307 ELSEIF(KFLR.EQ.21) THEN
41308 KFLSP=KFA
41309 KFLCH=KFS*21
41310 ELSE
41311 KFLSP=KFA
41312 KFLCH=-KFLR
41313 ENDIF
41314
41315C...Subdivide photon.
41316 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
41317 IF(KFLR.NE.21) THEN
41318 KFLSP=-KFLR
41319 ELSE
41320 RAGR=0.75D0*PYR(0)
41321 KFLSP=1
41322 IF(RAGR.GT.0.125D0) KFLSP=2
41323 IF(RAGR.GT.0.625D0) KFLSP=3
41324 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
41325 KFLCH=-KFLSP
41326 ENDIF
41327
41328C...Subdivide Reggeon or Pomeron.
41329 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
41330 IF(KFLIN.EQ.21) THEN
41331 KFLSP=KFS*21
41332 ELSE
41333 KFLSP=-KFLIN
41334 ENDIF
41335
41336C...Subdivide meson.
41337 ELSEIF(KFL(1).EQ.0) THEN
41338 KFL(2)=KFL(2)*(-1)**KFL(2)
41339 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
41340 IF(KFLR.EQ.KFL(2)) THEN
41341 KFLSP=KFL(3)
41342 ELSEIF(KFLR.EQ.KFL(3)) THEN
41343 KFLSP=KFL(2)
41344 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
41345 KFLSP=KFL(2)
41346 KFLCH=KFL(3)
41347 ELSEIF(KFLR.EQ.21) THEN
41348 KFLSP=KFL(3)
41349 KFLCH=KFL(2)
41350 ELSEIF(KFLR*KFL(2).GT.0) THEN
41351 NTRY=0
41352 100 NTRY=NTRY+1
41353 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
41354 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41355 GOTO 100
41356 ELSEIF(KFLCH.EQ.0) THEN
41357 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41358 MINT(51)=1
41359 RETURN
41360 ENDIF
41361 KFLSP=KFL(3)
41362 ELSE
41363 NTRY=0
41364 110 NTRY=NTRY+1
41365 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
41366 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41367 GOTO 110
41368 ELSEIF(KFLCH.EQ.0) THEN
41369 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41370 MINT(51)=1
41371 RETURN
41372 ENDIF
41373 KFLSP=KFL(2)
41374 ENDIF
41375
41376C...Special case for extracting photon from baryon without splitting
41377C...the latter. (Currently only used by external programs.)
41378 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
41379 KFLSP=KFA
41380 KFLCH=0
41381
41382C...Subdivide baryon.
41383 ELSE
41384 NAGR=0
41385 DO 120 J=1,3
41386 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
41387 120 CONTINUE
41388 IF(NAGR.GE.1) THEN
41389 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
41390 IAGR=0
41391 DO 130 J=1,3
41392 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
41393 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
41394 130 CONTINUE
41395 ELSE
41396 IAGR=1.00001D0+2.99998D0*PYR(0)
41397 ENDIF
41398 ID1=1
41399 IF(IAGR.EQ.1) ID1=2
41400 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
41401 ID2=6-IAGR-ID1
41402 KSP=3
41403 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
41404 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
41405 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
41406 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
41407 ELSEIF(MOD(KFA,10).EQ.2) THEN
41408 IF(IAGR.EQ.1) KSP=1
41409 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
41410 ENDIF
41411 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
41412 IF(KFLR.EQ.21) THEN
41413 KFLCH=KFL(IAGR)
41414 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
41415 NTRY=0
41416 140 NTRY=NTRY+1
41417 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
41418 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41419 GOTO 140
41420 ELSEIF(KFLCH.EQ.0) THEN
41421 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41422 MINT(51)=1
41423 RETURN
41424 ENDIF
41425 ELSEIF(NAGR.EQ.0) THEN
41426 NTRY=0
41427 150 NTRY=NTRY+1
41428 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
41429 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
41430 GOTO 150
41431 ELSEIF(KFLCH.EQ.0) THEN
41432 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
41433 MINT(51)=1
41434 RETURN
41435 ENDIF
41436 KFLSP=KFL(IAGR)
41437 ENDIF
41438 ENDIF
41439
41440C...Add on correct sign for result.
41441 KFLCH=KFLCH*KFS
41442 KFLSP=KFLSP*KFS
41443
41444 RETURN
41445 END
41446
41447C*********************************************************************
41448
41449C...PYGAMM
41450C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
41451C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
41452C...(Dover, 1965) 6.1.36.
41453
41454 FUNCTION PYGAMM(X)
41455
41456C...Double precision and integer declarations.
41457 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41458 IMPLICIT INTEGER(I-N)
41459 INTEGER PYK,PYCHGE,PYCOMP
41460C...Local array and data.
41461 DIMENSION B(8)
41462 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
41463 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
41464
41465 NX=INT(X)
41466 DX=X-NX
41467
41468 PYGAMM=1D0
41469 DXP=1D0
41470 DO 100 I=1,8
41471 DXP=DXP*DX
41472 PYGAMM=PYGAMM+B(I)*DXP
41473 100 CONTINUE
41474 IF(X.LT.1D0) THEN
41475 PYGAMM=PYGAMM/X
41476 ELSE
41477 DO 110 IX=1,NX-1
41478 PYGAMM=(X-IX)*PYGAMM
41479 110 CONTINUE
41480 ENDIF
41481
41482 RETURN
41483 END
41484
41485C***********************************************************************
41486
41487C...PYWAUX
41488C...Calculates real and imaginary parts of the auxiliary functions W1
41489C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
41490C...der Bij, Nucl. Phys. B297 (1988) 221.
41491
41492 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
41493
41494C...Double precision and integer declarations.
41495 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41496 IMPLICIT INTEGER(I-N)
41497 INTEGER PYK,PYCHGE,PYCOMP
41498C...Commonblocks.
41499 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41500 SAVE /PYDAT1/
41501
41502 ASINH(X)=LOG(X+SQRT(X**2+1D0))
41503 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
41504
41505 IF(EPS.LT.0D0) THEN
41506 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
41507 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
41508 WIM=0D0
41509 ELSEIF(EPS.LT.1D0) THEN
41510 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
41511 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
41512 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
41513 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
41514 ELSE
41515 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
41516 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
41517 WIM=0D0
41518 ENDIF
41519
41520 RETURN
41521 END
41522
41523C***********************************************************************
41524
41525C...PYI3AU
41526C...Calculates real and imaginary parts of the auxiliary function I3;
41527C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
41528C...Nucl. Phys. B297 (1988) 221.
41529
41530 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
41531
41532C...Double precision and integer declarations.
41533 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41534 IMPLICIT INTEGER(I-N)
41535 INTEGER PYK,PYCHGE,PYCOMP
41536C...Commonblocks.
41537 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41538 SAVE /PYDAT1/
41539
41540 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
41541 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
41542
41543 IF(EPS.LT.0D0) THEN
41544 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41545 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41546 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41547 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
41548 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
41549 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
41550 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
41551 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
41552 & EPS))
41553 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41554 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41555 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41556 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
41557 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
41558 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
41559 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
41560 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
41561 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41562 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41563 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41564 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
41565 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
41566 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
41567 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
41568 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
41569 ELSE
41570 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41571 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
41572 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
41573 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
41574 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
41575 ENDIF
41576 F3IM=0D0
41577 ELSEIF(EPS.LT.1D0) THEN
41578 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41579 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
41580 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
41581 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
41582 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
41583 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41584 & (0.25D0*(RAT+1D0)*EPS))
41585 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
41586 & (0.25D0*(RAT+1D0)*EPS))
41587 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
41588 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
41589 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
41590 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
41591 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
41592 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
41593 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41594 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
41595 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
41596 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
41597 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
41598 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
41599 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
41600 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
41601 & (1D0+0.25D0*RAT*EPS-GA))
41602 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
41603 & (1D0+0.25D0*RAT*EPS-GA))
41604 ELSE
41605 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
41606 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
41607 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
41608 & LOG((GA+BE-1D0)/(BE-GA))
41609 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
41610 ENDIF
41611 ELSE
41612 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
41613 RCTHE=RSQ*(1D0-2D0*BE/EPS)
41614 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
41615 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
41616 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
41617 R=SQRT(RSQ)
41618 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
41619 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
41620 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
41621 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
41622 & (PHI-THE)*(PHI+THE-PARU(1))
41623 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
41624 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
41625 ENDIF
41626
41627 Y3RE=2D0/(2D0*BE-1D0)*F3RE
41628 Y3IM=2D0/(2D0*BE-1D0)*F3IM
41629
41630 RETURN
41631 END
41632
41633C***********************************************************************
41634
41635C...PYSPEN
41636C...Calculates real and imaginary part of Spence function; see
41637C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
41638
41639 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
41640
41641C...Double precision and integer declarations.
41642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41643 IMPLICIT INTEGER(I-N)
41644 INTEGER PYK,PYCHGE,PYCOMP
41645C...Commonblocks.
41646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41647 SAVE /PYDAT1/
41648C...Local array and data.
41649 DIMENSION B(0:14)
41650 DATA B/
41651 &1.000000D+00, -5.000000D-01, 1.666667D-01,
41652 &0.000000D+00, -3.333333D-02, 0.000000D+00,
41653 &2.380952D-02, 0.000000D+00, -3.333333D-02,
41654 &0.000000D+00, 7.575757D-02, 0.000000D+00,
41655 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
41656
41657 XRE=XREIN
41658 XIM=XIMIN
41659 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
41660 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
41661 IF(IREIM.EQ.2) PYSPEN=0D0
41662 RETURN
41663 ENDIF
41664
41665 XMOD=SQRT(XRE**2+XIM**2)
41666 IF(XMOD.LT.1D-6) THEN
41667 IF(IREIM.EQ.1) PYSPEN=0D0
41668 IF(IREIM.EQ.2) PYSPEN=0D0
41669 RETURN
41670 ENDIF
41671
41672 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41673 SP0RE=0D0
41674 SP0IM=0D0
41675 SGN=1D0
41676 IF(XMOD.GT.1D0) THEN
41677 ALGXRE=LOG(XMOD)
41678 ALGXIM=XARG-SIGN(PARU(1),XARG)
41679 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
41680 SP0IM=-ALGXRE*ALGXIM
41681 SGN=-1D0
41682 XMOD=1D0/XMOD
41683 XARG=-XARG
41684 XRE=XMOD*COS(XARG)
41685 XIM=XMOD*SIN(XARG)
41686 ENDIF
41687 IF(XRE.GT.0.5D0) THEN
41688 ALGXRE=LOG(XMOD)
41689 ALGXIM=XARG
41690 XRE=1D0-XRE
41691 XIM=-XIM
41692 XMOD=SQRT(XRE**2+XIM**2)
41693 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41694 ALGYRE=LOG(XMOD)
41695 ALGYIM=XARG
41696 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
41697 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
41698 SGN=-SGN
41699 ENDIF
41700
41701 XRE=1D0-XRE
41702 XIM=-XIM
41703 XMOD=SQRT(XRE**2+XIM**2)
41704 XARG=SIGN(ACOS(XRE/XMOD),XIM)
41705 ZRE=-LOG(XMOD)
41706 ZIM=-XARG
41707
41708 SPRE=0D0
41709 SPIM=0D0
41710 SAVERE=1D0
41711 SAVEIM=0D0
41712 DO 100 I=0,14
41713 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
41714 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
41715 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
41716 SAVERE=TERMRE
41717 SAVEIM=TERMIM
41718 SPRE=SPRE+B(I)*TERMRE
41719 SPIM=SPIM+B(I)*TERMIM
41720 100 CONTINUE
41721
41722 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
41723 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
41724
41725 RETURN
41726 END
41727
41728C***********************************************************************
41729
41730C...PYQQBH
41731C...Calculates the matrix element for the processes
41732C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
41733C...REDUCE output and part of the rest courtesy Z. Kunszt, see
41734C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
41735
41736 SUBROUTINE PYQQBH(WTQQBH)
41737
41738C...Double precision and integer declarations.
41739 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41740 IMPLICIT INTEGER(I-N)
41741 INTEGER PYK,PYCHGE,PYCOMP
41742C...Commonblocks.
41743 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41744 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41746 COMMON/PYINT1/MINT(400),VINT(400)
41747 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
41748 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
41749C...Local arrays and function.
41750 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
41751 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
41752 &PP(I,3)*PP(J,3)
41753
41754C...Mass parameters.
41755 WTQQBH=0D0
41756 ISUB=MINT(1)
41757 SHPR=SQRT(VINT(26))*VINT(1)
41758 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
41759 PH=SQRT(VINT(21))*VINT(1)
41760 SPQ=PQ**2
41761 SPH=PH**2
41762
41763C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
41764 DO 100 I=1,2
41765 PT=SQRT(MAX(0D0,VINT(197+5*I)))
41766 PP(I,1)=PT*COS(VINT(198+5*I))
41767 PP(I,2)=PT*SIN(VINT(198+5*I))
41768 100 CONTINUE
41769 PP(3,1)=-PP(1,1)-PP(2,1)
41770 PP(3,2)=-PP(1,2)-PP(2,2)
41771 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
41772 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
41773 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
41774 PMT3=SQRT(PMS3)
41775 PP(3,3)=PMT3*SINH(VINT(211))
41776 PP(3,4)=PMT3*COSH(VINT(211))
41777 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
41778 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
41779 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
41780 PP(2,3)=-PP(1,3)-PP(3,3)
41781 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
41782 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
41783
41784C...Set up incoming kinematics and derived momentum combinations.
41785 DO 110 I=4,5
41786 PP(I,1)=0D0
41787 PP(I,2)=0D0
41788 PP(I,3)=-0.5D0*SHPR*(-1)**I
41789 PP(I,4)=-0.5D0*SHPR
41790 110 CONTINUE
41791 DO 120 J=1,4
41792 PP(6,J)=PP(1,J)+PP(2,J)
41793 PP(7,J)=PP(1,J)+PP(3,J)
41794 PP(8,J)=PP(1,J)+PP(4,J)
41795 PP(9,J)=PP(1,J)+PP(5,J)
41796 PP(10,J)=-PP(2,J)-PP(3,J)
41797 PP(11,J)=-PP(2,J)-PP(4,J)
41798 PP(12,J)=-PP(2,J)-PP(5,J)
41799 PP(13,J)=-PP(4,J)-PP(5,J)
41800 120 CONTINUE
41801
41802C...Derived kinematics invariants.
41803 X1=DOT(1,2)
41804 X2=DOT(1,3)
41805 X3=DOT(1,4)
41806 X4=DOT(1,5)
41807 X5=DOT(2,3)
41808 X6=DOT(2,4)
41809 X7=DOT(2,5)
41810 X8=DOT(3,4)
41811 X9=DOT(3,5)
41812 X10=DOT(4,5)
41813
41814C...Propagators.
41815 SS1=DOT(7,7)-SPQ
41816 SS2=DOT(8,8)-SPQ
41817 SS3=DOT(9,9)-SPQ
41818 SS4=DOT(10,10)-SPQ
41819 SS5=DOT(11,11)-SPQ
41820 SS6=DOT(12,12)-SPQ
41821 SS7=DOT(13,13)
41822 DX(1)=SS1*SS6
41823 DX(2)=SS2*SS6
41824 DX(3)=SS2*SS4
41825 DX(4)=SS1*SS5
41826 DX(5)=SS3*SS5
41827 DX(6)=SS3*SS4
41828 DX(7)=SS7*SS1
41829 DX(8)=SS7*SS4
41830
41831C...Define colour coefficients for g + g -> Q + Qbar + H.
41832 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
41833 DO 140 I=1,3
41834 DO 130 J=1,3
41835 CLR(I,J)=16D0/3D0
41836 CLR(I+3,J+3)=16D0/3D0
41837 CLR(I,J+3)=-2D0/3D0
41838 CLR(I+3,J)=-2D0/3D0
41839 130 CONTINUE
41840 140 CONTINUE
41841 DO 160 L=1,2
41842 DO 150 I=1,3
41843 CLR(I,6+L)=-6D0
41844 CLR(I+3,6+L)=6D0
41845 CLR(6+L,I)=-6D0
41846 CLR(6+L,I+3)=6D0
41847 150 CONTINUE
41848 160 CONTINUE
41849 DO 180 K1=1,2
41850 DO 170 K2=1,2
41851 CLR(6+K1,6+K2)=12D0
41852 170 CONTINUE
41853 180 CONTINUE
41854
41855C...Evaluate matrix elements for g + g -> Q + Qbar + H.
41856 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
41857 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
41858 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
41859 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
41860 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
41861 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
41862 & X10)
41863 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
41864 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
41865 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41866 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
41867 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
41868 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
41869 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
41870 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
41871 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
41872 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
41873 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
41874 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
41875 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41876 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
41877 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
41878 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
41879 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
41880 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
41881 & X4*X6*X5)
41882 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
41883 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
41884 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
41885 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
41886 & +X4*X9*X5+X4*X5**2)
41887 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
41888 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
41889 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
41890 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
41891 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
41892 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
41893 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
41894 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
41895 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
41896 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
41897 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
41898 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
41899 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
41900 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
41901 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
41902 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
41903 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
41904 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
41905 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
41906 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
41907 & X6)
41908 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
41909 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
41910 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
41911 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
41912 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
41913 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
41914 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
41915 & X5+X4*X6*X5)
41916 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
41917 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
41918 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
41919 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
41920 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
41921 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
41922 & X6**2)
41923 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
41924 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
41925 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
41926 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
41927 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
41928 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
41929 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
41930 & X4*X6*X5)
41931 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41932 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41933 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
41934 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
41935 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
41936 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41937 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
41938 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
41939 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
41940 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
41941 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
41942 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
41943 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
41944 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
41945 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
41946 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
41947 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
41948 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
41949 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
41950 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
41951 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
41952 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
41953 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
41954 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
41955 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
41956 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
41957 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
41958 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
41959 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
41960 & +X3*X8*X5+X3*X5**2)
41961 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
41962 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
41963 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
41964 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
41965 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
41966 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
41967 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
41968 & X5+X4*X6*X5)
41969 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
41970 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
41971 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
41972 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
41973 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
41974 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
41975 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
41976 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
41977 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
41978 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
41979 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
41980 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
41981 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
41982 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
41983 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
41984 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
41985 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
41986 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
41987 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
41988 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
41989 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
41990 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
41991 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
41992 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
41993 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
41994 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
41995 & X10)
41996 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
41997 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
41998 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
41999 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42000 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42001 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42002 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42003 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42004 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42005 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42006 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42007 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42008 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42009 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42010 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42011 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42012 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42013 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42014 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42015 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42016 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42017 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42018 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42019 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42020 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42021 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42022 & X7)
42023 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42024 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42025 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42026 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42027 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42028 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42029 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42030 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42031 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42032 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42033 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42034 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42035 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42036 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42037 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42038 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42039 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42040 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42041 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42042 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42043 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42044 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42045 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42046 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42047 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42048 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42049 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42050 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42051 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42052 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42053 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42054 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42055 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42056 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42057 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42058 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42059 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42060 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42061 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42062 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42063 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42064 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42065 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42066 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42067 & *X6)
42068 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42069 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42070 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42071 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42072 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42073 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42074 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
42075 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
42076 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
42077 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
42078 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
42079 & X8)
42080 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42081 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
42082 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
42083 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42084 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
42085 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
42086 & X9*X5)
42087 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
42088 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
42089 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
42090 & X8*X5)
42091 FM(9,10)=0.5D0*(FMXX+FM(9,10))
42092 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
42093 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
42094 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
42095
42096C...Repackage matrix elements.
42097 DO 200 I=1,8
42098 DO 190 J=I,8
42099 RM(I,J)=FM(I,J)
42100 190 CONTINUE
42101 200 CONTINUE
42102 RM(7,7)=FM(7,7)-2D0*FM(9,9)
42103 RM(7,8)=FM(7,8)-2D0*FM(9,10)
42104 RM(8,8)=FM(8,8)-2D0*FM(10,10)
42105
42106C...Produce final result: matrix elements * colours * propagators.
42107 DO 220 I=1,8
42108 DO 210 J=I,8
42109 FAC=8D0
42110 IF(I.EQ.J)FAC=4D0
42111 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
42112 210 CONTINUE
42113 220 CONTINUE
42114 WTQQBH=-WTQQBH/256D0
42115
42116 ELSE
42117C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
42118 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
42119 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
42120 & *X6+X8*X7)
42121 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
42122 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
42123 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
42124 & X5)
42125 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
42126 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
42127 & *X9+X4*X8)
42128
42129C...Produce final result: matrix elements * propagators.
42130 A11=A11/DX(7)**2
42131 A12=A12/(DX(7)*DX(8))
42132 A22=A22/DX(8)**2
42133 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
42134 ENDIF
42135
42136 RETURN
42137 END
42138
42139C*********************************************************************
42140
42141C...PYSTBH (and auxiliaries)
42142C.. Evaluates the matrix elements for t + b + H production.
42143
42144 SUBROUTINE PYSTBH(WTTBH)
42145
42146C...DOUBLE PRECISION AND INTEGER DECLARATIONS
42147 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42148 IMPLICIT INTEGER(I-N)
42149 INTEGER PYK,PYCHGE,PYCOMP
42150
42151C...COMMONBLOCKS
42152 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42153 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42154 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42155 COMMON/PYINT1/MINT(400),VINT(400)
42156 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42157 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
42158 COMMON/PYINT4/MWID(500),WIDS(500,5)
42159 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
42160 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42161 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
42162 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
42163 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
42164 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
42165 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42166 DOUBLE PRECISION MW2
42167 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
42168 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
42169
42170C...LOCAL ARRAYS AND COMPLEX VARIABLES
42171 DIMENSION QQ(4,2),PP(4,3)
42172 DATA QQ/8*0D0/
42173
42174 WTTBH=0D0
42175
42176C...KINEMATIC PARAMETERS.
42177 SHPR=SQRT(VINT(26))*VINT(1)
42178 PH=SQRT(VINT(21))*VINT(1)
42179 SPH=PH**2
42180
42181C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
42182 DO 100 I=1,2
42183 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42184 PP(1,I)=PT*COS(VINT(198+5*I))
42185 PP(2,I)=PT*SIN(VINT(198+5*I))
42186 100 CONTINUE
42187 PP(1,3)=-PP(1,1)-PP(1,2)
42188 PP(2,3)=-PP(2,1)-PP(2,2)
42189 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
42190 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
42191 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
42192 PMT3=SQRT(PMS3)
42193 PP(3,3)=PMT3*SINH(VINT(211))
42194 PP(4,3)=PMT3*COSH(VINT(211))
42195 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
42196 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42197 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
42198 PP(3,2)=-PP(3,1)-PP(3,3)
42199 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
42200 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
42201
42202C...CM SYSTEM, INGOING QUARKS/GLUONS
42203 QQ(3,1) = SHPR/2.D0
42204 QQ(4,1) = QQ(3,1)
42205 QQ(3,2) = -QQ(3,1)
42206 QQ(4,2) = QQ(4,1)
42207
42208C...PARAMETERS FOR AMPLITUDE METHOD
42209 ALPHA = AEM
42210 ALPHAS = AS
42211 SW2 = PARU(102)
42212 MW2 = PMAS(24,1)**2
42213 TANB = PARU(141)
42214 VTB = VCKM(3,3)
42215 RMB=PYMRUN(5,VINT(52))
42216
42217 ISUB=MINT(1)
42218
42219 IF (ISUB.EQ.401) THEN
42220 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42221 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42222 ELSE IF (ISUB.EQ.402) THEN
42223 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
42224 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
42225 END IF
42226
42227 RETURN
42228 END
42229C------------------------------------------------------------------
42230 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
42231C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
42232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42233 IMPLICIT INTEGER(I-N)
42234 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
42235 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42236 SAVE /PYCTBH/
42237
42238C TOP WIDTH CALCULATION
42239C VTB = 0.99
42240 MW=DSQRT(MW2)
42241 XB=(MB/MT)**2
42242 XW=(MW/MT)**2
42243 XH =(MHP/MT)**2
42244 GAMTBH = 0D0
42245 IF (MT .LT. (MHP+MB)) THEN
42246C T ->B W ONLY
42247 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42248 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42249 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42250 GAMT = GAMTBW
42251 ELSE
42252C T ->BW +T ->B H^+
42253 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
42254 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
42255 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
42256C
42257 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
42258 & -4.D0*(MHP*MB/MT**2)**2 )
42259 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
42260 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
42261 GAMT = GAMTBW+GAMTBH
42262 ENDIF
42263C THUS BR IS
42264 BR=GAMTBH/GAMT
42265 RETURN
42266 END
42267
42268C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
42269C GG->TBH^+, QQBAR->TBH^+
42270C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
42271C (FOR INSTANCE WITH PYTHIA)
42272C------------------------------------------------------------
42273C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
42274C PHYS REV. D 60 (1999) 115011
42275C (THESE FILES PREPARED BY J.-L. KNEUR)
42276C------------------------------------------------------------
42277C 1) GG->TBH^+
42278 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
42279C
42280C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
42281C
42282C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
42283C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
42284C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
42285C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
42286C "PHYSICAL PARAMETERS" INPUT:
42287C MT,MB TOP AND BOTTOM MASSES;
42288C MHP CHARGED HIGGS MASS
42289C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
42290C
42291C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
42292C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
42293C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
42294C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
42295C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
42296C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
42297C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
42298C
42299 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42300 IMPLICIT INTEGER(I-N)
42301 DOUBLE PRECISION MW2,MT,MB,MHP,MW
42302 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
42303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42305 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
42306
42307 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
42308 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
42309C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
42310C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
42311C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
42312C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
42313C (TAN BETA) VALUES
42314C
42315C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
42316C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
42317
42318 PI = 4*DATAN(1.D0)
42319 MW = DSQRT(MW2)
42320C
42321C COLLECTING THE RELEVANT OVERALL FACTORS:
42322C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
42323 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
42324C COUPLING CONSTANT (OVERALL NORMALIZATION)
42325 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
42326C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
42327C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
42328C ALPHAS IS ALPHA_STRONG;
42329C SW2 IS SIN(THETA_W)**2.
42330C
42331C VTB=.998D0
42332C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
42333C
42334 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
42335 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
42336C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
42337C
42338C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
42339C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
42340 DO 100 KK=1,4
42341 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
42342 100 CONTINUE
42343C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
42344 S = 2*PYTBHS(Q1,Q2)
42345 P1Q1=PYTBHS(Q1,P1)
42346 P1Q2=PYTBHS(P1,Q2)
42347 P2Q1=PYTBHS(P2,Q1)
42348 P2Q2=PYTBHS(P2,Q2)
42349 P1P2=PYTBHS(P1,P2)
42350C
42351C TOP WIDTH CALCULATION
42352 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
42353C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
42354C THEN DEFINE TOP (RESONANT) PROPAGATOR:
42355 A1INV= S -2*P1Q1 -2*P1Q2
42356 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
42357C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
42358C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
42359C THE TOP WIDTH
42360 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
42361 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
42362C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
42363C NOW COMES THE AMP**2:
42364C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
42365C THE EXPRESSIONS BELOW
42366 V18=0.D0
42367 A18=0.D0
42368 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
42369 &512*A1*A2*MB*MT/3-
42370 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42371 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
42372 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
42373 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42374 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
42375 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
42376 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
42377 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
42378 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42379 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42380 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
42381 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
42382 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42383 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42384 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
42385 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
42386 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
42387 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
42388 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42389 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
42390 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
42391 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42392 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42393 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42394 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
42395 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42396 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42397 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42398 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42399 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42400 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
42401 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42402 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
42403 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
42404 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
42405 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
42406 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
42407 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
42408 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
42409 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
42410 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
42411 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
42412 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
42413 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
42414 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
42415 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
42416 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
42417 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
42418 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
42419 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
42420 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
42421 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
42422 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42423 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
42424 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
42425 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
42426 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
42427 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
42428 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
42429 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
42430 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
42431 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42432 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
42433 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
42434 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
42435 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
42436 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
42437 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
42438 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
42439 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
42440 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
42441 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
42442 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42443 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
42444 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
42445 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
42446 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
42447 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
42448 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
42449 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42450 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
42451 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
42452 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
42453 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
42454 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
42455 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
42456 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
42457 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
42458 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
42459 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42460 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42461 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
42462 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
42463 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
42464 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
42465 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
42466 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
42467 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
42468 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
42469 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
42470 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
42471 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
42472 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
42473 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
42474 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
42475 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
42476 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
42477 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
42478 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
42479 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
42480 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
42481 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
42482 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
42483 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
42484 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
42485 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
42486 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
42487 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
42488 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
42489 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
42490 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
42491 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
42492 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
42493 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
42494 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
42495 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
42496 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
42497 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
42498 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
42499 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
42500 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
42501 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
42502 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
42503 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
42504 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
42505 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
42506 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
42507 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
42508 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
42509 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
42510 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
42511 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
42512 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
42513 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
42514 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42515 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
42516 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
42517 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42518 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
42519 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
42520 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
42521 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
42522 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42523 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42524 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
42525 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
42526 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
42527 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
42528 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42529 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
42530 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
42531 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
42532 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
42533 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
42534 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42535 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
42536 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
42537 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
42538 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
42539 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
42540 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
42541 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
42542 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
42543 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
42544 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42545 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
42546 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
42547 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42548 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
42549 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
42550 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
42551 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
42552 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
42553 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
42554 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42555 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42556 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
42557 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
42558 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
42559 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
42560 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
42561 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
42562 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
42563 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
42564 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
42565 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
42566 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
42567 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
42568 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
42569 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
42570 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
42571 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
42572 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42573 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
42574 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
42575 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
42576 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
42577 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
42578 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
42579 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42580 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42581 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
42582 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
42583 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
42584 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
42585 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
42586 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
42587 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
42588 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
42589 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
42590 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
42591 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
42592 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
42593 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
42594 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
42595 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
42596 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
42597 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
42598 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
42599 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
42600 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
42601 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
42602 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
42603 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
42604 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
42605 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
42606 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
42607 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
42608 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
42609 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
42610 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
42611 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
42612 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
42613 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42614 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42615 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
42616 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
42617 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
42618 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
42619 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
42620 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
42621 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
42622 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
42623 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
42624 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
42625 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
42626 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
42627 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42628 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42629 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
42630 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
42631 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
42632 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
42633 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
42634 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
42635 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
42636 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
42637 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
42638 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
42639 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
42640 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
42641 &384*A12*MB*MT*P1Q1**2/S**2+
42642 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
42643 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
42644 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
42645 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
42646 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
42647 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
42648 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
42649 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
42650 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
42651 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
42652 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
42653 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
42654 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
42655 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
42656 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
42657 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
42658 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
42659 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
42660 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
42661 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
42662 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
42663 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
42664 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
42665 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
42666 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
42667 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
42668 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
42669 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
42670 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
42671 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
42672 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
42673 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
42674 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
42675 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
42676 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
42677 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
42678 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
42679 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
42680 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
42681 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
42682 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
42683 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
42684 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
42685 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
42686 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
42687 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
42688 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
42689 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
42690 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
42691 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
42692 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
42693 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
42694 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
42695 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
42696 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42697 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
42698 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
42699 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42700 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
42701 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
42702 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
42703 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
42704 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
42705 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
42706 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
42707 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
42708 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
42709 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
42710 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
42711 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
42712 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
42713 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
42714 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
42715 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
42716 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
42717 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
42718 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42719 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
42720 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
42721 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
42722 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
42723 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
42724 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
42725 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
42726 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
42727 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
42728 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
42729 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
42730 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
42731 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
42732 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
42733 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
42734 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
42735 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
42736 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
42737 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
42738 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
42739 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
42740 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42741 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
42742 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
42743 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
42744 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
42745 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
42746 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
42747 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
42748 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
42749 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
42750 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
42751 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
42752 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42753 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
42754 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
42755 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42756 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
42757 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
42758 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
42759 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42760 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
42761 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
42762 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
42763 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42764 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42765 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42766 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42767 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
42768 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
42769 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
42770 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
42771 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
42772 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
42773 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
42774 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
42775 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42776 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
42777 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
42778 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
42779 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
42780 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
42781 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
42782 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
42783 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
42784 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
42785 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
42786 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
42787 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
42788 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
42789 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
42790 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
42791 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
42792 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
42793 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
42794 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
42795 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
42796 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
42797 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
42798 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
42799 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
42800 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42801 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
42802 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
42803 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
42804 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
42805 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
42806 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
42807 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
42808 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42809 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
42810 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
42811 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
42812 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
42813 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42814 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
42815 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
42816 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
42817 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
42818
42819 V18BIS=
42820 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42821 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42822 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42823 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
42824 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
42825 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42826 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
42827 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
42828 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
42829 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
42830 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
42831 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
42832 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
42833 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
42834 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
42835 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
42836 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
42837 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
42838 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
42839 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42840 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
42841 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
42842 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
42843 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
42844 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
42845 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
42846 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
42847 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
42848 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
42849 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
42850 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
42851 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
42852 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
42853 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
42854 &272*A1*A2*P1Q1*S/(3*P1Q2)+
42855 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
42856 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
42857 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
42858 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
42859 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
42860 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
42861 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
42862 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
42863 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
42864 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
42865 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
42866 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
42867 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
42868 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
42869 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
42870 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
42871 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
42872 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
42873 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
42874 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
42875 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
42876 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
42877 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
42878 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
42879 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
42880 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
42881 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
42882 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
42883 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
42884 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
42885 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
42886 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
42887 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
42888 &32*A12*P2Q1*S/(3*P1Q1)-
42889 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
42890 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
42891 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
42892 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
42893 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
42894 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
42895 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
42896 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
42897 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
42898 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
42899 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
42900 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
42901 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
42902 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
42903 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
42904 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
42905 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
42906 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
42907 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
42908 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
42909 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
42910 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
42911 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
42912 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
42913 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
42914 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
42915 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
42916 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
42917 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42918 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
42919 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
42920 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
42921 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
42922 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
42923 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
42924 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
42925 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
42926 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
42927 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42928 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
42929 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
42930 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42931 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42932 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42933 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42934 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42935 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
42936 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
42937 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
42938 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
42939 &272*A1*A2*P2Q1*S/(3*P2Q2)-
42940 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
42941 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
42942 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
42943 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
42944 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
42945 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
42946 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
42947 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
42948 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
42949 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
42950 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
42951 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
42952 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
42953 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
42954 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
42955 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
42956 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
42957 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
42958 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
42959 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
42960 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
42961 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
42962 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
42963C
42964
42965 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
42966 &512*A1*A2*MB*MT/3+
42967 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
42968 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
42969 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
42970 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
42971 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
42972 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
42973 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
42974 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
42975 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
42976 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
42977 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
42978 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
42979 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
42980 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
42981 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
42982 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
42983 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
42984 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
42985 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
42986 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
42987 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
42988 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
42989 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
42990 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
42991 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
42992 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
42993 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
42994 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
42995 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
42996 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
42997 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
42998 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
42999 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43000 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43001 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43002 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43003 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43004 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43005 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43006 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43007 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43008 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43009 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43010 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43011 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43012 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43013 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43014 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43015 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43016 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43017 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43018 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43019 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43020 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43021 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43022 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43023 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43024 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43025 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43026 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43027 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43028 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43029 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43030 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43031 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43032 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43033 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43034 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43035 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43036 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43037 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43038 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43039 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43040 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43041 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43042 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43043 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43044 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43045 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43046 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43047 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43048 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43049 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43050 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43051 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43052 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43053 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43054 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43055 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43056 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43057 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43058 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43059 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43060 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43061 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43062 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43063 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43064 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43065 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43066 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43067 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43068 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43069 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43070 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43071 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43072 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43073 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43074 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43075 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
43076 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
43077 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43078 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43079 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43080 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43081 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
43082 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43083 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43084 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43085 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43086 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43087 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
43088 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43089 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43090 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43091 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43092 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43093 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
43094 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
43095 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43096 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43097 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43098 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
43099 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43100 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43101 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43102 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43103 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43104 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
43105 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43106 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
43107 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43108 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43109 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
43110 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43111 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43112 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
43113 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43114 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43115 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43116 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43117 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43118 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43119 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43120 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
43121 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43122 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43123 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
43124 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43125 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43126 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
43127 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43128 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43129 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
43130 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43131 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43132 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
43133 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43134 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43135 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43136 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
43137 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43138 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
43139 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43140 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43141 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43142 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43143 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43144 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43145 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43146 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43147 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43148 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43149 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43150 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43151 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43152 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43153 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43154 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43155 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43156 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
43157 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43158 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43159 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43160 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
43161 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43162 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43163 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
43164 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43165 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43166 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43167 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43168 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43169 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43170 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43171 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43172 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43173 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43174 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43175 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43176 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43177 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
43178 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43179 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43180 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43181 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43182 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43183 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
43184 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43185 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43186 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43187 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43188 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43189 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43190 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43191 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43192 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
43193 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43194 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43195 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43196 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43197 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43198 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43199 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43200 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43201 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
43202 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43203 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43204 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43205 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43206 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43207 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
43208 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43209 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43210 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
43211 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43212 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43213 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43214 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43215 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43216 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
43217 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43218 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43219 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43220 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43221 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43222 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43223 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43224 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43225 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
43226 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43227 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43228 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43229 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43230 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43231 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43232 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43233 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
43234 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43235 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43236 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43237 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
43238 &384*A12*MB*MT*P1Q1**2/S**2+
43239 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43240 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
43241 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43242 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43243 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43244 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43245 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
43246 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43247 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43248 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43249 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43250 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43251 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43252 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43253 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
43254 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
43255 &384*A2**2*MB*MT*P2Q2**2/S**2+
43256 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43257 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
43258 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
43259 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
43260 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
43261 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
43262 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43263 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
43264 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
43265 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
43266 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
43267 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
43268 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
43269 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43270 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
43271 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43272 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
43273 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43274 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43275 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
43276 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
43277 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
43278 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
43279 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43280 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43281 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43282 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43283 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
43284 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43285 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
43286 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
43287 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
43288 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
43289 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
43290 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43291 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
43292 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43293 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
43294 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43295 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43296 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43297 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
43298 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43299 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43300 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43301 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43302 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
43303 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
43304 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
43305 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
43306 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
43307 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43308 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43309 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43310 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
43311 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43312 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
43313 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43314 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43315 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43316 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43317 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43318 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43319 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
43320 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43321 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
43322 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43323 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
43324 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43325 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43326 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
43327 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
43328 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43329 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43330 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43331 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43332 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
43333 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43334 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
43335 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43336 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
43337 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43338 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
43339 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43340 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
43341 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43342 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
43343 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
43344 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
43345 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43346 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
43347 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
43348 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43349 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43350 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43351 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43352 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
43353 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43354 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43355 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
43356 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
43357 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
43358 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43359 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43360 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43361 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43362 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43363 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43364 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43365 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43366 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43367 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
43368 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43369 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
43370 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43371 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43372 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
43373 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
43374 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43375 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
43376 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43377 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
43378 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
43379 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43380 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43381 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
43382 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43383 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43384 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
43385 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43386 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43387 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43388 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
43389 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
43390 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43391 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
43392 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43393 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43394 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43395 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43396 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43397 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43398 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
43399 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
43400 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
43401 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43402 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43403 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43404 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
43405 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43406 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
43407 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
43408 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43409 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43410 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43411 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43412 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43413 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43414 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43415 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43416 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43417 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43418 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43419 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
43420 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43421 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43422 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43423 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
43424 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43425 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43426 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
43427 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43428 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
43429 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
43430 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43431 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43432 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43433 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43434 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43435 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43436 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
43437 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
43438 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43439 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43440 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
43441 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
43442 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43443 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
43444 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
43445 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
43446 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
43447 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43448 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
43449
43450 A18BIS=
43451 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43452 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43453 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43454 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43455 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43456 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
43457 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43458 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43459 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
43460 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43461 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
43462 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
43463 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43464 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43465 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
43466 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
43467 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
43468 &12*S/(P1Q2*P2Q1)+
43469 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43470 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
43471 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43472 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
43473 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43474 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43475 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43476 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43477 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43478 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
43479 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43480 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
43481 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
43482 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43483 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
43484 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
43485 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
43486 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43487 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43488 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43489 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43490 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43491 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
43492 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43493 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43494 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
43495 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43496 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43497 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
43498 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
43499 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43500 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
43501 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43502 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43503 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
43504 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43505 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
43506 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43507 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
43508 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43509 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43510 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43511 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43512 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43513 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
43514 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
43515 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43516 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
43517 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
43518 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43519 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
43520 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43521 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43522 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43523 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43524 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43525 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43526 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43527 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43528 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43529 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43530 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
43531 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
43532 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
43533 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43534 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
43535 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43536 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43537 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43538 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43539 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43540 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43541 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43542 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
43543 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43544 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43545 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43546 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
43547 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
43548 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43549 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43550 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
43551 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
43552 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43553 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43554 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43555C
43556 V18=V18+V18BIS
43557 A18=A18+A18BIS
43558 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
43559 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
43560 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43561 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43562 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43563 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
43564 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43565 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43566 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43567 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43568 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43569 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43570 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
43571 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
43572 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
43573 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
43574 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
43575 V910=V910+96*A1*A2*P1P2*P2Q1/S-
43576 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43577 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
43578 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
43579 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43580 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43581C
43582 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
43583 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
43584 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43585 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43586 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
43587 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
43588 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43589 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
43590 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
43591 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
43592 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43593 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43594 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
43595 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
43596 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
43597 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
43598 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
43599 A910=A910+96*A1*A2*P1P2*P2Q1/S-
43600 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
43601 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
43602 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
43603 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
43604 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
43605C
43606C FINAL RESULT;
43607C
43608 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
43609
43610 END
43611C---------------------------------------------------------
43612C 2) Q QBAR ->TBH^+
43613 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43614C
43615C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
43616C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
43617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43618 IMPLICIT INTEGER(I-N)
43619 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43620 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43622 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43623 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43624 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43625 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43626C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43627C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43628C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43629C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
43630C
43631C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43632C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43633C
43634 DIMENSION YY(2,2)
43635
43636 PI = 4*DATAN(1.D0)
43637 MW = DSQRT(MW2)
43638
43639C COLLECTING THE RELEVANT OVERALL FACTORS:
43640C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
43641 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
43642C COUPLING CONSTANT (OVERALL NORMALIZATION)
43643 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43644C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43645C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43646C ALPHAS IS ALPHA_STRONG;
43647C SW2 IS SIN(THETA_W)**2.
43648C
43649C VTB=.998D0
43650C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43651C
43652 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43653 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43654C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43655C
43656C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43657C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43658 DO 100 KK=1,4
43659 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43660 100 CONTINUE
43661C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43662 S = 2*PYTBHS(Q1,Q2)
43663 P1Q1=PYTBHS(Q1,P1)
43664 P1Q2=PYTBHS(P1,Q2)
43665 P2Q1=PYTBHS(P2,Q1)
43666 P2Q2=PYTBHS(P2,Q2)
43667 P1P2=PYTBHS(P1,P2)
43668C
43669C TOP WIDTH CALCULATION
43670 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43671C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43672C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43673 A1INV= S -2*P1Q1 -2*P1Q2
43674 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43675C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43676C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
43677 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43678 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43679C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43680C NOW COMES THE AMP**2:
43681C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
43682C THE EXPRESSIONS BELOW
43683 YY(1, 1) = -16*A**2*A2**2*MB*MT+
43684 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
43685 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
43686 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
43687 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
43688 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
43689 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
43690 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
43691 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
43692 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
43693 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
43694 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
43695 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
43696 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
43697 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43698 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43699 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
43700 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
43701 &32*A2**2*MB**2*P1P2*V**2/S+
43702 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
43703 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
43704 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
43705 YY(1, 1)=2*YY(1, 1)
43706
43707 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
43708 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
43709 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
43710 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
43711 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
43712 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
43713 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
43714 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
43715 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
43716 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
43717 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
43718 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43719 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
43720 &64*A**2*A1*A2*MB*MT*P1P2/S+
43721 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
43722 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
43723 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
43724 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
43725 &64*A**2*A1*A2*P1Q1*P2Q1/S-
43726 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
43727 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
43728 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
43729 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
43730 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
43731 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
43732 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
43733 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
43734 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
43735 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
43736 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
43737 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
43738 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
43739 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
43740 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
43741 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
43742 &32*A1*A2*P1P2*P1Q1*V**2/S+
43743 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
43744 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
43745 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
43746 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
43747
43748
43749 YY(2, 2) =-16*A**2*A12*MB*MT+
43750 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
43751 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
43752 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
43753 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
43754 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
43755 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
43756 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
43757 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
43758 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
43759 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
43760 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
43761 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
43762 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
43763 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
43764 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
43765 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
43766 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
43767 &32*A12*MT**2*P2Q2*V**2/S-
43768 &32*A12*P1Q2*P2Q2*V**2/S
43769 YY(2, 2)=2*YY(2, 2)
43770
43771 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
43772 AMP2= FACT*PS*VTB**2*RES
43773
43774 END
43775C=====================================================================
43776C ************* FUNCTION SCALAR PRODUCTS *************************
43777 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
43778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43779 IMPLICIT INTEGER(I-N)
43780 DIMENSION A(4),B(4)
43781 DUM=A(4)*B(4)
43782 DO 100 ID=1,3
43783 DUM=DUM-A(ID)*B(ID)
43784 100 CONTINUE
43785 PYTBHS=DUM
43786 RETURN
43787 END
43788
43789C*********************************************************************
43790
43791C...PYMSIN
43792C...Initializes supersymmetry: finds sparticle masses and
43793C...branching ratios and stores this information.
43794C...AUTHOR: STEPHEN MRENNA
43795C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
43796
43797 SUBROUTINE PYMSIN
43798
43799C...Double precision and integer declarations.
43800 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43801 IMPLICIT INTEGER(I-N)
43802 INTEGER PYK,PYCHGE,PYCOMP
43803C...Parameter statement to help give large particle numbers.
43804 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
43805 &KEXCIT=4000000,KDIMEN=5000000)
43806C...Commonblocks.
43807 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43808 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43809 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
43810 COMMON/PYDAT4/CHAF(500,2)
43811 CHARACTER CHAF*16
43812 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43813 COMMON/PYINT4/MWID(500),WIDS(500,5)
43814 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43815 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
43816 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
43817 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
43818 COMMON/PYHTRI/HHH(7)
43819 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
43820 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
43821 &/PYMSSM/,/PYMSRV/,/PYSSMT/
43822
43823C...Local variables.
43824 DOUBLE PRECISION ALFA,BETA
43825 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
43826 INTEGER I,J,J1,I1,K1
43827 INTEGER KC,LKNT,IDLAM(400,3)
43828 DOUBLE PRECISION XLAM(0:400)
43829 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
43830 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
43831 DOUBLE PRECISION DELM,XMDIF
43832 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
43833 DOUBLE PRECISION ARG,SGNMU,R
43834 INTEGER IMSSM
43835 INTEGER IRPRTY
43836 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
43837 SAVE MWIDSU,MDCYSU
43838 DATA KFSUSY/
43839 &1000001,2000001,1000002,2000002,1000003,2000003,
43840 &1000004,2000004,1000005,2000005,1000006,2000006,
43841 &1000011,2000011,1000012,2000012,1000013,2000013,
43842 &1000014,2000014,1000015,2000015,1000016,2000016,
43843 &1000021,1000022,1000023,1000025,1000035,1000024,
43844 &1000037,1000039, 25, 35, 36, 37,
43845 & 6, 24, 45, 46,1000045, 9*0/
43846 DATA INIT/0/
43847
43848C...Automatically read QNUMBERS, MASS, and DECAY tables
43849 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
43850 NQNUM=0
43851 CALL PYSLHA(0,0,IFAIL)
43852 CALL PYSLHA(5,0,IFAIL)
43853 ENDIF
43854 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
43855
43856C...Do nothing further if SUSY not requested
43857 IMSSM=IMSS(1)
43858 IF(IMSSM.EQ.0) RETURN
43859
43860C...Save copy of MWID(KC) and MDCY(KC,1) values before
43861C...they are set to zero for the LSP.
43862 IF(INIT.EQ.0) THEN
43863 INIT=1
43864 DO 100 I=1,36
43865 KF=KFSUSY(I)
43866 KC=PYCOMP(KF)
43867 MWIDSU(I)=MWID(KC)
43868 MDCYSU(I)=MDCY(KC,1)
43869 100 CONTINUE
43870 ENDIF
43871
43872C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
43873 DO 110 I=1,36
43874 KF=KFSUSY(I)
43875 KC=PYCOMP(KF)
43876 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
43877 MWID(KC)=MWIDSU(I)
43878 MDCY(KC,1)=MDCYSU(I)
43879 ENDIF
43880 110 CONTINUE
43881
43882C...First part of routine: set masses and couplings.
43883
43884C...Reset mixing values in sfermion sector to pure left/right.
43885 DO 120 I=1,16
43886 SFMIX(I,1)=1D0
43887 SFMIX(I,4)=1D0
43888 SFMIX(I,2)=0D0
43889 SFMIX(I,3)=0D0
43890 120 CONTINUE
43891
43892C...Add NMSSM states if NMSSM switched on, and change old names.
43893 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
43894C... Switch on NMSSM
43895 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
43896
43897 KFN=25
43898 KCN=KFN
43899 CHAF(KCN,1)='h_10'
43900 CHAF(KCN,2)=' '
43901
43902 KFN=35
43903 KCN=KFN
43904 CHAF(KCN,1)='h_20'
43905 CHAF(KCN,2)=' '
43906
43907 KFN=45
43908 KCN=KFN
43909 CHAF(KCN,1)='h_30'
43910 CHAF(KCN,2)=' '
43911
43912 KFN=36
43913 KCN=KFN
43914 CHAF(KCN,1)='A_10'
43915 CHAF(KCN,2)=' '
43916
43917 KFN=46
43918 KCN=KFN
43919 CHAF(KCN,1)='A_20'
43920 CHAF(KCN,2)=' '
43921
43922 KFN=1000045
43923 KCN=PYCOMP(KFN)
43924 IF (KCN.EQ.0) THEN
43925 DO 123 KCT=100,MSTU(6)
43926 IF(KCHG(KCT,4).GT.100) KCN=KCT
43927 123 CONTINUE
43928 KCN=KCN+1
43929 KCHG(KCN,4)=KFN
43930 MSTU(20)=0
43931 ENDIF
43932C... Set stable for now
43933 PMAS(KCN,2)=1D-6
43934 MWID(KCN)=0
43935 MDCY(KCN,1)=0
43936 MDCY(KCN,2)=0
43937 MDCY(KCN,3)=0
43938 CHAF(KCN,1)='~chi_50'
43939 CHAF(KCN,2)=' '
43940 ENDIF
43941
43942C...Read spectrum from SLHA file.
43943 IF (IMSSM.EQ.11) THEN
43944 CALL PYSLHA(1,0,IFAIL)
43945 ENDIF
43946
43947C...Common couplings.
43948 TANB=RMSS(5)
43949 BETA=ATAN(TANB)
43950 COSB=COS(BETA)
43951 SINB=TANB*COSB
43952 COS2B=COS(2D0*BETA)
43953 ALFA=RMSS(18)
43954 XMW2=PMAS(24,1)**2
43955 XMZ2=PMAS(23,1)**2
43956 XW=PARU(102)
43957
43958C...Define sparticle masses for a general MSSM simulation.
43959 IF(IMSSM.EQ.1) THEN
43960 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
43961 DO 130 I=1,5,2
43962 KC=PYCOMP(KSUSY1+I)
43963 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
43964 KC=PYCOMP(KSUSY2+I)
43965 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
43966 KC=PYCOMP(KSUSY1+I+1)
43967 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
43968 KC=PYCOMP(KSUSY2+I+1)
43969 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
43970 130 CONTINUE
43971 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
43972 IF(XARG.LT.0D0) THEN
43973 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
43974 & ' FROM THE SUM RULE. '
43975 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
43976 RETURN
43977 ELSE
43978 XARG=SQRT(XARG)
43979 ENDIF
43980 DO 140 I=11,15,2
43981 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
43982 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
43983 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
43984 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
43985 140 CONTINUE
43986 IF(IMSS(8).EQ.1) THEN
43987 RMSS(13)=RMSS(6)
43988 RMSS(14)=RMSS(7)
43989 ENDIF
43990
43991C...Alternatively derive masses from SUGRA relations.
43992 ELSEIF(IMSSM.EQ.2) THEN
43993 RMSS(36)=RMSS(16)
43994 CALL PYAPPS
43995C...Or use ISASUSY
43996 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
43997 RMSS(36)=RMSS(16)
43998 CALL PYSUGI
43999 ALFA=RMSS(18)
44000 GOTO 170
44001 ELSE
44002 GOTO 170
44003 ENDIF
44004
44005C...Add in extra D-term contributions.
44006 IF(IMSS(7).EQ.1) THEN
44007 R=0.43D0
44008 DX=RMSS(23)
44009 DY=RMSS(24)
44010 DS=RMSS(25)
44011 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44012 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44013 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44014 WRITE(MSTU(11),*) 'C DX = ',DX
44015 WRITE(MSTU(11),*) 'C DY = ',DY
44016 WRITE(MSTU(11),*) 'C DS = ',DS
44017 WRITE(MSTU(11),*) 'C '
44018 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44019 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44020 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44021 DQ2=DY/6D0-DX/3D0-DS/3D0
44022 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44023 DD2=DY/3D0+DX-2D0*DS/3D0
44024 DL2=-DY/2D0+DX-2D0*DS/3D0
44025 DE2=DY-DX/3D0-DS/3D0
44026 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44027 DHD2=-DY/2D0-2D0*DX/3D0+DS
44028 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44029 & /ABS(COS2B)
44030 DMA2 = 2D0*DMU2+DHU2+DHD2
44031 DO 150 I=1,5,2
44032 KC=PYCOMP(KSUSY1+I)
44033 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44034 KC=PYCOMP(KSUSY2+I)
44035 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44036 KC=PYCOMP(KSUSY1+I+1)
44037 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44038 KC=PYCOMP(KSUSY2+I+1)
44039 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44040 150 CONTINUE
44041 DO 160 I=11,15,2
44042 KC=PYCOMP(KSUSY1+I)
44043 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44044 KC=PYCOMP(KSUSY2+I)
44045 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44046 KC=PYCOMP(KSUSY1+I+1)
44047 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44048 160 CONTINUE
44049 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44050 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44051 CALL PYSTOP(104)
44052 ENDIF
44053 SGNMU=SIGN(1D0,RMSS(4))
44054 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44055 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44056 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44057 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44058 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44059 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44060 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44061 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44062 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44063 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44064 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44065 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44066 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44067 CALL PYSTOP(104)
44068 ENDIF
44069 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44070 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44071 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44072 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44073 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44074 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
44075 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
44076 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
44077 ENDIF
44078
44079C...Fix the third generation sfermions.
44080 CALL PYTHRG
44081
44082C...Fix the neutralino--chargino--gluino sector.
44083 CALL PYINOM
44084
44085C...Fix the Higgs sector.
44086 CALL PYHGGM(ALFA)
44087
44088C...Choose the Gunion-Haber convention.
44089 ALFA=-ALFA
44090 RMSS(18)=ALFA
44091
44092C...Print information on mass parameters.
44093 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
44094 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44095 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
44096 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
44097 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
44098 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
44099 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
44100 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
44101 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
44102 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
44103 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44104 ENDIF
44105 IF(IMSS(20).EQ.1) THEN
44106 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44107 WRITE(MSTU(11),*) ' DEBUG MODE '
44108 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
44109 & UMIX(2,1),UMIX(2,2)
44110 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
44111 & UMIXI(2,1),UMIXI(2,2)
44112 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
44113 & VMIX(2,1),VMIX(2,2)
44114 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
44115 & VMIXI(2,1),VMIXI(2,2)
44116 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
44117 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
44118 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
44119 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
44120 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
44121 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
44122 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
44123 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
44124 WRITE(MSTU(11),*) ' ALFA = ',ALFA
44125 WRITE(MSTU(11),*) ' BETA = ',BETA
44126 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
44127 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
44128 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44129 ENDIF
44130
44131C...Set up the Higgs couplings - needed here since initialization
44132C...in PYINRE did not yet occur when PYWIDT is called below.
44133 170 AL=ALFA
44134 BE=BETA
44135 SINA=SIN(AL)
44136 COSA=COS(AL)
44137 COSB=COS(BE)
44138 SINB=TANB*COSB
44139 SBMA=SIN(BE-AL)
44140 SAPB=SIN(AL+BE)
44141 CAPB=COS(AL+BE)
44142 CBMA=COS(BE-AL)
44143 C2A=COS(2D0*AL)
44144 C2B=COSB**2-SINB**2
44145C...tanb (used for H+)
44146 PARU(141)=TANB
44147
44148C...Firstly: h
44149C...Coupling to d-type quarks
44150 PARU(161)=SINA/COSB
44151C...Coupling to u-type quarks
44152 PARU(162)=-COSA/SINB
44153C...Coupling to leptons
44154 PARU(163)=PARU(161)
44155C...Coupling to Z
44156 PARU(164)=SBMA
44157C...Coupling to W
44158 PARU(165)=PARU(164)
44159
44160C...Secondly: H
44161C...Coupling to d-type quarks
44162 PARU(171)=-COSA/COSB
44163C...Coupling to u-type quarks
44164 PARU(172)=-SINA/SINB
44165C...Coupling to leptons
44166 PARU(173)=PARU(171)
44167C...Coupling to Z
44168 PARU(174)=CBMA
44169C...Coupling to W
44170 PARU(175)=PARU(174)
44171C...Coupling to h
44172 IF(IMSS(4).GE.2) THEN
44173 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
44174 ELSE
44175 HHH(3)=HHH(3)+HHH(4)+HHH(5)
44176 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
44177 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
44178 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
44179 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
44180 ENDIF
44181C...Coupling to H+
44182C...Define later
44183 IF(IMSS(4).GE.2) THEN
44184 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
44185 ELSE
44186 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
44187 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
44188 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
44189 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
44190 ENDIF
44191C...Coupling to A
44192 IF(IMSS(4).GE.2) THEN
44193 PARU(177)=COS(2D0*BE)*COS(BE+AL)
44194 ELSE
44195 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
44196 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
44197 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
44198 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
44199 ENDIF
44200C...Coupling to H+
44201 IF(IMSS(4).GE.2) THEN
44202 PARU(178)=PARU(177)
44203 ELSE
44204 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
44205 ENDIF
44206C...Thirdly, A
44207C...Coupling to d-type quarks
44208 PARU(181)=TANB
44209C...Coupling to u-type quarks
44210 PARU(182)=1D0/PARU(181)
44211C...Coupling to leptons
44212 PARU(183)=PARU(181)
44213 PARU(184)=0D0
44214 PARU(185)=0D0
44215C...Coupling to Z h
44216 PARU(186)=COS(BE-AL)
44217C...Coupling to Z H
44218 PARU(187)=SIN(BE-AL)
44219 PARU(188)=0D0
44220 PARU(189)=0D0
44221 PARU(190)=0D0
44222
44223C...Finally: H+
44224C...Coupling to W h
44225 PARU(195)=COS(BE-AL)
44226
44227C...Tell that all Higgs couplings have been set.
44228 MSTP(4)=1
44229
44230C...Set R-Violating couplings.
44231C...Set lambda couplings to common value or "natural values".
44232 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
44233 VIR3=1D0/(126D0)**3
44234 DO 200 IRK=1,3
44235 DO 190 IRI=1,3
44236 DO 180 IRJ=1,3
44237 IF (IRI.NE.IRJ) THEN
44238 IF (IRI.LT.IRJ) THEN
44239 RVLAM(IRI,IRJ,IRK)=RMSS(51)
44240 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
44241 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
44242 & PMAS(9+2*IRK,1)*VIR3)
44243 ELSE
44244 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
44245 ENDIF
44246 ELSE
44247 RVLAM(IRI,IRJ,IRK)=0D0
44248 ENDIF
44249 180 CONTINUE
44250 190 CONTINUE
44251 200 CONTINUE
44252 ENDIF
44253C...Set lambda' couplings to common value or "natural values".
44254 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
44255 VIR3=1D0/(126D0)**3
44256 DO 230 IRI=1,3
44257 DO 220 IRJ=1,3
44258 DO 210 IRK=1,3
44259 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
44260 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
44261 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
44262 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
44263 210 CONTINUE
44264 220 CONTINUE
44265 230 CONTINUE
44266 ENDIF
44267C...Set lambda'' couplings to common value or "natural values".
44268 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
44269 VIR3=1D0/(126D0)**3
44270 DO 260 IRI=1,3
44271 DO 250 IRJ=1,3
44272 DO 240 IRK=1,3
44273 IF (IRJ.NE.IRK) THEN
44274 IF (IRJ.LT.IRK) THEN
44275 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
44276 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
44277 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
44278 & PMAS(2*IRK-1,1)*VIR3)
44279 ELSE
44280 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
44281 ENDIF
44282 ELSE
44283 RVLAMB(IRI,IRJ,IRK) = 0D0
44284 ENDIF
44285 240 CONTINUE
44286 250 CONTINUE
44287 260 CONTINUE
44288 ENDIF
44289
44290C...Antisymmetrize couplings set by user
44291 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
44292 DO 290 IRI=1,3
44293 DO 280 IRJ=1,3
44294 DO 270 IRK=1,3
44295 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
44296 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
44297 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
44298 ENDIF
44299 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
44300 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
44301 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
44302 ENDIF
44303 270 CONTINUE
44304 280 CONTINUE
44305 290 CONTINUE
44306 ENDIF
44307
44308C...Write spectrum to SLHA file
44309 IF (IMSS(23).NE.0) THEN
44310 IFAIL=0
44311 CALL PYSLHA(3,0,IFAIL)
44312 ENDIF
44313
44314C...Second part of routine: set decay modes and branching ratios.
44315
44316C...Allow chi10 -> gravitino + gamma or not.
44317 KC=PYCOMP(KSUSY1+39)
44318 IF( IMSS(11) .NE. 0 ) THEN
44319 PMAS(KC,1)=RMSS(21)/1D9
44320 PMAS(KC,2)=0D0
44321 IRPRTY=0
44322 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
44323 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
44324 IRPRTY=0
44325 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
44326 & ' ALLOWING SUSY LLE DECAYS'
44327 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
44328 & ' ALLOWING SUSY LQD DECAYS'
44329 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
44330 & ' ALLOWING SUSY UDD DECAYS'
44331 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
44332 & ' --- Warning: R-Violating couplings possibly',
44333 & ' incompatible with proton decay'
44334 ELSE
44335 PMAS(KC,1)=9999D0
44336 IRPRTY=1
44337 ENDIF
44338
44339C...Loop over sparticle and Higgs species.
44340 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
44341C...Find the LSP or NLSP for a gravitino LSP
44342 ILSP=0
44343 PMLSP=1D20
44344 DO 300 I=1,36
44345 KF=KFSUSY(I)
44346 IF(KF.EQ.1000039) GOTO 300
44347 KC=PYCOMP(KF)
44348 IF(PMAS(KC,1).LT.PMLSP) THEN
44349 ILSP=I
44350 PMLSP=PMAS(KC,1)
44351 ENDIF
44352 300 CONTINUE
44353 DO 370 I=1,50
44354 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
44355 KF=KFSUSY(I)
44356 IF (KF.EQ.0) GOTO 370
44357 KC=PYCOMP(KF)
44358 LKNT=0
44359
44360C...Check if there are any decays listed for this sparticle
44361C...in a file
44362 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
44363 IFAIL=0
44364 CALL PYSLHA(2,KF,IFAIL)
44365 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
44366 ELSEIF (I.GE.37) THEN
44367 GOTO 370
44368 ENDIF
44369
44370C...Sfermion decays.
44371 IF(I.LE.24) THEN
44372C...First check to see if sneutrino is lighter than chi10.
44373 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
44374 & PMAS(KC,1).LT.PMCHI1) THEN
44375 ELSE
44376 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
44377 ENDIF
44378
44379C...Gluino decays.
44380 ELSEIF(I.EQ.25) THEN
44381 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
44382 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
44383
44384C...Neutralino decays.
44385 ELSEIF(I.GE.26.AND.I.LE.29) THEN
44386 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
44387C...chi10 stable or chi10 -> gravitino + gamma.
44388 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
44389 PMAS(KC,2)=1D-6
44390 MDCY(KC,1)=0
44391 MWID(KC)=0
44392 ENDIF
44393
44394C...Chargino decays.
44395 ELSEIF(I.GE.30.AND.I.LE.31) THEN
44396 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
44397
44398C...Gravitino is stable.
44399 ELSEIF(I.EQ.32) THEN
44400 MDCY(KC,1)=0
44401 MWID(KC)=0
44402
44403C...Higgs decays.
44404 ELSEIF(I.GE.33.AND.I.LE.36) THEN
44405C...Calculate decays to non-SUSY particles.
44406 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
44407 LKNT=0
44408 DO 310 I1=0,100
44409 XLAM(I1)=0D0
44410 310 CONTINUE
44411 DO 330 I1=1,MDCY(KC,3)
44412 K1=MDCY(KC,2)+I1-1
44413 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
44414 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
44415 XLAM(I1)=WDTP(I1)
44416 XLAM(0)=XLAM(0)+XLAM(I1)
44417 DO 320 J1=1,3
44418 IDLAM(I1,J1)=KFDP(K1,J1)
44419 320 CONTINUE
44420 LKNT=LKNT+1
44421 330 CONTINUE
44422C...Add the decays to SUSY particles.
44423 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
44424 ENDIF
44425C...Zero the branching ratios for use in loop mode
44426C...thanks to K. Matchev (FNAL)
44427 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
44428 BRAT(IDC)=0D0
44429 340 CONTINUE
44430
44431C...Set stable particles.
44432 IF(LKNT.EQ.0) THEN
44433 MDCY(KC,1)=0
44434 MWID(KC)=0
44435 PMAS(KC,2)=1D-6
44436 PMAS(KC,3)=1D-5
44437 PMAS(KC,4)=0D0
44438
44439C...Store branching ratios in the standard tables.
44440 ELSE
44441 IDC=MDCY(KC,2)+MDCY(KC,3)-1
44442 DELM=1D6
44443 DO 360 IL=1,LKNT
44444 IDCSV=IDC
44445 350 IDC=IDC+1
44446 BRAT(IDC)=0D0
44447 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
44448 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
44449 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
44450 BRAT(IDC)=XLAM(IL)/XLAM(0)
44451 XMDIF=PMAS(KC,1)
44452 IF(MDME(IDC,1).GE.1) THEN
44453 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
44454 & PMAS(PYCOMP(KFDP(IDC,2)),1)
44455 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
44456 & PMAS(PYCOMP(KFDP(IDC,3)),1)
44457 ENDIF
44458 IF(I.LE.32) THEN
44459 IF(XMDIF.GE.0D0) THEN
44460 DELM=MIN(DELM,XMDIF)
44461 ELSE
44462 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
44463 WRITE(MSTU(11),*) ' KF = ',KF
44464 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
44465 ENDIF
44466 ENDIF
44467 GOTO 360
44468 ELSEIF(IDC.EQ.IDCSV) THEN
44469 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
44470 & 'channel not recognized:'
44471 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
44472 GOTO 360
44473 ELSE
44474 GOTO 350
44475 ENDIF
44476 360 CONTINUE
44477
44478C...Store width, cutoff and lifetime.
44479 PMAS(KC,2)=XLAM(0)
44480 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
44481 PMAS(KC,3)=PMAS(KC,2)*10D0
44482 ELSE
44483 PMAS(KC,3)=0.95D0*DELM
44484 ENDIF
44485 IF(PMAS(KC,2).NE.0D0) THEN
44486 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
44487 ENDIF
44488C...Write decays to SLHA file
44489 IF (IMSS(24).NE.0) THEN
44490 IFAIL=0
44491 CALL PYSLHA(4,KF,IFAIL)
44492 ENDIF
44493
44494 ENDIF
44495 370 CONTINUE
44496
44497 RETURN
44498 END
44499C*********************************************************************
44500
44501C...PYSLHA
44502C...Read/write spectrum or decay data from SLHA standard file(s).
44503C...P. Skands
44504
44505C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
44506C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
44507C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
44508C... (KFORIG=0 : read all decay tables)
44509C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
44510C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
44511C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
44512C... (KFORIG=0 : read all MASS entries)
44513
44514C...Recent updates:
44515C...17 Sep 2007: introduced /PYQNUM/ for QNUMBERS storage
44516C... : Corrected QNUMBERS name-formation; root only until space
44517 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
44518
44519C...Double precision and integer declarations.
44520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44521 IMPLICIT INTEGER(I-N)
44522 INTEGER PYK,PYCHGE,PYCOMP
44523 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44524 &KEXCIT=4000000,KDIMEN=5000000)
44525C...Commonblocks.
44526 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44527 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44528 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44529 COMMON/PYDAT4/CHAF(500,2)
44530 CHARACTER CHAF*16
44531 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44532 CHARACTER*40 ISAVER,VISAJE
44533 COMMON/PYINT4/MWID(500),WIDS(500,5)
44534 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
44535C...SUSY blocks
44536 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44537 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44538 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44539 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44540 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
44541
44542C...Local arrays, character variables and data.
44543 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
44544 & AU(3,3),AD(3,3),AE(3,3)
44545 COMMON/PYLH3C/CPRO(2),CVER(2)
44546C...The common block of new states (QNUMBERS / PARTICLE)
44547 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44548C...- NQNUM : Number of QNUMBERS blocks that have been read in
44549C...- KQNUM(I,0) : KF of new state
44550C...- KQNUM(I,1) : 3 times electric charge
44551C...- KQNUM(I,2) : Number of spin states: (2S + 1)
44552C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
44553C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
44554C...- KQNUM(I,5:9) : space available for further quantum numbers
44555 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
44556 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
44557C...MMOD: flags to set for each block read in.
44558C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
44559C...MSPC: Flags to set for each block read in.
44560C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
44561C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
44562C...11: AD 12: AE 13: YU 14: YD 15: YE
44563C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
44564 CHARACTER CPRO*12,CVER*12,CHNLIN*6
44565 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
44566 CHARACTER CHINL*120,CHKF*9,CHTMP*16
44567 INTEGER VERBOS
44568 SAVE VERBOS
44569C...Date of last Change
44570 PARAMETER (DOC='05 Nov 2007')
44571C...Local arrays and initial values
44572 DIMENSION IDC(5),KFSUSY(50)
44573 SAVE KFSUSY
44574 DATA NQNUM /0/
44575 DATA NDECAY /0/
44576 DATA VERBOS /1/
44577 DATA NHELLO /0/
44578 DATA MLHEF /0/
44579 DATA MLHEFD /0/
44580 DATA KFSUSY/
44581 &1000001,1000002,1000003,1000004,1000005,1000006,
44582 &2000001,2000002,2000003,2000004,2000005,2000006,
44583 &1000011,1000012,1000013,1000014,1000015,1000016,
44584 &2000011,2000012,2000013,2000014,2000015,2000016,
44585 &1000021,1000022,1000023,1000025,1000035,1000024,
44586 &1000037,1000039, 25, 35, 36, 37,
44587 & 6, 24, 45, 46,1000045, 9*0/
44588 DATA KFDEC/100*0/
44589 RMFUN(IP)=PMAS(PYCOMP(IP),1)
44590
44591C...Shorthand for spectrum and decay table unit numbers
44592 IMSS21=IMSS(21)
44593 IMSS22=IMSS(22)
44594
44595C...Default for LHEF input: read header information
44596 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
44597 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
44598 IF (IMSS21.EQ.MSTP(161)) MLHEF=1
44599 IF (IMSS22.EQ.MSTP(161)) MLHEFD=1
44600
44601C...Hello World
44602 IF (NHELLO.EQ.0) THEN
44603 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
44604 WRITE(MSTU(11),5000) DOC
44605 NHELLO=1
44606 ENDIF
44607 ENDIF
44608
44609C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
44610C...+MUPDA).
44611 LFN=IMSS21
44612 IF (MUPDA.EQ.2) LFN=IMSS22
44613 IF (MUPDA.EQ.3) LFN=IMSS(23)
44614 IF (MUPDA.EQ.4) LFN=IMSS(24)
44615C...Flag that we have not yet found whatever we were asked to find.
44616 IRETRN=1
44617
44618C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
44619 IF (LFN.EQ.0) THEN
44620 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
44621 GOTO 9999
44622 ENDIF
44623
44624C...If reading LHEF header, start by rewinding file
44625 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
44626
44627C...If told to read spectrum, first zero all previous information.
44628 IF (MUPDA.EQ.1) THEN
44629C...Zero all block read flags
44630 DO 100 M=1,100
44631 MMOD(M)=0
44632 MSPC(M)=0
44633 100 CONTINUE
44634C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
44635 DO 110 ISUSY=1,36
44636 KC=PYCOMP(KFSUSY(ISUSY))
44637 PMAS(KC,1)=0D0
44638 110 CONTINUE
44639C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
44640 DO 130 J=1,4
44641 SFMIX(5,J) =0D0
44642 SFMIX(6,J) =0D0
44643 SFMIX(15,J)=0D0
44644 DO 120 L=1,4
44645 ZMIX(L,J) =0D0
44646 ZMIXI(L,J)=0D0
44647 IF (J.LE.2.AND.L.LE.2) THEN
44648 UMIX(L,J) =0D0
44649 UMIXI(L,J)=0D0
44650 VMIX(L,J) =0D0
44651 VMIXI(L,J)=0D0
44652 ENDIF
44653 120 CONTINUE
44654C...Zero signed masses.
44655 SMZ(J)=0D0
44656 IF (J.LE.2) SMW(J)=0D0
44657 130 CONTINUE
44658
44659C...If reading decays, reset PYTHIA decay counters.
44660 ELSEIF (MUPDA.EQ.2) THEN
44661C...Check if DECAY for this KF already read
44662 IF (KFORIG.NE.0) THEN
44663 DO 140 IDEC=1,NDECAY
44664 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
44665 IRETRN=0
44666 RETURN
44667 ENDIF
44668 140 CONTINUE
44669 ENDIF
44670 KCC=100
44671 NDC=0
44672 BRSUM=0D0
44673 DO 150 KC=1,MSTU(6)
44674 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
44675 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
44676 150 CONTINUE
44677 ELSEIF (MUPDA.EQ.5) THEN
44678C...Zero block read flags
44679 DO 160 M=1,100
44680 MSPC(M)=0
44681 160 CONTINUE
44682 ENDIF
44683
44684C............READ
44685C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
44686 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
44687C...Initialize program and version strings
44688 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
44689 CPRO(MUPDA)=' '
44690 CVER(MUPDA)=' '
44691 ENDIF
44692
44693C...Initialize read loop
44694 MERR=0
44695 NLINE=0
44696 CHBLCK=' '
44697C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
44698 170 CHINL=' '
44699 READ(LFN,'(A120)',END=400) CHINL
44700C...Count which line number we're at.
44701 NLINE=NLINE+1
44702 WRITE(CHNLIN,'(I6)') NLINE
44703
44704C...Skip comment and empty lines without processing.
44705 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
44706
44707C...We assume all upper case below. Rewrite CHINL to all upper case.
44708 INL=0
44709 IGOOD=0
44710 180 INL=INL+1
44711 IF (CHINL(INL:INL).NE.'#') THEN
44712 DO 190 ICH=97,122
44713 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
44714 190 CONTINUE
44715C...Extra safety. Chek for sensible input on line
44716 IF (IGOOD.EQ.0) THEN
44717 DO 200 ICH=48,90
44718 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
44719 200 CONTINUE
44720 ENDIF
44721 IF (INL.LT.120) GOTO 180
44722 ENDIF
44723 IF (IGOOD.EQ.0) GOTO 170
44724
44725C...Exit when first <event> tag reached in LHEF file
44726 DO 210 I1=1,10
44727 IF (CHINL(I1:I1+5).EQ.'<EVENT') THEN
44728 REWIND(LFN)
44729 GOTO 400
44730 ENDIF
44731 210 CONTINUE
44732
44733C...Check for BLOCK begin statement (spectrum).
44734 IF (CHINL(1:5).EQ.'BLOCK') THEN
44735 MERR=0
44736 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
44737C...Check if another of this type of block was already read.
44738C...(logarithmic interpolation not yet implemented, so duplicates always
44739C...give errors)
44740 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
44741 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
44742 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
44743 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
44744 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
44745 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
44746 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
44747 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
44748 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
44749 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
44750 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
44751 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
44752 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
44753 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
44754 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
44755 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
44756 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
44757C...Check for new particles
44758 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44759 & THEN
44760 MSPC(19)=MSPC(19)+1
44761C...Read PDG code
44762 READ(CHBLCK(9:60),*) KFQ
44763
44764 DO 220 MQ=1,NQNUM
44765 IF (KQNUM(MQ,0).EQ.KFQ) THEN
44766 MERR=17
44767 GOTO 380
44768 ENDIF
44769 220 CONTINUE
44770 IF (NHELLO.EQ.0) THEN
44771 WRITE(MSTU(11),5000) DOC
44772 NHELLO=1
44773 ENDIF
44774 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44775 & ' * (PYSLHA:) Reading in '//CHBLCK(1:8)//
44776 & ' for KF =',KFQ
44777 NQNUM=NQNUM+1
44778 KQNUM(NQNUM,0)=KFQ
44779 MSPC(19)=MSPC(19)+1
44780 KCQ=PYCOMP(KFQ)
44781C...Only read in new codes (also OK to overwrite if KF > 3000000)
44782 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
44783 IF (KCQ.EQ.0) THEN
44784 DO 230 KCT=100,MSTU(6)
44785 IF(KCHG(KCT,4).GT.100) KCQ=KCT
44786 230 CONTINUE
44787 KCQ=KCQ+1
44788 ENDIF
44789 KCC=KCQ
44790 KCHG(KCQ,4)=KFQ
44791C...First write PDG code as name
44792 WRITE(CHTMP,*) KFQ
44793 WRITE(CHTMP,'(A)') CHTMP(2:10)
44794C...Then look for real name
44795 IBEG=9
44796 240 IBEG=IBEG+1
44797 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
44798 250 IBEG=IBEG+1
44799 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
44800 IEND=IBEG-1
44801 260 IEND=IEND+1
44802 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
44803 IF (IEND.LT.59) THEN
44804 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
44805 IF (CHDUM.NE.' ') CHTMP=CHDUM
44806 ENDIF
44807 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
44808 MSTU(20)=0
44809C...Set stable for now
44810 PMAS(KCQ,2)=1D-6
44811 MWID(KCQ)=0
44812 MDCY(KCQ,1)=0
44813 MDCY(KCQ,2)=0
44814 MDCY(KCQ,3)=0
44815 ELSE
44816 WRITE(MSTU(11),*)
44817 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
44818 & CHAF(KCQ,1), '. Entry ignored.'
44819 MERR=7
44820 ENDIF
44821 ENDIF
44822C...Finalize this line and read next.
44823 GOTO 380
44824C...Check for DECAY begin statement (decays).
44825 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
44826 MERR=0
44827 BRSUM=0D0
44828 CHBLCK='DECAY'
44829C...Read KF code and WIDTH
44830 MPSIGN=1
44831 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
44832 IF (KF.LE.0) THEN
44833 KF=-KF
44834 MPSIGN=-1
44835 ENDIF
44836C...If this is not the KF we're looking for...
44837 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
44838C...Set block skip flag and read next line.
44839 MERR=16
44840 GOTO 380
44841 ELSE
44842C...Check whether decay table for this particle already read in
44843 DO 280 IDECAY=1,NDECAY
44844 IF (KFDEC(IDECAY).EQ.KF) THEN
44845 MERR=16
44846 GOTO 380
44847 ENDIF
44848 280 CONTINUE
44849 ENDIF
44850
44851C...Determine PYTHIA KC code of particle
44852 KCREP=0
44853 IF(KF.LE.100) THEN
44854 KCREP=KF
44855 ELSE
44856 DO 290 KCR=101,KCC
44857 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
44858 290 CONTINUE
44859 ENDIF
44860 KC=KCREP
44861 IF (KCREP.NE.0) THEN
44862C...Particle is already known. Don't do anything yet.
44863 ELSE
44864C... Add new particle. Actually, this should not happen.
44865C... New particles should be added already when reading the spectrum
44866C... information, so go under previously stable category.
44867 KCC=KCC+1
44868 KC=KCC
44869 ENDIF
44870
44871 IF (WIDTH.LE.0D0) THEN
44872C...Stable (i.e. LSP)
44873 WRITE(MSTU(11),*)
44874 & '* (PYSLHA:) Reading in SLHA stable particle ',
44875 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
44876 IF (WIDTH.LT.0D0) THEN
44877 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
44878 & ' zero !')
44879 WIDTH=0D0
44880 ENDIF
44881 PMAS(KC,2)=1D-6
44882 MWID(KC)=0
44883 MDCY(KC,1)=0
44884C...Ignore any decay lines that may be present for this KF
44885 MERR=16
44886 MDCY(KC,2)=0
44887 MDCY(KC,3)=0
44888C...Return ok
44889 IRETRN=0
44890 ENDIF
44891C...Finalize and start reading in decay modes.
44892 GOTO 380
44893 ELSEIF (MOD(MERR,10).GE.6) THEN
44894C...If ignore block flag set, skip directly to next line.
44895 GOTO 170
44896 ENDIF
44897
44898C...READ SPECTRUM
44899 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
44900 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
44901 & THEN
44902 READ(CHINL,*) INDX, IVAL
44903 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
44904 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
44905 IF (INDX.EQ.3) KCHG(KCQ,2)=0
44906 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
44907 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
44908 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
44909 IF (INDX.EQ.4) THEN
44910 KCHG(KCQ,3)=IVAL
44911 IF (IVAL.EQ.1) THEN
44912 CHTMP=CHAF(KCQ,1)
44913 IF (CHTMP.EQ.' ') THEN
44914 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
44915 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
44916 ELSE
44917 ILAST=17
44918 300 ILAST=ILAST-1
44919 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
44920 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
44921 CHTMP(ILAST:ILAST)='-'
44922 ELSE
44923 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
44924 ENDIF
44925 CHAF(KCQ,2)=CHTMP
44926 ENDIF
44927 ENDIF
44928 ENDIF
44929 ELSE
44930 MERR=8
44931 ENDIF
44932 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
44933C...MASS: Mass spectrum
44934 IF (CHBLCK(1:4).EQ.'MASS') THEN
44935 READ(CHINL,*) KF, VAL
44936 MERR=1
44937 KC=0
44938 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
44939C...Read in masses for anything
44940 MERR=0
44941 KC=PYCOMP(KF)
44942C...Don't read in masses for the light quarks
44943 IF (IABS(KF).LE.3) THEN
44944 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44945 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
44946 & KF
44947 MERR=1
44948 ENDIF
44949 IF (KC.NE.0) THEN
44950 MSPC(1)=MSPC(1)+1
44951 PMAS(KC,1) = ABS(VAL)
44952 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
44953 WRITE(MSTU(11),'(A,I9,A,F12.3)')
44954 & ' * (PYSLHA:) Reading in MASS entry for KF =',
44955 & KF, ', pole mass =', VAL
44956 IRETRN=0
44957 ENDIF
44958C... Signed masses
44959 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
44960 IF (KF.EQ.1000022) SMZ(1)=VAL
44961 IF (KF.EQ.1000023) SMZ(2)=VAL
44962 IF (KF.EQ.1000025) SMZ(3)=VAL
44963 IF (KF.EQ.1000035) SMZ(4)=VAL
44964 IF (KF.EQ.1000024) SMW(1)=VAL
44965 IF (KF.EQ.1000037) SMW(2)=VAL
44966 ENDIF
44967 ELSEIF (MUPDA.EQ.5) THEN
44968 MERR=0
44969 ENDIF
44970C... MODSEL: Model selection and global switches
44971 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
44972 READ(CHINL,*) INDX, IVAL
44973 IF (INDX.LE.200.AND.INDX.GT.0) THEN
44974 IF (IMSS(1).EQ.0) IMSS(1)=11
44975 MODSEL(INDX)=IVAL
44976 MMOD(1)=MMOD(1)+1
44977 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
44978C... Switch on NMSSM
44979 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
44980 IMSS(13)=MAX(1,IMSS(13))
44981C... Add NMSSM states if not already done
44982
44983 KFN=25
44984 KCN=KFN
44985 CHAF(KCN,1)='h_10'
44986 CHAF(KCN,2)=' '
44987
44988 KFN=35
44989 KCN=KFN
44990 CHAF(KCN,1)='h_20'
44991 CHAF(KCN,2)=' '
44992
44993 KFN=45
44994 KCN=KFN
44995 CHAF(KCN,1)='h_30'
44996 CHAF(KCN,2)=' '
44997
44998 KFN=36
44999 KCN=KFN
45000 CHAF(KCN,1)='A_10'
45001 CHAF(KCN,2)=' '
45002
45003 KFN=46
45004 KCN=KFN
45005 CHAF(KCN,1)='A_20'
45006 CHAF(KCN,2)=' '
45007
45008 KFN=1000045
45009 KCN=PYCOMP(KFN)
45010 IF (KCN.EQ.0) THEN
45011 DO 310 KCT=100,MSTU(6)
45012 IF(KCHG(KCT,4).GT.100) KCN=KCT
45013 310 CONTINUE
45014 KCN=KCN+1
45015 KCHG(KCN,4)=KFN
45016 MSTU(20)=0
45017 ENDIF
45018C... Set stable for now
45019 PMAS(KCN,2)=1D-6
45020 MWID(KCN)=0
45021 MDCY(KCN,1)=0
45022 MDCY(KCN,2)=0
45023 MDCY(KCN,3)=0
45024 CHAF(KCN,1)='~chi_50'
45025 CHAF(KCN,2)=' '
45026 ENDIF
45027 ELSE
45028 MERR=1
45029 ENDIF
45030 ELSEIF (MUPDA.EQ.5) THEN
45031C...If MUPDA = 5, skip all except MASS, return if MODSEL
45032 MERR=8
45033 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
45034 & CHBLCK(1:8).EQ.'PARTICLE') THEN
45035C...Don't print a warning for QNUMBERS when reading spectrum
45036 MERR=8
45037C...MINPAR: Minimal model parameters
45038 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
45039 READ(CHINL,*) INDX, VAL
45040 IF (INDX.LE.100.AND.INDX.GT.0) THEN
45041 PARMIN(INDX)=VAL
45042 MMOD(2)=MMOD(2)+1
45043 ELSE
45044 MERR=1
45045 ENDIF
45046 IF (MMOD(3).NE.0) THEN
45047 WRITE(MSTU(11),*)
45048 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
45049 MERR=1
45050 ENDIF
45051C...tan(beta)
45052 IF (INDX.EQ.3) RMSS(5)=VAL
45053C...EXTPAR: non-minimal model parameters.
45054 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
45055 IF (MMOD(1).NE.0) THEN
45056 READ(CHINL,*) INDX, VAL
45057 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45058 PAREXT(INDX)=VAL
45059 MMOD(3)=MMOD(3)+1
45060 ELSE
45061 MERR=1
45062 ENDIF
45063 ELSE
45064 WRITE(MSTU(11),*)
45065 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
45066 MERR=1
45067 ENDIF
45068C...tan(beta)
45069 IF (INDX.EQ.25) RMSS(5)=VAL
45070 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
45071 READ(CHINL,*) INDX, VAL
45072 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
45073 MERR=1
45074 ELSEIF (INDX.EQ.4) THEN
45075 PMAS(PYCOMP(23),1)=VAL
45076 ELSEIF (INDX.EQ.6) THEN
45077 PMAS(PYCOMP(6),1)=VAL
45078 ENDIF
45079 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
45080 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
45081 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
45082 $ THEN
45083C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
45084 IM=0
45085 IF (CHBLCK(5:6).EQ.'IM') IM=1
45086 320 READ(CHINL,*) INDX1, INDX2, VAL
45087 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
45088 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
45089 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
45090 MSPC(2)=MSPC(2)+1
45091 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
45092 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
45093 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
45094 MSPC(3)=MSPC(3)+1
45095 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
45096 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
45097 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
45098 MSPC(4)=MSPC(4)+1
45099 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
45100 $ .CHBLCK(1:4).EQ.'STAU') THEN
45101 IF (CHBLCK(1:4).EQ.'STOP') THEN
45102 KFSM=6
45103 ISPC=6
45104 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
45105 KFSM=5
45106 ISPC=5
45107 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
45108 KFSM=15
45109 ISPC=7
45110 ENDIF
45111C...Set SFMIX element
45112 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
45113 MSPC(ISPC)=MSPC(ISPC)+1
45114 ENDIF
45115C...Running parameters
45116 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
45117 READ(CHBLCK(8:25),*,ERR=620) Q
45118 READ(CHINL,*) INDX, VAL
45119 MSPC(8)=MSPC(8)+1
45120 IF (INDX.EQ.1) THEN
45121 RMSS(4) = VAL
45122 ELSE
45123 MERR=1
45124 MSPC(8)=MSPC(8)-1
45125 ENDIF
45126 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
45127 READ(CHINL,*,ERR=630) VAL
45128 RMSS(18)= VAL
45129 MSPC(17)=MSPC(17)+1
45130C...Higgs parameters set manually or with FeynHiggs.
45131 IMSS(4)=MAX(2,IMSS(4))
45132 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
45133 & .CHBLCK(1:2).EQ.'AE') THEN
45134 READ(CHBLCK(9:26),*,ERR=620) Q
45135 READ(CHINL,*) INDX1, INDX2, VAL
45136 IF (CHBLCK(2:2).EQ.'U') THEN
45137 AU(INDX1,INDX2)=VAL
45138 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
45139 MSPC(11)=MSPC(11)+1
45140 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
45141 AD(INDX1,INDX2)=VAL
45142 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
45143 MSPC(10)=MSPC(10)+1
45144 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
45145 AE(INDX1,INDX2)=VAL
45146 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
45147 MSPC(12)=MSPC(12)+1
45148 ELSE
45149 MERR=1
45150 ENDIF
45151 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
45152 IF (MSPC(18).EQ.0) THEN
45153 READ(CHBLCK(9:25),*,ERR=620) Q
45154 RMSOFT(0)=Q
45155 ENDIF
45156 READ(CHINL,*) INDX, VAL
45157 RMSOFT(INDX)=VAL
45158 MSPC(18)=MSPC(18)+1
45159 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
45160 MERR=8
45161 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
45162 & .CHBLCK(1:2).EQ.'YE') THEN
45163 MERR=8
45164 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
45165 READ(CHINL(1:6),*) INDX
45166 IT=0
45167 MIRD=0
45168 330 IT=IT+1
45169 IF (CHINL(IT:IT).EQ.' ') GOTO 330
45170C...Don't read index
45171 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
45172 MIRD=1
45173 GOTO 330
45174 ENDIF
45175 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
45176 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
45177 ELSE
45178C... Set unrecognized block flag.
45179 MERR=6
45180 ENDIF
45181
45182C...DECAY TABLES
45183C...Read in decay information
45184 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
45185C...Read new decay chanel
45186 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
45187 NDC=NDC+1
45188C...Read in branching ratio and number of daughters for this mode.
45189 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
45190 READ(CHINL(4:50),*,ERR=600) DUM, NDA
45191 IF (NDA.LE.5) THEN
45192 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
45193 & '(PYSLHA:) Decay data arrays full by KF ='
45194 $ //CHAF(KC,1))
45195C...If first decay channel, set decays start point in decay table
45196 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
45197 IF (KFORIG.EQ.0) WRITE(MSTU(11),*)
45198 & '* (PYSLHA:) Reading in SLHA decay table for ',
45199 & 'KF =',KF,': ',CHAF(KCREP,1)(1:16)
45200C...Set particle parameters (mass set when reading BLOCK MASS above)
45201 PMAS(KC,2)=WIDTH
45202 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
45203 WRITE(MSTU(11),*)
45204 & '* Note: the Pythia gg->h/H/A cross section'//
45205 & ' is proportional to the h/H/A->gg width'
45206 ENDIF
45207 PMAS(KC,3)=0D0
45208 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
45209 MWID(KC)=2
45210 MDCY(KC,1)=1
45211 MDCY(KC,2)=NDC
45212 MDCY(KC,3)=0
45213C...Add to list of DECAY blocks currently read
45214 NDECAY=NDECAY+1
45215 KFDEC(NDECAY)=KF
45216C...Return ok
45217 IRETRN=0
45218 ENDIF
45219C... Count up number of decay modes for this particle
45220 MDCY(KC,3)=MDCY(KC,3)+1
45221C... Read in decay daughters.
45222 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
45223C... Flip sign if reading antiparticle decays (if antipartner exists)
45224 DO 340 IDA=1,NDA
45225 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
45226 & IDC(IDA)=MPSIGN*IDC(IDA)
45227 340 CONTINUE
45228C...Switch on decay channel, with products ordered in decreasing ABS(KF)
45229 MDME(NDC,1)=1
45230 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
45231 BRSUM=BRSUM+ABS(BRAT(NDC))
45232 BRAT(NDC)=ABS(BRAT(NDC))
45233 350 IFLIP=0
45234 DO 360 IDA=1,NDA-1
45235 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
45236 ITMP=IDC(IDA)
45237 IDC(IDA)=IDC(IDA+1)
45238 IDC(IDA+1)=ITMP
45239 IFLIP=IFLIP+1
45240 ENDIF
45241 360 CONTINUE
45242 IF (IFLIP.GT.0) GOTO 350
45243C...Treat as ordinary decay, no fancy stuff.
45244 MDME(NDC,2)=0
45245 DO 370 IDA=1,5
45246 IF (IDA.LE.NDA) THEN
45247 KFDP(NDC,IDA)=IDC(IDA)
45248 ELSE
45249 KFDP(NDC,IDA)=0
45250 ENDIF
45251 370 CONTINUE
45252C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
45253C & (KFDP(NDC,J),J=1,NDA)
45254 ELSE
45255 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line'//
45256 & CHNLIN)
45257 MERR=11
45258 NDC=NDC-1
45259 ENDIF
45260 ELSEIF(CHINL(1:1).EQ.'+') THEN
45261 MERR=11
45262 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
45263 MERR=16
45264 ELSE
45265 MERR=16
45266 ENDIF
45267 ENDIF
45268C... Error check.
45269 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
45270 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
45271 & //CHINL(1:40)
45272 MERR=0
45273 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
45274 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
45275 & CHBLCK(1:MIN(INL,40))//'... on line'//CHNLIN
45276 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
45277 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
45278 & //CHBLCK(1:INL)//'... on line'//CHNLIN
45279 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
45280 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
45281 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
45282 & //'... on line'//CHNLIN
45283 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
45284 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
45285 & /CHBLCK(1:INL)//'... on line'//CHNLIN
45286 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
45287 WRITE (CHTMP,*) KF
45288 WRITE(MSTU(11),*)
45289 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
45290 & CHTMP(1:9)//' on line'//CHNLIN
45291 ENDIF
45292C...Iterate read loop
45293 GOTO 170
45294C...Error catching
45295 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
45296 & ', ignoring subsequent lines.'
45297 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
45298 CHBLCK=' '
45299 GOTO 170
45300C...End of read loop
45301 400 CONTINUE
45302C...Set flag that KC codes have been rearranged.
45303 MSTU(20)=0
45304 VERBOS=0
45305
45306C...Perform possible tests that new information is consistent.
45307 IF (MUPDA.EQ.1) THEN
45308 MSTU23=MSTU(23)
45309 MSTU27=MSTU(27)
45310C...Check Z and top masses
45311 IF (ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0) THEN
45312 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45313 CALL PYERRM(19,'(PYSLHA:) note Z boson mass, M ='//CHTMP)
45314 ENDIF
45315 IF (ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0) THEN
45316 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45317 CALL PYERRM(19,'(PYSLHA:) note top quark mass, M ='
45318 & //CHTMP//'GeV')
45319 ENDIF
45320C...Check masses
45321 DO 410 ISUSY=1,37
45322 KF=KFSUSY(ISUSY)
45323C...Don't complain about right-handed neutrinos
45324 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
45325 & +16) GOTO 410
45326C...Only check gravitino in GMSB scenarios
45327 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
45328 KC=PYCOMP(KF)
45329 IF (PMAS(KC,1).EQ.0D0) THEN
45330 WRITE(CHTMP,*) KF
45331 CALL PYERRM(9
45332 & ,'(PYSLHA:) No mass information found for KF ='
45333 & //CHTMP)
45334 ENDIF
45335 410 CONTINUE
45336C...Check mixing matrices (MSSM only)
45337 IF (IMSS(13).EQ.0) THEN
45338 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
45339 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
45340 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
45341 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
45342 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
45343 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
45344 IF (MSPC(5).NE.4) CALL PYERRM(9
45345 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
45346 IF (MSPC(6).NE.4) CALL PYERRM(9
45347 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
45348 IF (MSPC(7).NE.4) CALL PYERRM(9
45349 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
45350 IF (MSPC(8).LT.1) CALL PYERRM(9
45351 & ,'(PYSLHA:) Too few elements in HMIX')
45352 IF (MSPC(10).EQ.0) CALL PYERRM(9
45353 & ,'(PYSLHA:) Missing A_b trilinear coupling')
45354 IF (MSPC(11).EQ.0) CALL PYERRM(9
45355 & ,'(PYSLHA:) Missing A_t trilinear coupling')
45356 IF (MSPC(12).EQ.0) CALL PYERRM(9
45357 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
45358 IF (MSPC(17).LT.1) CALL PYERRM(9
45359 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
45360 ENDIF
45361C...Check wavefunction normalizations.
45362C...Sfermions
45363 DO 420 ISPC=5,7
45364 IF (MSPC(ISPC).EQ.4) THEN
45365 KFSM=ISPC
45366 IF (ISPC.EQ.7) KFSM=15
45367 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
45368 & *SFMIX(KFSM,3))
45369 IF (ABS(1D0-CHECK).GT.1D-3) THEN
45370 KCSM=PYCOMP(KFSM)
45371 CALL PYERRM(17
45372 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
45373 & //CHAF(KCSM,1))
45374 ENDIF
45375 ENDIF
45376 420 CONTINUE
45377C...Neutralinos + charginos
45378 DO 440 J=1,4
45379 CN1=0D0
45380 CN2=0D0
45381 CU1=0D0
45382 CU2=0D0
45383 CV1=0D0
45384 CV2=0D0
45385 DO 430 L=1,4
45386 CN1=CN1+ZMIX(J,L)**2
45387 CN2=CN2+ZMIX(L,J)**2
45388 IF (J.LE.2.AND.L.LE.2) THEN
45389 CU1=CU1+UMIX(J,L)**2
45390 CU2=CU2+UMIX(L,J)**2
45391 CV1=CV1+VMIX(J,L)**2
45392 CV2=CV2+VMIX(L,J)**2
45393 ENDIF
45394 430 CONTINUE
45395C...NMIX normalization
45396 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
45397 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
45398 CALL PYERRM(19,
45399 & '(PYSLHA:) NMIX: Inconsistent normalization.')
45400 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
45401 ENDIF
45402C...UMIX, VMIX normalizations
45403 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
45404 IF (J.LE.2) THEN
45405 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
45406 CALL PYERRM(19
45407 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
45408 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
45409 & CU2
45410 ENDIF
45411 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
45412 CALL PYERRM(19,
45413 & '(PYSLHA:) VMIX: Inconsistent normalization.')
45414 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
45415 & CV2
45416 ENDIF
45417 ENDIF
45418 ENDIF
45419 440 CONTINUE
45420 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
45421 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
45422 & '* PYSLHA: No spectrum inconsistencies were found.'
45423 ELSE
45424 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
45425 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
45426 & ,' Warning: one or more (serious)'//
45427 & ' inconsistencies were found in the spectrum !'
45428 & ,' Read the error messages above and check your'//
45429 & ' input file.'
45430 ENDIF
45431C...Increase precision in Higgs sector using FeynHiggs
45432 IF (IMSS(4).EQ.3) THEN
45433C...FeynHiggs needs MSOFT.
45434 IERR=0
45435 IF (MSPC(18).EQ.0) THEN
45436 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
45437 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
45438 & ' Cannot call FeynHiggs.'
45439 IERR=-1
45440 ELSE
45441 WRITE(MSTU(11),'(1x,/1x,A/)')
45442 & '* (PYSLHA:) Now calling FeynHiggs.'
45443 CALL PYFEYN(IERR)
45444 IF (IERR.NE.0) IMSS(4)=2
45445 ENDIF
45446 ENDIF
45447 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
45448 IBEG=1
45449 IF (KFORIG.NE.0) IBEG=NDECAY
45450 DO 490 IDECAY=IBEG,NDECAY
45451 KF = KFDEC(IDECAY)
45452 KC = PYCOMP(KF)
45453 WRITE(CHKF,8300) KF
45454 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
45455 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
45456 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
45457 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
45458 $ //CHKF)
45459 BRSUM=0D0
45460 BROPN=0D0
45461 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45462 IF(MDME(IDA,2).GT.80) GOTO 460
45463 KQ=KCHG(KC,1)
45464 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
45465 MERR=0
45466 DO 450 J=1,5
45467 KP=KFDP(IDA,J)
45468 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
45469 IF(KP.EQ.81) KQ=0
45470 ELSEIF(PYCOMP(KP).EQ.0) THEN
45471 MERR=3
45472 ELSE
45473 KQ=KQ-PYCHGE(KP)
45474 KPC=PYCOMP(KP)
45475 PMS=PMS-PMAS(KPC,1)
45476 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
45477 & PMAS(KPC,3))
45478 ENDIF
45479 450 CONTINUE
45480 IF(KQ.NE.0) MERR=MAX(2,MERR)
45481 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
45482 & MERR=MAX(1,MERR)
45483 IF(MERR.EQ.3) CALL PYERRM(17,
45484 & '(PYSLHA:) Unknown particle code in decay of KF ='
45485 $ //CHKF)
45486 IF(MERR.EQ.2) CALL PYERRM(17,
45487 & '(PYSLHA:) Charge not conserved in decay of KF ='
45488 $ //CHKF)
45489 IF(MERR.EQ.1) CALL PYERRM(7,
45490 & '(PYSLHA:) Kinematically unallowed decay of KF ='
45491 $ //CHKF)
45492 BRSUM=BRSUM+BRAT(IDA)
45493 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
45494 460 CONTINUE
45495C...Check branching ratio sum.
45496 IF (BROPN.LE.0D0) THEN
45497C...If zero, set stable.
45498 WRITE(CHTMP,8500) BROPN
45499 CALL PYERRM(7
45500 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
45501 & CHTMP(9:16)//'. Changed to stable.')
45502 PMAS(KC,2)=1D-6
45503 MWID(KC)=0
45504C...If BR's > 1, rescale.
45505 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
45506 WRITE(CHTMP,8500) BRSUM
45507 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
45508 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
45509 & ' ; sum was'//CHTMP(9:16)//'.')
45510 FAC=1D0/BRSUM
45511 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45512 IF(MDME(IDA,2).GT.80) GOTO 470
45513 BRAT(IDA)=FAC*BRAT(IDA)
45514 470 CONTINUE
45515 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
45516C...If BR's < 1, insert dummy mode for proper cross section rescaling.
45517 WRITE(CHTMP,8500) BRSUM
45518 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
45519 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
45520 & CHTMP(9:16)//'. Dummy mode will be inserted.')
45521C...Move table and insert dummy mode
45522 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45523 NDC=NDC+1
45524 BRAT(NDC)=BRAT(IDA)
45525 KFDP(NDC,1)=KFDP(IDA,1)
45526 KFDP(NDC,2)=KFDP(IDA,2)
45527 KFDP(NDC,3)=KFDP(IDA,3)
45528 KFDP(NDC,4)=KFDP(IDA,4)
45529 KFDP(NDC,5)=KFDP(IDA,5)
45530 MDME(NDC,1)=MDME(IDA,1)
45531 480 CONTINUE
45532 NDC=NDC+1
45533 BRAT(NDC)=1D0-BRSUM
45534 KFDP(NDC,1)=0
45535 KFDP(NDC,2)=0
45536 KFDP(NDC,3)=0
45537 KFDP(NDC,4)=0
45538 KFDP(NDC,5)=0
45539 MDME(NDC,1)=0
45540 BRSUM=1D0
45541C...Update MDCY
45542 MDCY(KC,3)=MDCY(KC,3)+1
45543 MDCY(KC,2)=NDC-MDCY(KC,3)+1
45544 ENDIF
45545 490 CONTINUE
45546 ENDIF
45547
45548
45549C...WRITE SPECTRUM ON SLHA FILE
45550 ELSEIF(MUPDA.EQ.3) THEN
45551C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
45552 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
45553 MODSEL(1)=1
45554 PARMIN(1)=RMSS(8)
45555 PARMIN(2)=RMSS(1)
45556 PARMIN(3)=RMSS(5)
45557 PARMIN(4)=SIGN(1D0,RMSS(4))
45558 PARMIN(5)=RMSS(36)
45559 ENDIF
45560C...Write spectrum
45561 WRITE(LFN,7000) 'SLHA MSSM spectrum'
45562 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
45563 & // ' P. Skands.'
45564 WRITE(LFN,7010) 'MODSEL', 'Model selection'
45565 WRITE(LFN,7110) 1, MODSEL(1)
45566 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
45567 IF (MODSEL(1).EQ.1) THEN
45568 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
45569 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
45570 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45571 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45572 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
45573 ELSEIF(MODSEL(2).EQ.2) THEN
45574 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
45575 WRITE(LFN,7210) 2, PARMIN(2), 'M'
45576 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
45577 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
45578 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
45579 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
45580 ENDIF
45581 WRITE(LFN,7000) ' '
45582 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
45583 DO 500 I=1,36
45584 KF=KFSUSY(I)
45585 KC=PYCOMP(KF)
45586 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
45587 KFSM=KF-KSUSY1
45588 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
45589 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
45590 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
45591 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
45592 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
45593 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
45594 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
45595 ELSE
45596 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
45597 ENDIF
45598 500 CONTINUE
45599C...SUSY scale
45600 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
45601 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
45602 WRITE(LFN,7210) 1, RMSS(4),'mu'
45603 WRITE(LFN,7010) 'ALPHA',' '
45604 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
45605 WRITE(LFN,7020) 'AU',RMSUSY
45606 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
45607 WRITE(LFN,7020) 'AD',RMSUSY
45608 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
45609 WRITE(LFN,7020) 'AE',RMSUSY
45610 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
45611 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
45612 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
45613 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
45614 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
45615 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
45616 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
45617 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
45618 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
45619 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
45620 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
45621 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
45622 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
45623 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
45624 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
45625 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
45626 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
45627 DO 520 I1=1,4
45628 DO 510 I2=1,4
45629 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
45630 510 CONTINUE
45631 520 CONTINUE
45632 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
45633 DO 540 I1=1,2
45634 DO 530 I2=1,2
45635 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
45636 530 CONTINUE
45637 540 CONTINUE
45638 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
45639 DO 560 I1=1,2
45640 DO 550 I2=1,2
45641 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
45642 550 CONTINUE
45643 560 CONTINUE
45644 WRITE(LFN,7010) 'SPINFO'
45645 IF (IMSS(1).EQ.2) THEN
45646 CPRO(1)='PYTHIA'
45647 CVER(1)='6.4'
45648 ELSEIF (IMSS(1).EQ.12) THEN
45649 ISAVER=VISAJE()
45650 CPRO(1)='ISASUSY'
45651 CVER(1)=ISAVER(1:12)
45652 ENDIF
45653 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
45654 WRITE(LFN,7310) 2, CVER(1), 'Version number'
45655 ENDIF
45656
45657C...Print user information about spectrum
45658 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
45659 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
45660 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
45661 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
45662 IF (MUPDA.EQ.1) THEN
45663 WRITE(MSTU(11),5020) LFN
45664 ELSE
45665 WRITE(MSTU(11),5010) LFN
45666 ENDIF
45667
45668 WRITE(MSTU(11),5400)
45669 WRITE(MSTU(11),5500) 'Pole masses'
45670 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
45671 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
45672 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
45673 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
45674 IF (IMSS(13).EQ.0) THEN
45675 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
45676 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
45677 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
45678 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
45679 & CHAF(37,1), ' ', ' ',' ',' ',
45680 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
45681 ELSEIF (IMSS(13).EQ.1) THEN
45682 KF1=KSUSY1+21
45683 KF2=KSUSY1+22
45684 KF3=KSUSY1+23
45685 KF4=KSUSY1+25
45686 KF5=KSUSY1+35
45687 KF6=KSUSY1+45
45688 KF7=KSUSY1+24
45689 KF8=KSUSY1+37
45690 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
45691 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
45692 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
45693 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
45694 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
45695 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
45696 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
45697 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
45698 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
45699 & RMFUN(37)
45700 ENDIF
45701 WRITE(MSTU(11),5400)
45702 WRITE(MSTU(11),5500) 'Mixing structure'
45703 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
45704 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
45705 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
45706 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
45707 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
45708 & ),(SFMIX(15,J),J=3,4)
45709 WRITE(MSTU(11),5400)
45710 WRITE(MSTU(11),5500) 'Couplings'
45711 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
45712 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
45713 WRITE(MSTU(11),5400)
45714 WRITE(MSTU(11),6500)
45715
45716 ENDIF
45717
45718C...Only rewind when reading
45719 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
45720
45721 9999 RETURN
45722
45723C...Serious error catching
45724 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
45725 write(*,*) CHINL(1:80)
45726 CALL PYSTOP(106)
45727 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
45728 WRITE(*,*) CHINL(1:72)
45729 CALL PYSTOP(106)
45730 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
45731 WRITE(*,*) CHINL(1:80)
45732 CALL PYSTOP(106)
45733 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
45734 WRITE(*,*) CHINL(1:80)
45735 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
45736 CALL PYSTOP(106)
45737 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
45738 WRITE(*,*) CHINL(1:80)
45739 CALL PYSTOP(106)
45740
45741 8300 FORMAT(I9)
45742 8500 FORMAT(F16.5)
45743
45744C...Formats for user information printout.
45745 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.10: SUSY/BSM SPECTRUM '
45746 & ,'INTERFACE',1x,17('*')/1x,'*',2x
45747 & ,'PYSLHA: Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
45748 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
45749 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
45750 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
45751 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
45752 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
45753 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
45754 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
45755 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
45756 & ,'----------------')
45757 5400 FORMAT(1x,'*',1x,A)
45758 5500 FORMAT(1x,'*',1x,A,':')
45759 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
45760 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
45761 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
45762 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
45763 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45764 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
45765 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
45766 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
45767 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
45768 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
45769 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
45770 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
45771 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
45772 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
45773 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
45774 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
45775 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
45776 & ,1x,F6.3,1x),'|')
45777 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
45778 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
45779 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
45780 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
45781 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
45782 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
45783 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
45784 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
45785 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
45786 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
45787 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
45788 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
45789 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
45790 & ,'A_tau = ',F8.2)
45791 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
45792 & ,' mu = ',F8.2)
45793 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
45794
45795C...Format to use for comments
45796 7000 FORMAT('# ',A)
45797C...Format to use for block statements
45798 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
45799 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
45800C...Indexed Int
45801 7110 FORMAT(1x,I4,1x,I4,3x,'#')
45802C...Non-Indexed Double
45803 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
45804C...Indexed Double
45805 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
45806C...Long Indexed Double (PDG + double)
45807 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
45808C...Indexed Char(12)
45809 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
45810C...Single matrix
45811 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
45812C...Double Matrix
45813 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
45814C...Write Decay Table
45815 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
45816 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
45817 & 3x,'#',1x,A)
45818
45819 END
45820
45821
45822C*********************************************************************
45823
45824C...PYAPPS
45825C...Uses approximate analytical formulae to determine the full set of
45826C...MSSM parameters from SUGRA input.
45827C...See M. Drees and S.P. Martin, hep-ph/9504124
45828
45829 SUBROUTINE PYAPPS
45830
45831C...Double precision and integer declarations.
45832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45833 IMPLICIT INTEGER(I-N)
45834 INTEGER PYK,PYCHGE,PYCOMP
45835C...Parameter statement to help give large particle numbers.
45836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45837 &KEXCIT=4000000,KDIMEN=5000000)
45838C...Commonblocks.
45839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45841 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45842 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
45843
45844 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
45845 &' not intended for serious physics studies'
45846 IMSS(5)=0
45847 IMSS(8)=0
45848 XMT=PMAS(6,1)
45849 XMZ2=PMAS(23,1)**2
45850 XMW2=PMAS(24,1)**2
45851 TANB=RMSS(5)
45852 BETA=ATAN(TANB)
45853 XW=PARU(102)
45854 XMG=RMSS(1)
45855 XMG2=XMG*XMG
45856 XM0=RMSS(8)
45857 XM02=XM0*XM0
45858C...Temporary sign change for AT. Others unchanged.
45859 AT=-RMSS(16)
45860 RMSS(15)=RMSS(16)
45861 RMSS(17)=RMSS(16)
45862 SINB=TANB/SQRT(TANB**2+1D0)
45863 COSB=SINB/TANB
45864
45865 DTERM=XMZ2*COS(2D0*BETA)
45866 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
45867 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
45868 RMSS(6)=XMEL
45869 RMSS(7)=XMER
45870 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
45871 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
45872 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
45873 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
45874 DO 100 I=1,5,2
45875 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
45876 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
45877 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
45878 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
45879 100 CONTINUE
45880 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
45881 IF(XARG.LT.0D0) THEN
45882 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45883 & ' FROM THE SUM RULE. '
45884 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45885 RETURN
45886 ELSE
45887 XARG=SQRT(XARG)
45888 ENDIF
45889 DO 110 I=11,15,2
45890 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
45891 PMAS(PYCOMP(KSUSY2+I),1)=XMER
45892 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45893 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45894 110 CONTINUE
45895 RMT=PYMRUN(6,PMAS(6,1)**2)
45896 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
45897 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
45898 RMB=PYMRUN(5,PMAS(6,1)**2)
45899 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
45900 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
45901 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
45902 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
45903 &SINB)**2)
45904 RMSS(16)=-ATP
45905 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
45906 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
45907 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
45908 XMU=SIGN(SQRT(XMU2),RMSS(4))
45909 RMSS(4)=XMU
45910 IF(XMA2.GT.0D0) THEN
45911 RMSS(19)=SQRT(XMA2)
45912 ELSE
45913 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
45914 CALL PYSTOP(102)
45915 ENDIF
45916 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
45917 IF(ARG.GT.0D0) THEN
45918 RMSS(14)=SQRT(ARG)
45919 ELSE
45920 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
45921 CALL PYSTOP(102)
45922 ENDIF
45923 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
45924 IF(ARG.GT.0D0) THEN
45925 RMSS(13)=SQRT(ARG)
45926 ELSE
45927 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
45928 CALL PYSTOP(102)
45929 ENDIF
45930 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
45931 IF(ARG.GT.0D0) THEN
45932 RMSS(10)=SQRT(ARG)
45933 ELSE
45934 RMSS(10)=-SQRT(-ARG)
45935 ENDIF
45936 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
45937 IF(ARG.GT.0D0) THEN
45938 RMSS(12)=SQRT(ARG)
45939 ELSE
45940 RMSS(12)=-SQRT(-ARG)
45941 ENDIF
45942 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
45943 IF(ARG.GT.0D0) THEN
45944 RMSS(11)=SQRT(ARG)
45945 ELSE
45946 RMSS(11)=-SQRT(-ARG)
45947 ENDIF
45948
45949 RETURN
45950 END
45951
45952C*********************************************************************
45953
45954C...PYSUGI
45955C...Interface to ISASUSY version 7.71.
45956C...Warning: this interface should not be used with earlier versions
45957C...of ISASUSY, since common block incompatibilities may then arise.
45958C...Calls SUGRA (in ISAJET) to perform RGE evolution.
45959C...Then converts to Gunion-Haber conventions.
45960
45961 SUBROUTINE PYSUGI
45962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45963
45964 INTEGER PYK,PYCHGE,PYCOMP
45965 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45966 &KEXCIT=4000000,KDIMEN=5000000)
45967
45968C...Date of Change
45969 CHARACTER DOC*11
45970 PARAMETER (DOC='01 May 2006')
45971
45972C...ISASUGRA Input:
45973 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
45974C...XISAIN contains the MSSMi inputs in natural order.
45975 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
45976 $XAMIN(7)
45977 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
45978 SAVE /SUGXIN/
45979C...ISASUGRA Output
45980 CHARACTER*40 ISAVER,VISAJE
45981 REAL SUPER
45982 COMMON /SSPAR/ SUPER(72)
45983 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
45984 $FBGUT,FTAGUT,FNGUT
45985 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
45986 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45987 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45988 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
45989 $VUMT,VDMT,ASMTP,ASMSS,M3Q
45990 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
45991 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
45992 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
45993 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
45994 INTEGER IALLOW
45995 SAVE /SUGMG/,/SSPAR/
45996C SUPER: Filled by ISASUGRA.
45997C SUPER(1) = mass of ~g
45998C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
45999C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46000C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46001C ,~tau_2
46002C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46003C SUPER(29) = Higgsino mass = - mu
46004C SUPER(30) = ratio v2/v1 of vev's
46005C SUPER(31:34) = Signed neutralino masses
46006C SUPER(35:50) = Neutralino mixing matrix
46007C SUPER(51:52) = Signed chargino masses
46008C SUPER(53:54) = Chargino left, right mixing angles
46009C SUPER(55:58) = mass of h0, H0, A0, H+
46010C SUPER(59) = Higgs mixing angle alpha
46011C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46012C SUPER(66) = Gravitino mass
46013C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46014C SUPER(70) = b-Yukawa at mA scale (not used)
46015C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46016C GSS: Filled by ISASUGRA
46017C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
46018C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
46019C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
46020C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
46021C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
46022C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
46023C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
46024C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
46025C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
46026C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
46027C GSS(31) = log(vuq)
46028C MSS: Filled by ISASUGRA
46029C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
46030C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
46031C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
46032C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
46033C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
46034C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
46035C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
46036C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
46037C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
46038C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
46039C MSS(31) = ha0 MSS(32) = h+
46040C Unification, filled by ISASUGRA if applicable.
46041C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
46042
46043C...SPYTHIA Input/Output
46044 INTEGER IMSS
46045 DOUBLE PRECISION RMSS
46046 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46047 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46048 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46049C...SLHA Input/Output
46050 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46051 & AU(3,3),AD(3,3),AE(3,3)
46052C...PYTHIA common blocks
46053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46054 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46056
46057 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
46058CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
46059 INTEGER IMODEL
46060 REAL M0,MHF,A0,MT
46061 CHARACTER*20 CHMOD(5)
46062 CHARACTER*32 FNAME
46063
46064 COMMON /SUGNU/ XNUSUG(18)
46065 REAL XNUSUG
46066 SAVE /SUGNU/
46067
46068 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
46069 & 'truly unified SUGRA', 'non-minimal GMSB'/
46070
46071C...Start by checking for incompatibilities/inconsistencies:
46072 DO 100 ICHK=2,9
46073 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
46074 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
46075 & ,' option not used by PYSUGI'
46076 ENDIF
46077 100 CONTINUE
46078C...ISAJET works with REAL numbers.
46079 MZERO=REAL(RMSS(8))
46080 MHLF=REAL(RMSS(1))
46081 AZERO=REAL(RMSS(16))
46082 TANB=REAL(RMSS(5))
46083 SGNMU=REAL(RMSS(4))
46084 MTOP=REAL(PMAS(6,1))
46085 IMODEL=0
46086 IF (IMSS(1).EQ.12) THEN
46087 IMODEL=1
46088 GOTO 130
46089 ELSEIF(IMSS(1).EQ.13) THEN
46090C...Read from isajet par file in IMSS(20)
46091 LFN=IMSS(20)
46092C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46093 IF (LFN.EQ.0) THEN
46094 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
46095 GOTO 9999
46096 ENDIF
46097 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
46098CMrenna change to allow any susy model
46099 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
46100 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
46101 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
46102 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
46103 & ' gauge couplings:'
46104 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
46105 READ(LFN,*) IMODEL
46106 IF (IMODEL.EQ.4) THEN
46107 IAL3UN=1
46108 IMODEL=1
46109 ENDIF
46110 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
46111 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
46112 & //' sgn(mu), M_t:'
46113 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
46114 IF (IMODEL.EQ.3) THEN
46115 IMODEL=1
46116 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
46117 & //' 0 to continue:'
46118 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
46119 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
46120 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
46121 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
46122 & //' generation masses'
46123 WRITE(MSTU(11),*)
46124 & ' NUSUG5 = GUT scale 3rd generation masses'
46125 READ(LFN,*) INUSUG
46126 IF (INUSUG.EQ.0) THEN
46127 GOTO 120
46128 ELSEIF (INUSUG.EQ.1) THEN
46129 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
46130 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
46131 IF (XNUSUG(3).LE.0.) THEN
46132 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
46133 CALL PYSTOP(109)
46134 END IF
46135 ELSEIF (INUSUG.EQ.2) THEN
46136 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
46137 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
46138 ELSEIF (INUSUG.EQ.3) THEN
46139 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
46140 READ(LFN,*) XNUSUG(7),XNUSUG(8)
46141 ELSEIF (INUSUG.EQ.4) THEN
46142 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
46143 & //' M(ur), M(el), M(er):'
46144 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
46145 & XNUSUG(10),XNUSUG(9)
46146 ELSEIF (INUSUG.EQ.5) THEN
46147 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
46148 & //' M(Ll), M(Lr):'
46149 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
46150 & XNUSUG(15),XNUSUG(14)
46151 ENDIF
46152 GOTO 110
46153 ENDIF
46154 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
46155 IMSS(11)=1
46156 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
46157 & ,' sgn(mu), M_t, C_gv:'
46158 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
46159 XGMIN(7)=XCMGV
46160 XGMIN(8)=1.
46161C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
46162 AMPL=2.4D18
46163 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
46164 IF (IMODEL.EQ.5) THEN
46165 IMODEL=2
46166 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
46167 & ,' masses at M_mes'
46168 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
46169 & ,' shifts at M_mes'
46170 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
46171 & ' Y at M_mes'
46172 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
46173 & ,'SU(2),SU(3)'
46174 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
46175 & ,' n5_2, n5_3'
46176 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
46177 $ XGMIN(13),XGMIN(14)
46178 ENDIF
46179 ELSE
46180 WRITE(MSTU(11),*) 'Invalid model choice.'
46181 GOTO 9999
46182 ENDIF
46183 ENDIF
46184
46185 120 MZERO=M0
46186 MHLF=MHF
46187 AZERO=A0
46188C TANB=REAL(RMSS(5))
46189C SGNMU=REAL(RMSS(4))
46190 MTOP=MT
46191
46192C...Initialize MSSM parameter array
46193 130 DO 140 IPAR=1,72
46194 SUPER(IPAR)=0.0
46195 140 CONTINUE
46196C...Call ISASUGRA
46197 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
46198C...Check whether ISASUSY thought the model was OK.
46199 IF (NOGOOD.NE.0) THEN
46200 IF (NOGOOD.EQ.1) CALL PYERRM(26
46201 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
46202 IF (NOGOOD.EQ.2) CALL PYERRM(26
46203 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
46204 IF (NOGOOD.EQ.3) CALL PYERRM(26
46205 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
46206 IF (NOGOOD.EQ.4) CALL PYERRM(26
46207 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
46208 IF (NOGOOD.EQ.7) CALL PYERRM(26
46209 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
46210 IF (NOGOOD.EQ.8) CALL PYERRM(26
46211 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
46212C...Give warning, but don't stop, if LSP not ~chi_10.
46213 IF (NOGOOD.EQ.5) CALL PYERRM(16
46214 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
46215 ENDIF
46216C...Warn about possible GUT scale tachyons.
46217 IF (ITACHY.NE.0) CALL PYERRM(16,
46218 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
46219C...Finalize spectrum (last iteration)
46220C...(Thanks to A. Raklev for pointing this out.)
46221C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
46222 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
46223 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
46224 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
46225 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
46226 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
46227 $ MTOP,IALLOW,1)
46228
46229C...M1, M2, M3.
46230 RMSS(1)=dble(GSS(7))
46231 RMSS(2)=dble(GSS(8))
46232 RMSS(3)=dble(GSS(9))
46233 RMSOFT(1)=dble(GSS(7))
46234 RMSOFT(2)=dble(GSS(8))
46235 RMSOFT(3)=dble(GSS(9))
46236C...Mu = - Higgsino mass.
46237 RMSS(4)=-SUPER(29)
46238 RMSS(5)=TANB
46239C...Slepton and squark masses. 2 first generations.
46240 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
46241 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
46242 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
46243 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
46244C...Third generation.
46245 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
46246 RMSS(11)=SUPER(11)
46247 RMSS(12)=SUPER(15)
46248 RMSS(13)=SUPER(22)
46249 RMSS(14)=SUPER(23)
46250C...SLHA: store exact soft spectrum in RMSOFT
46251 RMSOFT(31)=SUPER(18)
46252 RMSOFT(32)=SUPER(20)
46253 RMSOFT(33)=SUPER(22)
46254 RMSOFT(34)=SUPER(19)
46255 RMSOFT(35)=SUPER(21)
46256 RMSOFT(36)=SUPER(23)
46257 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
46258 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
46259 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
46260 RMSOFT(44)=SUPER(3)
46261 RMSOFT(45)=SUPER(9)
46262 RMSOFT(46)=SUPER(15)
46263 RMSOFT(47)=SUPER(5)
46264 RMSOFT(48)=SUPER(7)
46265 RMSOFT(49)=SUPER(11)
46266
46267C...~b, ~t, and ~tau trilinear couplings and mixing angles.
46268 RMSS(15)=SUPER(62)
46269 RMSS(16)=SUPER(60)
46270 RMSS(17)=SUPER(64)
46271 RMSS(26)=SUPER(63)
46272 RMSS(27)=SUPER(61)
46273 RMSS(28)=SUPER(65)
46274C...SLHA trilinears
46275 DO 142 K1=1,3
46276 DO 141 K2=1,3
46277 AE(K1,K2)=0D0
46278 AU(K1,K2)=0D0
46279 AD(K1,K2)=0D0
46280 141 CONTINUE
46281 142 CONTINUE
46282 AE(3,3)=SUPER(64)
46283 AU(3,3)=SUPER(60)
46284 AD(3,3)=SUPER(62)
46285C...Higgs mixing angle alpha (Gunion-Haber convention).
46286 RMSS(18)=-SUPER(59)
46287C...A0 mass.
46288 RMSS(19)=SUPER(57)
46289C...GUT scale coupling
46290 RMSS(20)=AGUTSS
46291C...Gravitino mass (for future compatibility)
46292 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
46293
46294C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
46295C...Higgs sector.
46296 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
46297 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
46298 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
46299 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
46300C...Gluino.
46301 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
46302C...Squarks and Sleptons.
46303 DO 150 ILR=1,2
46304 ILRM=ILR-1
46305 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
46306 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
46307 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
46308 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
46309 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
46310 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
46311 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
46312 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
46313 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
46314 150 CONTINUE
46315 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
46316 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
46317 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
46318C...Neutralinos.
46319 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
46320 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
46321 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
46322 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
46323C...Signed masses (extra minus from going to G-H convention).
46324 SMZ(1)=-SUPER(31)
46325 SMZ(2)=-SUPER(32)
46326 SMZ(3)=-SUPER(33)
46327 SMZ(4)=-SUPER(34)
46328C...Charginos
46329 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
46330 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
46331C...Signed masses (extra minus from going to G-H convention).
46332 SMW(1)=-SUPER(51)
46333 SMW(2)=-SUPER(52)
46334
46335C... Neutralino Mixing.
46336 DO 160 IN=1,4
46337 ZMIX(IN,1)= SUPER(38+4*(IN-1))
46338 ZMIX(IN,2)= SUPER(37+4*(IN-1))
46339 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
46340 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
46341 160 CONTINUE
46342C...Chargino Mixing (PYTHIA same angle as HERWIG).
46343 THX=1D0
46344 THY=1D0
46345 IF (SUPER(53).GT.0) THX=-1D0
46346 IF (SUPER(54).GT.0) THY=-1D0
46347 UMIX(1,1) = -SIN(SUPER(53))
46348 UMIX(1,2) = -COS(SUPER(53))
46349 UMIX(2,1) = -THX*COS(SUPER(53))
46350 UMIX(2,2) = THX*SIN(SUPER(53))
46351 VMIX(1,1) = -SIN(SUPER(54))
46352 VMIX(1,2) = -COS(SUPER(54))
46353 VMIX(2,1) = -THY*COS(SUPER(54))
46354 VMIX(2,2) = THY*SIN(SUPER(54))
46355C...Sfermion mixing (PYTHIA same angle as ISAJET)
46356 SFMIX(5,1)=COS(SUPER(63))
46357 SFMIX(5,2)=SIN(SUPER(63))
46358 SFMIX(5,3)=-SIN(SUPER(63))
46359 SFMIX(5,4)=COS(SUPER(63))
46360 SFMIX(6,1)=COS(SUPER(61))
46361 SFMIX(6,2)=SIN(SUPER(61))
46362 SFMIX(6,3)=-SIN(SUPER(61))
46363 SFMIX(6,4)=COS(SUPER(61))
46364 SFMIX(15,1)=COS(SUPER(65))
46365 SFMIX(15,2)=SIN(SUPER(65))
46366 SFMIX(15,3)=-SIN(SUPER(65))
46367 SFMIX(15,4)=COS(SUPER(65))
46368
46369 IF (MSTP(122).NE.0) THEN
46370C...Print a few lines to make the user know what's happening
46371 ISAVER=VISAJE()
46372 WRITE(MSTU(11),5000) DOC, ISAVER
46373 WRITE(MSTU(11),5100)
46374 IF (IMODEL.EQ.1) THEN
46375 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
46376 & MTOP
46377 WRITE(MSTU(11),5300)
46378 ENDIF
46379 WRITE(MSTU(11),5500) 'Pole masses'
46380 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
46381 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
46382 & ,(SUPER(IP),IP=19,25,2)
46383 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
46384 & ,IP=1,2)
46385 WRITE(MSTU(11),5400)
46386 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
46387 WRITE(MSTU(11),5400)
46388 WRITE(MSTU(11),5500) 'EW scale mixing structure'
46389 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46390 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46391 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46392 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46393 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46394 & ),(SFMIX(15,J),J=3,4)
46395 WRITE(MSTU(11),5400)
46396 WRITE(MSTU(11),6450) RMSS(18)
46397 WRITE(MSTU(11),5400)
46398 WRITE(MSTU(11),5500) 'Couplings'
46399 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
46400 WRITE(MSTU(11),5400)
46401 ENDIF
46402
46403C...Call FeynHiggs to improve Higgs sector if requested
46404 IF (IMSS(4).EQ.3) THEN
46405 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
46406 & ' (PYSUGI:) Now calling FeynHiggs.'
46407 CALL PYFEYN(IERR)
46408 IF (IERR.EQ.0) THEN
46409 IMSS(4)=2
46410 IF (MSTP(122).NE.0) THEN
46411 WRITE(MSTU(11),5400)
46412 WRITE(MSTU(11),5500)
46413 & 'Corrected Higgs masses and mixing'
46414 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
46415 & PMAS(37,1)
46416 WRITE(MSTU(11),6450) RMSS(18)
46417 WRITE(MSTU(11),5400)
46418 ENDIF
46419 ENDIF
46420 ENDIF
46421
46422 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
46423
46424C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
46425C...output by ISASUSY.
46426 IMSS(4)=MAX(2,IMSS(4))
46427
46428 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
46429 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
46430 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
46431 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
46432 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46433 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46434 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
46435 & ,'----------------')
46436 5400 FORMAT(1x,'*',1x,A)
46437 5500 FORMAT(1x,'*',1x,A,':')
46438 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46439 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46440 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
46441 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
46442 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
46443 & ,1x))
46444 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
46445 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
46446 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
46447 & .2,1x))
46448 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46449 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46450 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46451 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46452 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
46453 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
46454 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
46455 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46456 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46457 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46458 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46459 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46460 & ,1x,F6.3,1x),'|')
46461 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46462 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46463 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46464 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46465 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46466 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46467 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46468 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46469 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46470 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46471 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46472 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46473 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
46474 & ,4x,'Alpha_GUT = ',F8.2)
46475 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
46476 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
46477
46478 9999 RETURN
46479 END
46480
46481C*********************************************************************
46482
46483C...PYFEYN
46484C...Interface to FeynHiggs for MSSM Higgs sector.
46485C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
46486C...P. Skands
46487
46488 SUBROUTINE PYFEYN(IERR)
46489
46490C...Double precision and integer declarations.
46491 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46492 IMPLICIT INTEGER(I-N)
46493 INTEGER PYK,PYCHGE,PYCOMP
46494C...Commonblocks.
46495 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46496 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46497C...SUSY blocks
46498 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46499C...FeynHiggs variables
46500 DOUBLE PRECISION RMHIGG(4)
46501 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
46502 DOUBLE COMPLEX DMU,
46503 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46504 & DM1, DM2, DM3
46505C...SLHA Common Block
46506 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46507 & AU(3,3),AD(3,3),AE(3,3)
46508 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
46509
46510 IERR=0
46511 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
46512 IF (IERR.NE.0) THEN
46513 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
46514 & //'Will not use FeynHiggs for this run.')
46515 RETURN
46516 ENDIF
46517 Q=RMSOFT(0)
46518 DMB=PMAS(5,1)
46519 DMT=PMAS(6,1)
46520 DMZ=PMAS(23,1)
46521 DMW=PMAS(24,1)
46522 DMA=PMAS(36,1)
46523 DM1=RMSOFT(1)
46524 DM2=RMSOFT(2)
46525 DM3=RMSOFT(3)
46526 DTANB=RMSS(5)
46527 DMU=RMSS(4)
46528 DM3SL=RMSOFT(33)
46529 DM3SE=RMSOFT(36)
46530 DM3SQ=RMSOFT(43)
46531 DM3SU=RMSOFT(46)
46532 DM3SD=RMSOFT(49)
46533 DM2SL=RMSOFT(32)
46534 DM2SE=RMSOFT(35)
46535 DM2SQ=RMSOFT(42)
46536 DM2SU=RMSOFT(45)
46537 DM2SD=RMSOFT(48)
46538 DM1SL=RMSOFT(31)
46539 DM1SE=RMSOFT(34)
46540 DM1SQ=RMSOFT(41)
46541 DM1SU=RMSOFT(44)
46542 DM1SD=RMSOFT(47)
46543 AE33=AE(3,3)
46544 AE22=AE(2,2)
46545 AE11=AE(1,1)
46546 AU33=AU(3,3)
46547 AU22=AU(2,2)
46548 AU11=AU(1,1)
46549 AD33=AD(3,3)
46550 AD22=AD(2,2)
46551 AD11=AD(1,1)
46552 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
46553 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
46554 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
46555 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
46556 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
46557 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
46558 IF (IERR.NE.0) THEN
46559 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
46560 & //' Will not use FeynHiggs for this run.')
46561 RETURN
46562 ENDIF
46563C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
46564 SAEFF=0D0
46565 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
46566 IF (IERR.NE.0) THEN
46567 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
46568 & 'GSCORR. Will not use FeynHiggs for this run.')
46569 RETURN
46570 ENDIF
46571 ALPHA = ASIN(DBLE(SAEFF))
46572 R=RMSS(18)/ALPHA
46573 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
46574 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46575 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
46576 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
46577 ENDIF
46578 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
46579 & 1.15D0*PMAS(25,1)) THEN
46580 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
46581 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
46582 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
46583 ENDIF
46584 RMSS(18)=ALPHA
46585 PMAS(25,1)=RMHIGG(1)
46586 PMAS(35,1)=RMHIGG(2)
46587 PMAS(36,1)=RMHIGG(3)
46588 PMAS(37,1)=RMHIGG(4)
46589
46590 RETURN
46591 END
46592
46593C*********************************************************************
46594
46595C...PYRNMQ
46596C...Determines the running mass of Squarks.
46597
46598 FUNCTION PYRNMQ(ID,DTERM)
46599
46600C...Double precision and integer declarations.
46601 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46602 IMPLICIT INTEGER(I-N)
46603 INTEGER PYK,PYCHGE,PYCOMP
46604C...Commonblock.
46605 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46606 SAVE /PYMSSM/
46607
46608C...Local variables.
46609 DOUBLE PRECISION PI,R
46610 DOUBLE PRECISION TOL
46611 DOUBLE PRECISION CI(3)
46612 EXTERNAL PYALPS
46613 DOUBLE PRECISION PYALPS
46614 DATA TOL/0.001D0/
46615 DATA PI,R/3.141592654D0,.61803399D0/
46616 DATA CI/0.47D0,0.07D0,0.02D0/
46617
46618 C=1D0-R
46619 CA=CI(ID)
46620 AG=(0.71D0)**2/4D0/PI
46621 AG=RMSS(20)
46622 XM0=RMSS(8)
46623 XMG=RMSS(1)
46624 XM02=XM0*XM0
46625 XMG2=XMG*XMG
46626
46627 AS=PYALPS(XM02+6D0*XMG2)
46628 CG=8D0/9D0*((AS/AG)**2-1D0)
46629 BX=XM02+(CA+CG)*XMG2+DTERM
46630 AX=MIN(50D0**2,0.5D0*BX)
46631 CX=MAX(2000D0**2,2D0*BX)
46632
46633 X0=AX
46634 X3=CX
46635 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
46636 X1=BX
46637 X2=BX+C*(CX-BX)
46638 ELSE
46639 X2=BX
46640 X1=BX-C*(BX-AX)
46641 ENDIF
46642 AS1=PYALPS(X1)
46643 CG=8D0/9D0*((AS1/AG)**2-1D0)
46644 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46645 AS2=PYALPS(X2)
46646 CG=8D0/9D0*((AS2/AG)**2-1D0)
46647 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46648 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
46649 IF(F2.LT.F1) THEN
46650 X0=X1
46651 X1=X2
46652 X2=R*X1+C*X3
46653 F1=F2
46654 AS2=PYALPS(X2)
46655 CG=8D0/9D0*((AS2/AG)**2-1D0)
46656 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
46657 ELSE
46658 X3=X2
46659 X2=X1
46660 X1=R*X2+C*X0
46661 F2=F1
46662 AS1=PYALPS(X1)
46663 CG=8D0/9D0*((AS1/AG)**2-1D0)
46664 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
46665 ENDIF
46666 GOTO 100
46667 ENDIF
46668 IF(F1.LT.F2) THEN
46669 PYRNMQ=X1
46670 XMIN=X1
46671 ELSE
46672 PYRNMQ=X2
46673 XMIN=X2
46674 ENDIF
46675
46676 RETURN
46677 END
46678
46679C*********************************************************************
46680
46681C...PYTHRG
46682C...Calculates the mass eigenstates of the third generation sfermions.
46683C...Created: 5-31-96
46684
46685 SUBROUTINE PYTHRG
46686
46687C...Double precision and integer declarations.
46688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46689 IMPLICIT INTEGER(I-N)
46690 INTEGER PYK,PYCHGE,PYCOMP
46691C...Parameter statement to help give large particle numbers.
46692 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46693 &KEXCIT=4000000,KDIMEN=5000000)
46694C...Commonblocks.
46695 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46696 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46697 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46698 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46699 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46700 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46701
46702C...Local variables.
46703 DOUBLE PRECISION BETA
46704 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
46705 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
46706 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
46707 DOUBLE PRECISION ATR,AMQR,AMQL
46708 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
46709 INTEGER IF,I,J,II,JJ,IT,L
46710 LOGICAL DTERM
46711 DATA SMALL/1D-3/
46712 DATA ID1/10,10,13/
46713 DATA ID2/5,6,15/
46714 DATA ID3/15,16,17/
46715 DATA ID4/11,12,14/
46716 DATA DTERM/.TRUE./
46717
46718 XMZ2=PMAS(23,1)**2
46719 XMW2=PMAS(24,1)**2
46720 TANB=RMSS(5)
46721 XMU=-RMSS(4)
46722 BETA=ATAN(TANB)
46723 COS2B=COS(2D0*BETA)
46724
46725C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
46726
46727 IOPT=IMSS(5)
46728 IF(IOPT.EQ.1) THEN
46729 CTT=DCOS(RMSS(27))
46730 CTT2=CTT**2
46731 STT=DSIN(RMSS(27))
46732 STT2=STT**2
46733 XM12=RMSS(10)**2
46734 XM22=RMSS(12)**2
46735 XMQL2=CTT2*XM12+STT2*XM22
46736 XMQR2=STT2*XM12+CTT2*XM22
46737 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
46738 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46739 RMSS(16)=ATOP
46740C......SUBTRACT OUT D-TERM AND FERMION MASS
46741 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
46742 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
46743 IF(XMQL2.GE.0D0) THEN
46744 RMSS(10)=SQRT(XMQL2)
46745 ELSE
46746 RMSS(10)=-SQRT(-XMQL2)
46747 ENDIF
46748 IF(XMQR2.GE.0D0) THEN
46749 RMSS(12)=SQRT(XMQR2)
46750 ELSE
46751 RMSS(12)=-SQRT(-XMQR2)
46752 ENDIF
46753
46754C SAME FOR BOTTOM SQUARK
46755 CTT=DCOS(RMSS(26))
46756 CTT2=CTT**2
46757 STT=DSIN(RMSS(26))
46758 STT2=STT**2
46759 XM22=RMSS(11)**2
46760 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
46761 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
46762 IF(ABS(CTT).GE..9999D0) THEN
46763 ABOT=-XMU*TANB
46764 XMQR2=RMSS(11)**2
46765 ELSEIF(ABS(CTT).LE.1D-4) THEN
46766 ABOT=-XMU*TANB
46767 XMQR2=RMSS(11)**2
46768 ELSE
46769 XM12=(XMQL2-STT2*XM22)/CTT2
46770 XMQR2=STT2*XM12+CTT2*XM22
46771 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46772 ENDIF
46773 RMSS(15)=ABOT
46774C......SUBTRACT OUT D-TERM AND FERMION MASS
46775 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
46776 IF(XMQR2.GE.0D0) THEN
46777 RMSS(11)=SQRT(XMQR2)
46778 ELSE
46779 RMSS(11)=-SQRT(-XMQR2)
46780 ENDIF
46781C SAME FOR TAU SLEPTON
46782 CTT=DCOS(RMSS(28))
46783 CTT2=CTT**2
46784 STT=DSIN(RMSS(28))
46785 STT2=STT**2
46786 XM12=RMSS(13)**2
46787 XM22=RMSS(14)**2
46788 XMQL2=CTT2*XM12+STT2*XM22
46789 XMQR2=STT2*XM12+CTT2*XM22
46790 XMFR=PMAS(15,1)
46791 XMF2=XMFR**2
46792 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
46793 RMSS(17)=ATAU
46794C......SUBTRACT OUT D-TERM AND FERMION MASS
46795 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
46796 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
46797 IF(XMQL2.GE.0D0) THEN
46798 RMSS(13)=SQRT(XMQL2)
46799 ELSE
46800 RMSS(13)=-SQRT(-XMQL2)
46801 ENDIF
46802 IF(XMQR2.GE.0D0) THEN
46803 RMSS(14)=SQRT(XMQR2)
46804 ELSE
46805 RMSS(14)=-SQRT(-XMQR2)
46806 ENDIF
46807 ENDIF
46808 DO 170 L=1,3
46809 AMQL=RMSS(ID1(L))
46810 IF(AMQL.LT.0D0) THEN
46811 XMQL2=-AMQL**2
46812 ELSE
46813 XMQL2=AMQL**2
46814 ENDIF
46815 ATR=RMSS(ID3(L))
46816 AMQR=RMSS(ID4(L))
46817 IF(AMQR.LT.0D0) THEN
46818 XMQR2=-AMQR**2
46819 ELSE
46820 XMQR2=AMQR**2
46821 ENDIF
46822 IF=ID2(L)
46823 XMF=PYMRUN(IF,PMAS(6,1)**2)
46824 XMF2=XMF**2
46825 AM2(1,1)=XMQL2+XMF2
46826 AM2(2,2)=XMQR2+XMF2
46827 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
46828 IF(DTERM) THEN
46829 IF(L.EQ.1) THEN
46830 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
46831 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
46832 AM2(1,2)=XMF*(ATR+XMU*TANB)
46833 ELSEIF(L.EQ.2) THEN
46834 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
46835 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
46836 AM2(1,2)=XMF*(ATR+XMU/TANB)
46837 ELSEIF(L.EQ.3) THEN
46838 IF(IMSS(8).EQ.1) THEN
46839 AM2(1,1)=RMSS(6)**2
46840 AM2(2,2)=RMSS(7)**2
46841 AM2(1,2)=0D0
46842 RMSS(13)=RMSS(6)
46843 RMSS(14)=RMSS(7)
46844 ELSE
46845 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
46846 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
46847 AM2(1,2)=XMF*(ATR+XMU*TANB)
46848 ENDIF
46849 ENDIF
46850 ENDIF
46851 AM2(2,1)=AM2(1,2)
46852 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
46853 IF(DETM.LT.0D0) THEN
46854 WRITE(MSTU(11),*) ID2(L),DETM,AM2
46855 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
46856 ENDIF
46857 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
46858 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
46859 XMF12=SAME-DIFF
46860 XMF22=SAME+DIFF
46861 IT=0
46862 IF(XMF22-XMF12.GT.0D0) THEN
46863 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
46864 RT(2,2) = RT(1,1)
46865 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
46866 & AM2(1,2)/(XMF22-XMF12))
46867 RT(2,1) = -RT(1,2)
46868 ELSE
46869 RT(1,1) = 1D0
46870 RT(2,2) = RT(1,1)
46871 RT(1,2) = 0D0
46872 RT(2,1) = -RT(1,2)
46873 ENDIF
46874 100 CONTINUE
46875 IT=IT+1
46876
46877 DO 140 I=1,2
46878 DO 130 JJ=1,2
46879 DI(I,JJ)=0D0
46880 DO 120 II=1,2
46881 DO 110 J=1,2
46882 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
46883 110 CONTINUE
46884 120 CONTINUE
46885 130 CONTINUE
46886 140 CONTINUE
46887
46888 IF(DI(1,1).GT.DI(2,2)) THEN
46889 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
46890 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
46891 WRITE(MSTU(11),*) AM2
46892 WRITE(MSTU(11),*) DI
46893 WRITE(MSTU(11),*) RT
46894 DI(1,1)=-RT(2,1)
46895 DI(2,2)=RT(1,2)
46896 DI(1,2)=-RT(2,2)
46897 DI(2,1)=RT(1,1)
46898 DO 160 I=1,2
46899 DO 150 J=1,2
46900 RT(I,J)=DI(I,J)
46901 150 CONTINUE
46902 160 CONTINUE
46903 GOTO 100
46904 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
46905 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46906 & ' OFF DIAGONAL ELEMENTS '
46907 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
46908 WRITE(MSTU(11),*) DI
46909 WRITE(MSTU(11),*) ' ROTATION = ',RT
46910C...STOP
46911 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
46912 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
46913 & ' NEGATIVE MASSES '
46914 CALL PYSTOP(111)
46915 ENDIF
46916 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
46917 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
46918 SFMIX(IF,1)=RT(1,1)
46919 SFMIX(IF,2)=RT(1,2)
46920 SFMIX(IF,3)=RT(2,1)
46921 SFMIX(IF,4)=RT(2,2)
46922 170 CONTINUE
46923
46924C.....TAU SNEUTRINO MASS...L=3
46925
46926 XARG=AM2(1,1)+XMW2*COS2B
46927 IF(XARG.LT.0D0) THEN
46928 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
46929 & ' FROM THE SUM RULE. '
46930 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46931 RETURN
46932 ELSE
46933 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
46934 ENDIF
46935
46936 RETURN
46937 END
46938C*********************************************************************
46939
46940C...PYINOM
46941C...Finds the mass eigenstates and mixing matrices for neutralinos
46942C...and charginos.
46943
46944 SUBROUTINE PYINOM
46945
46946C...Double precision and integer declarations.
46947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46948 IMPLICIT INTEGER(I-N)
46949 INTEGER PYCOMP
46950C...Parameter statement to help give large particle numbers.
46951 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46952 &KEXCIT=4000000,KDIMEN=5000000)
46953C...Commonblocks.
46954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46955 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46956 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46957 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46958 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46959 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
46960
46961C...Local variables.
46962 DOUBLE PRECISION XMW,XMZ,XM(4)
46963 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
46964 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
46965 DOUBLE PRECISION COSW,SINW
46966 DOUBLE PRECISION XMU
46967 DOUBLE PRECISION TANB,COSB,SINB
46968 DOUBLE PRECISION XM1,XM2,XM3,BETA
46969 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
46970 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
46971 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
46972 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
46973 DOUBLE PRECISION PYALPS,PYALEM
46974 DOUBLE PRECISION PYRNM3
46975 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
46976 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
46977 DATA KFNCHI/1000022,1000023,1000025,1000035/
46978
46979 IOPT=IMSS(2)
46980 IF(IMSS(1).EQ.2) THEN
46981 IOPT=1
46982 ENDIF
46983C...M1, M2, AND M3 ARE INDEPENDENT
46984 IF(IOPT.EQ.0) THEN
46985 XM1=RMSS(1)
46986 XM2=RMSS(2)
46987 XM3=RMSS(3)
46988 ELSEIF(IOPT.GE.1) THEN
46989 Q2=PMAS(23,1)**2
46990 AEM=PYALEM(Q2)
46991 A2=AEM/PARU(102)
46992 A1=AEM/(1D0-PARU(102))
46993 XM1=RMSS(1)
46994 XM2=RMSS(2)
46995 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
46996 IF(IOPT.EQ.1) THEN
46997 XM2=XM1*A2/A1*3D0/5D0
46998 RMSS(2)=XM2
46999 ELSEIF(IOPT.EQ.3) THEN
47000 XM1=XM2*5D0/3D0*A1/A2
47001 RMSS(1)=XM1
47002 ENDIF
47003 XM3=PYRNM3(XM2/A2)
47004 RMSS(3)=XM3
47005 IF(XM3.LE.0D0) THEN
47006 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47007 CALL PYSTOP(105)
47008 ENDIF
47009 ENDIF
47010
47011C...GLUINO MASS
47012 IF(IMSS(3).EQ.1) THEN
47013 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47014 ELSE
47015 AQ=0D0
47016 DO 110 I=1,4
47017 DO 100 ILR=1,2
47018 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47019 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
47020 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
47021 100 CONTINUE
47022 110 CONTINUE
47023
47024 DO 130 I=5,6
47025 DO 120 ILR=1,2
47026 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
47027 RM2=PMAS(I,1)**2/XM3**2
47028 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
47029 IF(ARG.GE.0D0) THEN
47030 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
47031 AX0=ABS(X0)
47032 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
47033 AX1=ABS(X1)
47034 IF(X0.EQ.1D0) THEN
47035 AT=-1D0
47036 BT=0.25D0
47037 ELSEIF(X0.EQ.0D0) THEN
47038 AT=0D0
47039 BT=-0.25D0
47040 ELSE
47041 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
47042 & 0.5D0*X0**2*LOG(AX0)
47043 BT=(-1D0-2D0*X0)/4D0
47044 ENDIF
47045 IF(X1.EQ.1D0) THEN
47046 AT=-1D0+AT
47047 BT=0.25D0+BT
47048 ELSEIF(X1.EQ.0D0) THEN
47049 AT=0D0+AT
47050 BT=-0.25D0+BT
47051 ELSE
47052 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
47053 & X1**2*LOG(AX1)+AT
47054 BT=(-1D0-2D0*X1)/4D0+BT
47055 ENDIF
47056 AQ=AQ+AT+BT
47057 ELSE
47058 X0=0.5D0*(1D0+RM2-RM1)
47059 Y0=-0.5D0*SQRT(-ARG)
47060 AMGX0=SQRT(X0**2+Y0**2)
47061 AM1X0=SQRT((1D0-X0)**2+Y0**2)
47062 ARGX0=ATAN2(-X0,-Y0)
47063 AR1X0=ATAN2(1D0-X0,Y0)
47064 X1=X0
47065 Y1=-Y0
47066 AMGX1=AMGX0
47067 AM1X1=AM1X0
47068 ARGX1=ATAN2(-X1,-Y1)
47069 AR1X1=ATAN2(1D0-X1,Y1)
47070 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
47071 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
47072 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
47073 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
47074 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
47075 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
47076 AQ=AQ+AT+BT
47077 ENDIF
47078 120 CONTINUE
47079 130 CONTINUE
47080 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
47081 & /(2D0*PARU(2))*(15D0+AQ))
47082 ENDIF
47083
47084C...NEUTRALINO MASSES
47085 DO 150 I=1,4
47086 DO 140 J=1,4
47087 AI(I,J)=0D0
47088 140 CONTINUE
47089 150 CONTINUE
47090 XMZ=PMAS(23,1)/100D0
47091 XMW=PMAS(24,1)/100D0
47092 XMU=RMSS(4)/100D0
47093 SINW=SQRT(PARU(102))
47094 COSW=SQRT(1D0-PARU(102))
47095 TANB=RMSS(5)
47096 BETA=ATAN(TANB)
47097 COSB=COS(BETA)
47098 SINB=TANB*COSB
47099
47100 XM2=XM2/100D0
47101 XM1=XM1/100D0
47102
47103
47104C... Definitions:
47105C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
47106C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
47107 AR(1,1) = XM1*COS(RMSS(30))
47108 AI(1,1) = XM1*SIN(RMSS(30))
47109 AR(2,2) = XM2*COS(RMSS(31))
47110 AI(2,2) = XM2*SIN(RMSS(31))
47111 AR(3,3) = 0D0
47112 AR(4,4) = 0D0
47113 AR(1,2) = 0D0
47114 AR(2,1) = 0D0
47115 AR(1,3) = -XMZ*SINW*COSB
47116 AR(3,1) = AR(1,3)
47117 AR(1,4) = XMZ*SINW*SINB
47118 AR(4,1) = AR(1,4)
47119 AR(2,3) = XMZ*COSW*COSB
47120 AR(3,2) = AR(2,3)
47121 AR(2,4) = -XMZ*COSW*SINB
47122 AR(4,2) = AR(2,4)
47123 AR(3,4) = -XMU*COS(RMSS(33))
47124 AI(3,4) = -XMU*SIN(RMSS(33))
47125 AR(4,3) = -XMU*COS(RMSS(33))
47126 AI(4,3) = -XMU*SIN(RMSS(33))
47127C CALL PYEIG4(AR,WR,ZR)
47128 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47129 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47130 & 'PROBLEM WITH PYEICG IN PYINOM ')
47131 DO 160 I=1,4
47132 INDEX(I)=I
47133 XM(I)=ABS(WR(I))
47134 160 CONTINUE
47135 DO 180 I=2,4
47136 K=I
47137 DO 170 J=I-1,1,-1
47138 IF(XM(K).LT.XM(J)) THEN
47139 ITMP=INDEX(J)
47140 XTMP=XM(J)
47141 INDEX(J)=INDEX(K)
47142 XM(J)=XM(K)
47143 INDEX(K)=ITMP
47144 XM(K)=XTMP
47145 K=K-1
47146 ELSE
47147 GOTO 180
47148 ENDIF
47149 170 CONTINUE
47150 180 CONTINUE
47151
47152
47153 DO 210 I=1,4
47154 K=INDEX(I)
47155 SMZ(I)=WR(K)*100D0
47156 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
47157 S=0D0
47158 DO 190 J=1,4
47159 S=S+ZR(J,K)**2+ZI(J,K)**2
47160 190 CONTINUE
47161 DO 200 J=1,4
47162 ZMIX(I,J)=ZR(J,K)/SQRT(S)
47163 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
47164 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
47165 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
47166 200 CONTINUE
47167 210 CONTINUE
47168
47169C...CHARGINO MASSES
47170C.....Find eigenvectors of X X^*
47171 DO I=1,4
47172 DO J=1,4
47173 AR(I,J)=0D0
47174 AI(I,J)=0D0
47175 ENDDO
47176 ENDDO
47177 AI(1,1) = 0D0
47178 AI(2,2) = 0D0
47179 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
47180 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
47181 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47182 &XMU*COS(RMSS(33))*SINB)
47183 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
47184 &XMU*SIN(RMSS(33))*SINB)
47185 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
47186 &XMU*COS(RMSS(33))*SINB)
47187 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
47188 &XMU*SIN(RMSS(33))*SINB)
47189 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47190 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47191 & 'PROBLEM WITH PYEICG IN PYINOM ')
47192 INDEX(1)=1
47193 INDEX(2)=2
47194 IF(WR(2).LT.WR(1)) THEN
47195 INDEX(1)=2
47196 INDEX(2)=1
47197 ENDIF
47198
47199
47200 DO 240 I=1,2
47201 K=INDEX(I)
47202 SMW(I)=SQRT(WR(K))*100D0
47203 S=0D0
47204 DO 220 J=1,2
47205 S=S+ZR(J,K)**2+ZI(J,K)**2
47206 220 CONTINUE
47207 DO 230 J=1,2
47208 UMIX(I,J)=ZR(J,K)/SQRT(S)
47209 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
47210 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
47211 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
47212 230 CONTINUE
47213 240 CONTINUE
47214C...Force chargino mass > neutralino mass
47215 IFRC=0
47216 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
47217 CALL PYERRM(18,'(PYINOM:) '//
47218 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
47219 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
47220 IFRC=1
47221 ENDIF
47222 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
47223 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
47224
47225C.....Find eigenvectors of X^* X
47226 DO I=1,4
47227 DO J=1,4
47228 AR(I,J)=0D0
47229 AI(I,J)=0D0
47230 ZR(I,J)=0D0
47231 ZI(I,J)=0D0
47232 ENDDO
47233 ENDDO
47234 AI(1,1) = 0D0
47235 AI(2,2) = 0D0
47236 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
47237 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
47238 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47239 &XMU*COS(RMSS(33))*COSB)
47240 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
47241 &XMU*SIN(RMSS(33))*COSB)
47242 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
47243 &XMU*COS(RMSS(33))*COSB)
47244 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
47245 &XMU*SIN(RMSS(33))*COSB)
47246 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
47247 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
47248 & 'PROBLEM WITH PYEICG IN PYINOM ')
47249 INDEX(1)=1
47250 INDEX(2)=2
47251 IF(WR(2).LT.WR(1)) THEN
47252 INDEX(1)=2
47253 INDEX(2)=1
47254 ENDIF
47255
47256 SIMAG=0D0
47257 DO 270 I=1,2
47258 K=INDEX(I)
47259 S=0D0
47260 DO 250 J=1,2
47261 S=S+ZR(J,K)**2+ZI(J,K)**2
47262 SIMAG=SIMAG+ZI(J,K)**2
47263 250 CONTINUE
47264 DO 260 J=1,2
47265 VMIX(I,J)=ZR(J,K)/SQRT(S)
47266 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
47267 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
47268 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
47269 260 CONTINUE
47270 270 CONTINUE
47271
47272C.....Simplify if no phases
47273 IF(SIMAG.LT.1D-6) THEN
47274 AR(1,1) = XM2*COS(RMSS(31))
47275 AR(2,2) = XMU*COS(RMSS(33))
47276 AR(1,2) = SQRT(2D0)*XMW*SINB
47277 AR(2,1) = SQRT(2D0)*XMW*COSB
47278 IKNT=0
47279 300 CONTINUE
47280 DO I=1,2
47281 DO J=1,2
47282 ZR(I,J)=0D0
47283 ENDDO
47284 ENDDO
47285
47286 DO I=1,2
47287 DO J=1,2
47288 DO K=1,2
47289 DO L=1,2
47290 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
47291 ENDDO
47292 ENDDO
47293 ENDDO
47294 ENDDO
47295 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
47296 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
47297 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
47298 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
47299 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47300 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47301 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
47302 IKNT=IKNT+1
47303 GOTO 300
47304 ENDIF
47305C.....Must deal with phases
47306 ELSE
47307 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
47308 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
47309 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
47310 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
47311
47312 IKNT=0
47313 310 CONTINUE
47314 DO I=1,2
47315 DO J=1,2
47316 CAI(I,J)=CMPLX(0D0,0D0)
47317 ENDDO
47318 ENDDO
47319
47320 DO I=1,2
47321 DO J=1,2
47322 DO K=1,2
47323 DO L=1,2
47324 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
47325 & CMPLX(VMIX(J,L),VMIXI(J,L))
47326 ENDDO
47327 ENDDO
47328 ENDDO
47329 ENDDO
47330
47331 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
47332 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
47333 TEMPR=VMIX(1,1)
47334 TEMPI=VMIXI(1,1)
47335 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47336 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47337 TEMPR=VMIX(1,2)
47338 TEMPI=VMIXI(1,2)
47339 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
47340 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
47341 TEMPR=VMIX(2,1)
47342 TEMPI=VMIXI(2,1)
47343 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47344 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47345 TEMPR=VMIX(2,2)
47346 TEMPI=VMIXI(2,2)
47347 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
47348 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
47349 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
47350 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
47351 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
47352 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
47353 IKNT=IKNT+1
47354 GOTO 310
47355 ENDIF
47356 ENDIF
47357 RETURN
47358 END
47359
47360C*********************************************************************
47361
47362C...PYRNM3
47363C...Calculates the running of M3, the SU(3) gluino mass parameter.
47364
47365 FUNCTION PYRNM3(RGUT)
47366
47367C...Double precision and integer declarations.
47368 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47369 IMPLICIT INTEGER(I-N)
47370 INTEGER PYK,PYCHGE,PYCOMP
47371
47372C...Local variables.
47373 DOUBLE PRECISION R
47374 DOUBLE PRECISION TOL
47375 EXTERNAL PYALPS
47376 DOUBLE PRECISION PYALPS
47377 DATA TOL/0.001D0/
47378 DATA R/0.61803399D0/
47379
47380 C=1D0-R
47381
47382 BX=RGUT*PYALPS(RGUT**2)
47383 AX=MIN(50D0,BX*0.5D0)
47384 CX=MAX(2000D0,2D0*BX)
47385
47386 X0=AX
47387 X3=CX
47388 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47389 X1=BX
47390 X2=BX+C*(CX-BX)
47391 ELSE
47392 X2=BX
47393 X1=BX-C*(BX-AX)
47394 ENDIF
47395 AS1=PYALPS(X1**2)
47396 F1=ABS(X1-RGUT*AS1)
47397 AS2=PYALPS(X2**2)
47398 F2=ABS(X2-RGUT*AS2)
47399 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47400 IF(F2.LT.F1) THEN
47401 X0=X1
47402 X1=X2
47403 X2=R*X1+C*X3
47404 F1=F2
47405 AS2=PYALPS(X2**2)
47406 F2=ABS(X2-RGUT*AS2)
47407 ELSE
47408 X3=X2
47409 X2=X1
47410 X1=R*X2+C*X0
47411 F2=F1
47412 AS1=PYALPS(X1**2)
47413 F1=ABS(X1-RGUT*AS1)
47414 ENDIF
47415 GOTO 100
47416 ENDIF
47417 IF(F1.LT.F2) THEN
47418 PYRNM3=X1
47419 XMIN=X1
47420 ELSE
47421 PYRNM3=X2
47422 XMIN=X2
47423 ENDIF
47424
47425 RETURN
47426 END
47427
47428C*********************************************************************
47429
47430C...PYEIG4
47431C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
47432C...Specific application: mixing in neutralino sector.
47433
47434 SUBROUTINE PYEIG4(A,W,Z)
47435
47436C...Double precision and integer declarations.
47437 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47438 IMPLICIT INTEGER(I-N)
47439 INTEGER PYK,PYCHGE,PYCOMP
47440
47441C...Arrays: in call and local.
47442 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
47443
47444C...Coefficients of fourth-degree equation from matrix.
47445C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
47446 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
47447 B2=0D0
47448 DO 110 I=1,3
47449 DO 100 J=I+1,4
47450 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
47451 100 CONTINUE
47452 110 CONTINUE
47453 B1=0D0
47454 B0=0D0
47455 DO 120 I=1,4
47456 I1=MOD(I,4)+1
47457 I2=MOD(I+1,4)+1
47458 I3=MOD(I+2,4)+1
47459 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
47460 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
47461 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
47462 B0=B0+(-1D0)**(I+1)*A(1,I)*(
47463 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
47464 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
47465 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
47466 120 CONTINUE
47467
47468C...Coefficients of third-degree equation needed for
47469C...separation into two second-degree equations.
47470C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
47471 C2=-B2
47472 C1=B1*B3-4D0*B0
47473 C0=-B1**2-B0*B3**2+4D0*B0*B2
47474 CQ=C1/3D0-C2**2/9D0
47475 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
47476 CQR=CQ**3+CR**2
47477
47478C...Cases with one or three real roots.
47479 IF(CQR.GE.0D0) THEN
47480 S1=(CR+SQRT(CQR))**(1D0/3D0)
47481 S2=(CR-SQRT(CQR))**(1D0/3D0)
47482 U=S1+S2-C2/3D0
47483 ELSE
47484 SABS=SQRT(-CQ)
47485 THE=ACOS(CR/SABS**3)/3D0
47486 SRE=SABS*COS(THE)
47487 U=2D0*SRE-C2/3D0
47488 ENDIF
47489
47490C...Find and solve two second-degree equations.
47491 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
47492 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
47493 Q1=U/2D0+SQRT(U**2/4D0-B0)
47494 Q2=U/2D0-SQRT(U**2/4D0-B0)
47495 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
47496 QSAV=Q1
47497 Q1=Q2
47498 Q2=QSAV
47499 ENDIF
47500 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
47501 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
47502 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
47503 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
47504
47505C...Order eigenvalues in asceding mass.
47506 W(1)=X(1)
47507 DO 150 I1=2,4
47508 DO 130 I2=I1-1,1,-1
47509 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
47510 W(I2+1)=W(I2)
47511 130 CONTINUE
47512 140 W(I2+1)=X(I1)
47513 150 CONTINUE
47514
47515C...Find equation system for eigenvectors.
47516 DO 250 I=1,4
47517 DO 170 J1=1,4
47518 D(J1,J1)=A(J1,J1)-W(I)
47519 DO 160 J2=J1+1,4
47520 D(J1,J2)=A(J1,J2)
47521 D(J2,J1)=A(J2,J1)
47522 160 CONTINUE
47523 170 CONTINUE
47524
47525C...Find largest element in matrix.
47526 DAMAX=0D0
47527 DO 190 J1=1,4
47528 DO 180 J2=1,4
47529 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
47530 JA=J1
47531 JB=J2
47532 DAMAX=ABS(D(J1,J2))
47533 180 CONTINUE
47534 190 CONTINUE
47535
47536C...Subtract others by multiple of row selected above.
47537 DAMAX=0D0
47538 DO 210 J3=JA+1,JA+3
47539 J1=J3-4*((J3-1)/4)
47540 RL=D(J1,JB)/D(JA,JB)
47541 DO 200 J2=1,4
47542 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
47543 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
47544 JC=J1
47545 JD=J2
47546 DAMAX=ABS(D(J1,J2))
47547 200 CONTINUE
47548 210 CONTINUE
47549
47550C...Do one more subtraction of a row.
47551 DAMAX=0D0
47552 DO 230 J3=JC+1,JC+3
47553 J1=J3-4*((J3-1)/4)
47554 IF(J1.EQ.JA) GOTO 230
47555 RL=D(J1,JD)/D(JC,JD)
47556 DO 220 J2=1,4
47557 IF(J2.EQ.JB) GOTO 220
47558 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
47559 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
47560 JE=J1
47561 DAMAX=ABS(D(J1,J2))
47562 220 CONTINUE
47563 230 CONTINUE
47564
47565C...Construct unnormalized eigenvector.
47566 JF1=JD+1-4*(JD/4)
47567 JF2=JD+2-4*((JD+1)/4)
47568 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
47569 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
47570 E(JF1)=-D(JE,JF2)
47571 E(JF2)=D(JE,JF1)
47572 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
47573 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
47574 & D(JA,JB)
47575
47576C...Normalize and fill in final array.
47577 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
47578 SGN=(-1D0)**INT(PYR(0)+0.5D0)
47579 DO 240 J=1,4
47580 Z(I,J)=SGN*E(J)/EA
47581 240 CONTINUE
47582 250 CONTINUE
47583
47584 RETURN
47585 END
47586
47587C*********************************************************************
47588
47589C...PYHGGM
47590C...Determines the Higgs boson mass spectrum using several inputs.
47591
47592 SUBROUTINE PYHGGM(ALPHA)
47593
47594C...Double precision and integer declarations.
47595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47596 IMPLICIT INTEGER(I-N)
47597 INTEGER PYK,PYCHGE,PYCOMP
47598C...Parameter statement to help give large particle numbers.
47599 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47600 &KEXCIT=4000000,KDIMEN=5000000)
47601C...Commonblocks.
47602 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47603 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47604 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47605 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47606 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
47607
47608C...Local variables.
47609 DOUBLE PRECISION AT,AB,XMU,TANB
47610 DOUBLE PRECISION ALPHA
47611 INTEGER IHOPT
47612 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
47613 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
47614 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
47615 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
47616
47617 IHOPT=IMSS(4)
47618 IF(IHOPT.EQ.2) THEN
47619 ALPHA=RMSS(18)
47620 RETURN
47621 ENDIF
47622 AT=RMSS(16)
47623 AB=RMSS(15)
47624 DMGL=RMSS(3)
47625 XMU=RMSS(4)
47626 TANB=RMSS(5)
47627
47628 DMA=RMSS(19)
47629 DTANB=TANB
47630 DMQ=RMSS(10)
47631 DMUR=RMSS(12)
47632 DMDR=RMSS(11)
47633 DMTOP=PMAS(6,1)
47634 DMC=PMAS(PYCOMP(KSUSY1+37),1)
47635 DAU=AT
47636 DAD=AB
47637 DMU=XMU
47638 RMSS(40)=0D0
47639 RMSS(41)=0D0
47640
47641 IF(IHOPT.EQ.0) THEN
47642 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47643 & DMHCH,DSA,DCA,DTANBA)
47644 ELSEIF(IHOPT.EQ.1) THEN
47645 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
47646 & DMHCH,DSA,DCA,DTANBA)
47647 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
47648 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
47649 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
47650 RMSS(40)=DDT
47651 RMSS(41)=DDB
47652 DMH=DMHP
47653 DHM=DHMP
47654 DMA=DAMP
47655 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
47656 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
47657 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
47658 & PMAS(PYCOMP(1000006),1),DSTOP2
47659 ENDIF
47660 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
47661 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
47662 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
47663 & PMAS(PYCOMP(2000006),1),DSTOP1
47664 ENDIF
47665 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
47666 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
47667 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
47668 & PMAS(PYCOMP(1000005),1),DSBOT2
47669 ENDIF
47670 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
47671 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
47672 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
47673 & PMAS(PYCOMP(2000005),1),DSBOT1
47674 ENDIF
47675
47676 ELSEIF (IHOPT.EQ.3) THEN
47677c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
47678C...Currently only available for SLHA spectrum read-in.
47679 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
47680 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
47681 & //' spectrum, change IMSS(1) or IMSS(4) option.')
47682 ENDIF
47683 ALPHA=RMSS(18)
47684 RETURN
47685 ENDIF
47686
47687 ALPHA=ACOS(DCA)
47688
47689 PMAS(25,1)=DMH
47690 PMAS(35,1)=DHM
47691 PMAS(36,1)=DMA
47692 PMAS(37,1)=DMHCH
47693
47694 RETURN
47695 END
47696
47697C*********************************************************************
47698
47699C...PYSUBH
47700C...This routine computes the renormalization group improved
47701C...values of Higgs masses and couplings in the MSSM.
47702
47703C...Program based on the work by M. Carena, J.R. Espinosa,
47704c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
47705
47706C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
47707C...All masses in GeV units. MA is the CP-odd Higgs mass,
47708C...MTOP is the physical top mass, MQ and MUR are the soft
47709C...supersymmetry breaking mass parameters of left handed
47710C...and right handed stops respectively, AU and AD are the
47711C...stop and sbottom trilinear soft breaking terms,
47712C...respectively, and MU is the supersymmetric
47713C...Higgs mass parameter. We use the conventions from
47714C...the physics report of Haber and Kane: left right
47715C...stop mixing term proportional to (AU - MU/TANB)
47716C...We use as input TANB defined at the scale MTOP
47717
47718C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
47719C...where MH and HM are the lightest and heaviest CP-even
47720C...Higgs masses, MHCH is the charged Higgs mass and
47721C...ALPHA is the Higgs mixing angle
47722C...TANBA is the angle TANB at the CP-odd Higgs mass scale
47723
47724C...Range of validity:
47725C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
47726C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
47727C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
47728C...are the sbottom mass eigenvalues, respectively. This
47729C...range automatically excludes the existence of tachyons.
47730C...For the charged Higgs mass computation, the method is
47731C...valid if
47732C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
47733C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
47734C...where M_SUSY**2 is the average of the squared stop mass
47735C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
47736C...masses have been assumed to be of order of the stop ones
47737C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
47738
47739 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
47740 &XMHCH,SA,CA,TANBA)
47741
47742C...Double precision and integer declarations.
47743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47744 IMPLICIT INTEGER(I-N)
47745 INTEGER PYK,PYCHGE,PYCOMP
47746C...Parameter statement to help give large particle numbers.
47747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47748 &KEXCIT=4000000,KDIMEN=5000000)
47749C...Commonblocks.
47750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47751 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47752 COMMON/PYHTRI/HHH(7)
47753 SAVE /PYDAT1/,/PYDAT2/
47754
47755C...Local variables.
47756 DOUBLE PRECISION PYALEM,PYALPS
47757 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
47758 DOUBLE PRECISION XMHCH,SA,CA
47759 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
47760 DOUBLE PRECISION Q02
47761 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
47762 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
47763 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
47764 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
47765 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
47766 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
47767 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
47768 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
47769
47770 XMZ = PMAS(23,1)
47771 Q02=XMZ**2
47772 AEM=PYALEM(Q02)
47773 ALP1=AEM/(1D0-PARU(102))
47774 ALP2=AEM/PARU(102)
47775 ALPH3Z=PYALPS(Q02)
47776
47777 ALP1 = 0.0101D0
47778 ALP2 = 0.0337D0
47779 ALPH3Z = 0.12D0
47780
47781 V = 174.1D0
47782 PI = PARU(1)
47783 TANBA = TANB
47784 TANBT = TANB
47785
47786C...MBOTTOM(MTOP) = 3. GEV
47787 XMB = PYMRUN(5,XMTOP**2)
47788 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
47789 &LOG(XMTOP**2/XMZ**2))
47790
47791C...RMTOP= RUNNING TOP QUARK MASS
47792 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
47793 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
47794 T = LOG(XMS**2/XMTOP**2)
47795 SINB = TANB/((1D0 + TANB**2)**0.5D0)
47796 COSB = SINB/TANB
47797C...IF(MA.LE.XMTOP) TANBA = TANBT
47798 IF(XMA.GT.XMTOP)
47799 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
47800 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
47801 &LOG(XMA**2/XMTOP**2))
47802
47803 SINBT = TANBT/SQRT(1D0 + TANBT**2)
47804 COSBT = 1D0/SQRT(1D0 + TANBT**2)
47805C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
47806 G1 = SQRT(ALP1*4D0*PI)
47807 G2 = SQRT(ALP2*4D0*PI)
47808 G3 = SQRT(ALP3*4D0*PI)
47809 HU = RMTOP/V/SINBT
47810 HD = XMB/V/COSBT
47811 HU2=HU*HU
47812 HD2=HD*HD
47813 HU4=HU2*HU2
47814 HD4=HD2*HD2
47815 AU2=AU**2
47816 AD2=AD**2
47817 XMS2=XMS**2
47818 XMS3=XMS**3
47819 XMS4=XMS2*XMS2
47820 XMU2=XMU*XMU
47821 PI2=PI*PI
47822
47823 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
47824 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
47825 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
47826 &+ 3D0*(AU + AD)**2/XMS2)/6D0
47827 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
47828 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
47829 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
47830 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
47831 &- 16D0*G3**2) *T/16D0/PI2)
47832 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
47833 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
47834 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
47835 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
47836 &- 16D0*G3**2) *T/16D0/PI2)
47837 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
47838 &(HU2 + HD2)*T/16D0/PI2)
47839 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47840 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47841 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47842 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
47843 &- 16D0*G3**2) *T/16D0/PI2)
47844 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47845 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
47846 &- 16D0*G3**2) *T/16D0/PI2)
47847 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
47848 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
47849 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
47850 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
47851 &XMS4)*
47852 &(1+ (6D0*HU2 -2D0* HD2
47853 &- 16D0*G3**2) *T/16D0/PI2)
47854 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
47855 &XMS4)*
47856 &(1+ (6D0*HD2 -2D0* HU2/2D0
47857 &- 16D0*G3**2) *T/16D0/PI2)
47858 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
47859 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
47860 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
47861 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
47862 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
47863 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47864 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
47865 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47866 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
47867 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47868 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
47869 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
47870 HHH(1)=XLAM1
47871 HHH(2)=XLAM2
47872 HHH(3)=XLAM3
47873 HHH(4)=XLAM4
47874 HHH(5)=XLAM5
47875 HHH(6)=XLAM6
47876 HHH(7)=XLAM7
47877 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
47878 &2D0* XLAM6*SINBT*COSBT
47879 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
47880 &+ XLAM5*COSBT**2)
47881 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
47882 &XLAM6*COSBT**2
47883 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
47884 &2D0* XLAM6* COSBT*SINBT
47885 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47886 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
47887 &((XLAM1* COSBT**2 +2D0*
47888 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
47889 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
47890 &*SINBT**2
47891 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
47892 &+ XLAM4) + XLAM6*COSBT**2
47893 &+ XLAM7* SINBT**2))
47894
47895 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
47896 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
47897 XHM = SQRT(XHM2)
47898 XMH = SQRT(XMH2)
47899 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
47900 XMHCH = SQRT(XMHCH2)
47901
47902 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47903 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47904 &XLAM6* COSBT*SINBT
47905 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47906 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47907 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
47908 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
47909
47910 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
47911 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
47912 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
47913 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
47914 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
47915 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
47916 &XLAM6* COSBT*SINBT
47917 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
47918 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
47919 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
47920
47921 SA = -SINALP
47922 CA = -COSALP
47923
47924 100 CONTINUE
47925
47926 RETURN
47927 END
47928
47929C*********************************************************************
47930
47931C...PYPOLE
47932C...This subroutine computes the CP-even higgs and CP-odd pole
47933c...Higgs masses and mixing angles.
47934
47935C...Program based on the work by M. Carena, M. Quiros
47936C...and C.E.M. Wagner, "Effective potential methods and
47937C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
47938
47939C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
47940C...AT,AB,MU
47941C...where MCHI is the largest chargino mass, MA is the running
47942C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
47943C...expectaion values at the scale MTOP, MQ is the third generation
47944C...left handed squark mass parameter, MUR is the third generation
47945C...right handed stop mass parameter, MDR is the third generation
47946C...right handed sbottom mass parameter, MTOP is the pole top quark
47947C...mass; AT,AB are the soft supersymmetry breaking trilinear
47948C...couplings of the stop and sbottoms, respectively, and MU is the
47949C...supersymmetric mass parameter
47950
47951C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
47952C...Higgses whose pole mass is computed. If IHIGGS=0 only running
47953C...masses are given, what makes the running of the program
47954c...much faster and it is quite generally a good approximation
47955c...(for a theoretical discussion see ref. above). If IHIGGS=1,
47956C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
47957c...and if IHIGGS=3, then h,H,A polarizations are computed
47958
47959C...Output: MH and MHP which are the lightest CP-even Higgs running
47960C...and pole masses, respectively; HM and HMP are the heaviest CP-even
47961C...Higgs running and pole masses, repectively; SA and CA are the
47962C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
47963C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
47964C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
47965C...the value of TANB at the CP-odd Higgs mass scale
47966
47967C...This subroutine makes use of CERN library subroutine
47968C...integration package, which makes the computation of the
47969C...pole Higgs masses somewhat faster. We thank P. Janot for this
47970C...improvement. Those who are not able to call the CERN
47971C...libraries, please use the subroutine SUBHPOLE2.F, which
47972C...although somewhat slower, gives identical results
47973
47974 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
47975 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
47976
47977C...Double precision and integer declarations.
47978 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47979 IMPLICIT INTEGER(I-N)
47980
47981C...Parameters.
47982 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47983 SAVE /PYDAT1/
47984 INTEGER PYK,PYCHGE,PYCOMP
47985
47986C...Local variables.
47987 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
47988 &SSBOT2(2),B(2,2),COUPB(2,2),
47989 &HCOUPT(2,2),HCOUPB(2,2),
47990 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
47991
47992 DELTA(1,1) = 1D0
47993 DELTA(2,2) = 1D0
47994 DELTA(1,2) = 0D0
47995 DELTA(2,1) = 0D0
47996 V = 174.1D0
47997 XMZ=91.18D0
47998 PI=PARU(1)
47999 RXMT=PYMRUN(6,XMT**2)
48000 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48001 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48002
48003 SINB = TANB/(TANB**2+1D0)**0.5D0
48004 COSB = 1D0/(TANB**2+1D0)**0.5D0
48005 COS2B = SINB**2 - COSB**2
48006 SINBPA = SINB*CA + COSB*SA
48007 COSBPA = COSB*CA - SINB*SA
48008 RMBOT = PYMRUN(5,XMT**2)
48009 XMQ2 = XMQ**2
48010 XMUR2 = XMUR**2
48011 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48012 XMDR2 = XMDR**2
48013 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48014 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48015 IF(XMST11.LT.0D0) GOTO 500
48016 IF(XMST22.LT.0D0) GOTO 500
48017 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
48018 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
48019 IF(XMSB11.LT.0D0) GOTO 500
48020 IF(XMSB22.LT.0D0) GOTO 500
48021C WMST11 = RXMT**2 + XMQ2
48022C WMST22 = RXMT**2 + XMUR2
48023 XMST12 = RXMT*(AT - XMU/TANB)
48024 XMSB12 = RMBOT*(AB - XMU*TANB)
48025
48026CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48027C...STOP EIGENVALUES CALCULATION
48028CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48029
48030 STOP12 = 0.5D0*(XMST11+XMST22) +
48031 &0.5D0*((XMST11+XMST22)**2 -
48032 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
48033 STOP22 = 0.5D0*(XMST11+XMST22) -
48034 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
48035 &XMST12**2))**0.5D0
48036
48037 IF(STOP22.LT.0D0) GOTO 500
48038 SSTOP2(1) = STOP12
48039 SSTOP2(2) = STOP22
48040 STOP1 = STOP12**0.5D0
48041 STOP2 = STOP22**0.5D0
48042C STOP1W = STOP1
48043C STOP2W = STOP2
48044
48045 IF(XMST12.EQ.0D0) XST11 = 1D0
48046 IF(XMST12.EQ.0D0) XST12 = 0D0
48047 IF(XMST12.EQ.0D0) XST21 = 0D0
48048 IF(XMST12.EQ.0D0) XST22 = 1D0
48049
48050 IF(XMST12.EQ.0D0) GOTO 110
48051
48052 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48053 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
48054 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48055 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
48056
48057 110 T(1,1) = XST11
48058 T(2,2) = XST22
48059 T(1,2) = XST12
48060 T(2,1) = XST21
48061
48062 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
48063 &0.5D0*((XMSB11+XMSB22)**2 -
48064 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
48065 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
48066 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
48067 &XMSB12**2))**0.5D0
48068 IF(SBOT22.LT.0D0) GOTO 500
48069 SBOT1 = SBOT12**0.5D0
48070 SBOT2 = SBOT22**0.5D0
48071
48072 SSBOT2(1) = SBOT12
48073 SSBOT2(2) = SBOT22
48074
48075 IF(XMSB12.EQ.0D0) XSB11 = 1D0
48076 IF(XMSB12.EQ.0D0) XSB12 = 0D0
48077 IF(XMSB12.EQ.0D0) XSB21 = 0D0
48078 IF(XMSB12.EQ.0D0) XSB22 = 1D0
48079
48080 IF(XMSB12.EQ.0D0) GOTO 130
48081
48082 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48083 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
48084 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48085 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
48086
48087 130 B(1,1) = XSB11
48088 B(2,2) = XSB22
48089 B(1,2) = XSB12
48090 B(2,1) = XSB21
48091
48092
48093 SINT = 0.2320D0
48094 SQR = DSQRT(2D0)
48095 VP = 174.1D0*SQR
48096
48097CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48098C...STARTING OF LIGHT HIGGS
48099CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48100
48101 IF(IHIGGS.EQ.0) GOTO 490
48102
48103 DO 150 I = 1,2
48104 DO 140 J = 1,2
48105 COUPT(I,J) =
48106 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
48107 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48108 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
48109 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
48110 & T(1,J)*T(2,I))
48111 140 CONTINUE
48112 150 CONTINUE
48113
48114
48115 DO 170 I = 1,2
48116 DO 160 J = 1,2
48117 COUPB(I,J) =
48118 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
48119 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48120 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
48121 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
48122 & B(1,J)*B(2,I))
48123 160 CONTINUE
48124 170 CONTINUE
48125
48126 PRUN = XMH
48127 EPS = 1D-4*PRUN
48128 ITER = 0
48129 180 ITER = ITER + 1
48130 DO 230 I3 = 1,3
48131
48132 PR(I3)=PRUN+(I3-2)*EPS/2
48133 P2=PR(I3)**2
48134 POLT = 0D0
48135 DO 200 I = 1,2
48136 DO 190 J = 1,2
48137 POLT = POLT + COUPT(I,J)**2*3D0*
48138 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48139 190 CONTINUE
48140 200 CONTINUE
48141
48142 POLB = 0D0
48143 DO 220 I = 1,2
48144 DO 210 J = 1,2
48145 POLB = POLB + COUPB(I,J)**2*3D0*
48146 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48147 210 CONTINUE
48148 220 CONTINUE
48149C RXMT2 = RXMT**2
48150 XMT2=XMT**2
48151
48152 POLTT =
48153 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48154 & CA**2/SINB**2 *
48155 & (-2D0*XMT**2+0.5D0*P2)*
48156 & PYFINT(P2,XMT2,XMT2)
48157
48158 POL = POLT + POLB + POLTT
48159 POLAR(I3) = P2 - XMH**2 - POL
48160 230 CONTINUE
48161 DERIV = (POLAR(3)-POLAR(1))/EPS
48162 DRUN = - POLAR(2)/DERIV
48163 PRUN = PRUN + DRUN
48164 P2 = PRUN**2
48165 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
48166 GOTO 180
48167 240 CONTINUE
48168
48169 XMHP = DSQRT(P2)
48170
48171CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48172C...END OF LIGHT HIGGS
48173CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48174
48175 250 IF(IHIGGS.EQ.1) GOTO 490
48176
48177CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48178C... STARTING OF HEAVY HIGGS
48179CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48180
48181 DO 270 I = 1,2
48182 DO 260 J = 1,2
48183 HCOUPT(I,J) =
48184 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
48185 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
48186 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
48187 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
48188 & T(1,J)*T(2,I))
48189 260 CONTINUE
48190 270 CONTINUE
48191
48192 DO 290 I = 1,2
48193 DO 280 J = 1,2
48194 HCOUPB(I,J) =
48195 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
48196 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
48197 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
48198 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
48199 & B(1,J)*B(2,I))
48200 HCOUPB(I,J)=0D0
48201 280 CONTINUE
48202 290 CONTINUE
48203
48204 PRUN = HM
48205 EPS = 1D-4*PRUN
48206 ITER = 0
48207 300 ITER = ITER + 1
48208 DO 350 I3 = 1,3
48209 PR(I3)=PRUN+(I3-2)*EPS/2
48210 HP2=PR(I3)**2
48211
48212 HPOLT = 0D0
48213 DO 320 I = 1,2
48214 DO 310 J = 1,2
48215 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
48216 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48217 310 CONTINUE
48218 320 CONTINUE
48219
48220 HPOLB = 0D0
48221 DO 340 I = 1,2
48222 DO 330 J = 1,2
48223 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
48224 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48225 330 CONTINUE
48226 340 CONTINUE
48227
48228C RXMT2 = RXMT**2
48229 XMT2 = XMT**2
48230
48231 HPOLTT =
48232 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48233 & SA**2/SINB**2 *
48234 & (-2D0*XMT**2+0.5D0*HP2)*
48235 & PYFINT(HP2,XMT2,XMT2)
48236
48237 HPOL = HPOLT + HPOLB + HPOLTT
48238 POLAR(I3) =HP2-HM**2-HPOL
48239 350 CONTINUE
48240 DERIV = (POLAR(3)-POLAR(1))/EPS
48241 DRUN = - POLAR(2)/DERIV
48242 PRUN = PRUN + DRUN
48243 HP2 = PRUN**2
48244 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
48245 GOTO 300
48246 360 CONTINUE
48247
48248
48249 370 CONTINUE
48250 HMP = HP2**0.5D0
48251
48252CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48253C... END OF HEAVY HIGGS
48254CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48255
48256 IF(IHIGGS.EQ.2) GOTO 490
48257
48258CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48259C...BEGINNING OF PSEUDOSCALAR HIGGS
48260CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48261
48262 DO 390 I = 1,2
48263 DO 380 J = 1,2
48264 ACOUPT(I,J) =
48265 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
48266 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
48267 380 CONTINUE
48268 390 CONTINUE
48269 DO 410 I = 1,2
48270 DO 400 J = 1,2
48271 ACOUPB(I,J) =
48272 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
48273 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
48274 400 CONTINUE
48275 410 CONTINUE
48276
48277 PRUN = XMA
48278 EPS = 1D-4*PRUN
48279 ITER = 0
48280 420 ITER = ITER + 1
48281 DO 470 I3 = 1,3
48282 PR(I3)=PRUN+(I3-2)*EPS/2
48283 AP2=PR(I3)**2
48284 APOLT = 0D0
48285 DO 440 I = 1,2
48286 DO 430 J = 1,2
48287 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
48288 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
48289 430 CONTINUE
48290 440 CONTINUE
48291 APOLB = 0D0
48292 DO 460 I = 1,2
48293 DO 450 J = 1,2
48294 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
48295 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
48296 450 CONTINUE
48297 460 CONTINUE
48298C RXMT2 = RXMT**2
48299 XMT2=XMT**2
48300 APOLTT =
48301 & 3D0*RXMT**2/8D0/PI**2/ V **2*
48302 & COSB**2/SINB**2 *
48303 & (-0.5D0*AP2)*
48304 & PYFINT(AP2,XMT2,XMT2)
48305 APOL = APOLT + APOLB + APOLTT
48306 POLAR(I3) = AP2 - XMA**2 -APOL
48307 470 CONTINUE
48308 DERIV = (POLAR(3)-POLAR(1))/EPS
48309 DRUN = - POLAR(2)/DERIV
48310 PRUN = PRUN + DRUN
48311 AP2 = PRUN**2
48312 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
48313 GOTO 420
48314 480 CONTINUE
48315
48316 AMP = DSQRT(AP2)
48317
48318CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48319C...END OF PSEUDOSCALAR HIGGS
48320CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48321
48322 IF(IHIGGS.EQ.3) GOTO 490
48323
48324 490 CONTINUE
48325 RETURN
48326 500 CONTINUE
48327 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
48328 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
48329 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
48330 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
48331 CALL PYSTOP(107)
48332 END
48333
48334C*********************************************************************
48335
48336C...PYRGHM
48337C...Auxiliary to PYPOLE.
48338
48339 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
48340 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
48341 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
48342 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
48343C...Parameters.
48344 INTEGER MSTU,MSTJ
48345 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48346 SAVE /PYDAT1/
48347
48348 MZ = 91.18D0
48349 PI = PARU(1)
48350 V = 174.1D0
48351 ALPHA1 = 0.0101D0
48352 ALPHA2 = 0.0337D0
48353 ALPHA3Z = 0.12D0
48354 TANBA = TANB
48355 TANBT = TANB
48356C MBOTTOM(MTOP) = 3. GEV
48357 MB = PYMRUN(5,MTOP**2)
48358 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
48359 *LOG(MTOP**2/MZ**2))
48360C RMTOP= RUNNING TOP QUARK MASS
48361 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48362 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
48363 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
48364 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
48365CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48366C
48367C NEW DEFINITION, TGLU.
48368C
48369CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48370 TGLU = LOG(MGLU**2/MTOP**2)
48371 SINB = TANB/DSQRT(1D0 + TANB**2)
48372 COSB = SINB/TANB
48373 IF(MA.GT.MTOP)
48374 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
48375 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
48376 *LOG(MA**2/MTOP**2))
48377 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
48378 SINB = TANBT/SQRT(1D0 + TANBT**2)
48379 COSB = 1D0/DSQRT(1D0 + TANBT**2)
48380 G1 = SQRT(ALPHA1*4D0*PI)
48381 G2 = SQRT(ALPHA2*4D0*PI)
48382 G3 = SQRT(ALPHA3*4D0*PI)
48383 HU = RMTOP/V/SINB
48384 HD = MB/V/COSB
48385 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
48386 *SBOT1,SBOT2,DELTAMT,DELTAMB)
48387 IF(MQ.GT.MUR) TP = TQ - TU
48388 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
48389 IF(MQ.GT.MUR) TDP = TU
48390 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
48391 IF(MQ.GT.MD) TPD = TQ - TD
48392 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
48393 IF(MQ.GT.MD) TDPD = TD
48394 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
48395
48396 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
48397 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
48398 * HD**2*(G1**2/3D0+G2**2)*TPD
48399
48400 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
48401 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
48402 * HU**2*(-G1**2/3D0+G2**2)*TP
48403
48404CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48405C
48406C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
48407C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
48408C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
48409C TWO STOPS.
48410C
48411C
48412CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48413
48414 DLAMBDAP2 = 0D0
48415 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
48416 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
48417 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
48418 ENDIF
48419
48420 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
48421 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48422 ENDIF
48423
48424 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
48425 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
48426 ENDIF
48427
48428 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
48429 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
48430 ENDIF
48431
48432 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
48433 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48434 ENDIF
48435
48436 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
48437 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
48438 ENDIF
48439 ENDIF
48440 DLAMBDA3 = 0D0
48441 DLAMBDA4 = 0D0
48442 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
48443 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
48444 *(G2**2-G1**2/3D0)*TPD
48445 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
48446 *1D0/16D0/PI**2*G1**2*HU**2*TP
48447 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
48448 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
48449 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
48450 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
48451 *HD**2*TPD
48452 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
48453 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
48454 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
48455 *+ (3D0*HD**2/2D0 + HU**2/2D0
48456 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
48457 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
48458 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
48459 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
48460 *(TP + TDP)/8D0/PI**2)
48461 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
48462 *+ (3D0*HU**2/2D0 + HD**2/2D0
48463 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
48464 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
48465 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
48466 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48467 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
48468 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
48469 LAMBDA4 = (- G2**2/2D0)*(1D0
48470 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
48471 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
48472
48473 LAMBDA5 = 0D0
48474 LAMBDA6 = 0D0
48475 LAMBDA7 = 0D0
48476
48477 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
48478 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
48479
48480 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
48481 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
48482 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
48483 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
48484
48485 M2(2,1) = M2(1,2)
48486CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48487CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
48488CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48489
48490 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
48491
48492 IF(MCHI.GT.MSSUSY) GOTO 100
48493 IF(MCHI.LT.MTOP) MCHI=MTOP
48494
48495 TCHAR=LOG(MSSUSY**2/MCHI**2)
48496
48497 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
48498 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
48499 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
48500
48501 DELTAM112=2D0*DELTAL12*V**2*COSB**2
48502 DELTAM222=2D0*DELTAL12*V**2*SINB**2
48503 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
48504
48505 M2(1,1)=M2(1,1)+DELTAM112
48506 M2(2,2)=M2(2,2)+DELTAM222
48507 M2(1,2)=M2(1,2)+DELTAM122
48508 M2(2,1)=M2(2,1)+DELTAM122
48509
48510 100 CONTINUE
48511
48512CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48513CCC END OF CHARGINOS/NEUTRALINOS
48514CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48515
48516 DO 120 I = 1,2
48517 DO 110 J = 1,2
48518 M2P(I,J) = M2(I,J) + VH(I,J)
48519 110 CONTINUE
48520 120 CONTINUE
48521 TRM2P = M2P(1,1) + M2P(2,2)
48522 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
48523 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48524 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
48525 HMP = DSQRT(HM2P)
48526 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
48527 MCH=DSQRT(MCH2)
48528 IF(MH2P.LT.0.) GOTO 130
48529 MHP = SQRT(MH2P)
48530 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
48531 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
48532 IF(COS2ALPHA.GE.0.) THEN
48533 ALPHA = ASIN(SIN2ALPHA)/2D0
48534 ELSE
48535 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
48536 ENDIF
48537 SA = SIN(ALPHA)
48538 CA = COS(ALPHA)
48539CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48540C
48541C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
48542C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
48543C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
48544C
48545C
48546CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48547 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
48548 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
48549 130 CONTINUE
48550 RETURN
48551 END
48552
48553C*********************************************************************
48554
48555C...PYGFXX
48556C...Auxiliary to PYRGHM.
48557
48558 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
48559 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
48560 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
48561 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
48562C...Commonblocks.
48563 INTEGER MSTU,MSTJ,KCHG
48564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48566 SAVE /PYDAT1/,/PYDAT2/
48567
48568 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
48569
48570 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
48571 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
48572
48573 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
48574 MQ2 = MQ**2
48575 MUR2 = MUR**2
48576 MD2 = MD**2
48577 TANBA = TANB
48578 SINBA = TANBA/DSQRT(TANBA**2+1D0)
48579 COSBA = SINBA/TANBA
48580
48581 SINB = TANB/DSQRT(TANB**2+1D0)
48582 COSB = SINB/TANB
48583
48584 PI = PARU(1)
48585 MZ = PMAS(23,1)
48586 MW = PMAS(24,1)
48587 SW = 1D0-MW**2/MZ**2
48588 V = 174.1D0
48589
48590 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
48591 G2 = DSQRT(0.0336D0*4D0*PI)
48592 G1 = DSQRT(0.0101D0*4D0*PI)
48593
48594 IF(MQ.GT.MUR) MST = MQ
48595 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
48596
48597 MSUSYT = DSQRT(MST**2 + MTOP**2)
48598
48599 IF(MQ.GT.MD) MSB = MQ
48600 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
48601
48602 MB = PYMRUN(5,MSB**2)
48603 MSUSYB = DSQRT(MSB**2 + MB**2)
48604 TT = LOG(MSUSYT**2/MTOP**2)
48605 TB = LOG(MSUSYB**2/MTOP**2)
48606
48607 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
48608 HT = RMTOP/(V*SINB)
48609 HTST = RMTOP/V
48610 HB = MB/V/COSB
48611 G32 = ALPHA3*4D0*PI
48612 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
48613 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
48614 AL2 = 3D0/8D0/PI**2*HT**2
48615C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
48616C ALST = 3./8./PI**2*HTST**2
48617 AL1 = 3D0/8D0/PI**2*HB**2
48618
48619 AL(1,1) = AL1
48620 AL(1,2) = (AL2+AL1)/2D0
48621 AL(2,1) = (AL2+AL1)/2D0
48622 AL(2,2) = AL2
48623
48624 IF(MA.GT.MTOP) THEN
48625 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
48626 * LOG(MTOP**2/MA**2))
48627 H1I = VI* COSBA
48628 H2I = VI*SINBA
48629 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
48630 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
48631 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
48632 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
48633 ELSE
48634 VI = V
48635 H1I = VI*COSB
48636 H2I = VI*SINB
48637 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48638 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
48639 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48640 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
48641 ENDIF
48642
48643 TANBST = H2T/H1T
48644 SINBT = TANBST/DSQRT(1D0+TANBST**2)
48645
48646 TANBSB = H2B/H1B
48647 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
48648 COSBB = SINBB/TANBSB
48649
48650 DELTAMT = 0D0
48651 DELTAMB = 0D0
48652
48653 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48654 MTOP2 = DSQRT(MTOP4)
48655 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48656 * /(1D0+DELTAMB)**4
48657 MBOT2 = DSQRT(MBOT4)
48658
48659 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48660 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48661 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48662 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48663 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48664 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48665 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48666 * MQ2 - MUR2)**2*0.25D0
48667 * + MTOP2*(AT-XMU/TANBST)**2)
48668 IF(STOP22.LT.0.) GOTO 120
48669 SBOT12 = (MQ2 + MD2)*.5D0
48670 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48671 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48672 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48673 SBOT22 = (MQ2 + MD2)*.5D0
48674 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48675 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48676 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48677 IF(SBOT22.LT.0.) SBOT22 = 10000D0
48678
48679 STOP1 = DSQRT(STOP12)
48680 STOP2 = DSQRT(STOP22)
48681 SBOT1 = DSQRT(SBOT12)
48682 SBOT2 = DSQRT(SBOT22)
48683
48684CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48685C
48686C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
48687C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
48688C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
48689C INDUCED CORRECTIONS.
48690C
48691CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48692
48693 X=SBOT1
48694 Y=SBOT2
48695 Z=XMGL
48696 IF(X.EQ.Y) X = X - 0.00001D0
48697 IF(X.EQ.Z) X = X - 0.00002D0
48698 IF(Y.EQ.Z) Y = Y - 0.00003D0
48699
48700 T1=T(X,Y,Z)
48701 X=STOP1
48702 Y=STOP2
48703 Z=XMU
48704 IF(X.EQ.Y) X = X - 0.00001D0
48705 IF(X.EQ.Z) X = X - 0.00002D0
48706 IF(Y.EQ.Z) Y = Y - 0.00003D0
48707 T2=T(X,Y,Z)
48708 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
48709 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
48710 X=STOP1
48711 Y=STOP2
48712 Z=XMGL
48713 IF(X.EQ.Y) X = X - 0.00001D0
48714 IF(X.EQ.Z) X = X - 0.00002D0
48715 IF(Y.EQ.Z) Y = Y - 0.00003D0
48716 T3=T(X,Y,Z)
48717 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
48718
48719CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48720C
48721C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
48722C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
48723C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
48724C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
48725C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
48726C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
48727C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
48728C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
48729C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
48730C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
48731C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
48732C
48733C
48734CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48735
48736 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
48737 MTOP2 = DSQRT(MTOP4)
48738 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
48739 * /(1D0+DELTAMB)**4
48740 MBOT2 = DSQRT(MBOT4)
48741
48742 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
48743 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48744 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48745 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
48746 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
48747 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
48748 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
48749 * MQ2 - MUR2)**2*0.25D0
48750 * + MTOP2*(AT-XMU/TANBST)**2)
48751
48752 IF(STOP22.LT.0.) GOTO 120
48753 SBOT12 = (MQ2 + MD2)*.5D0
48754 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48755 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48756 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48757 SBOT22 = (MQ2 + MD2)*.5D0
48758 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
48759 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
48760 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
48761 IF(SBOT22.LT.0.) GOTO 120
48762
48763
48764 STOP1 = DSQRT(STOP12)
48765 STOP2 = DSQRT(STOP22)
48766 SBOT1 = DSQRT(SBOT12)
48767 SBOT2 = DSQRT(SBOT22)
48768
48769CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48770CCC D-TERMS
48771CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
48772 STW=SW
48773
48774 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
48775 * LOG(STOP1/STOP2)
48776 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
48777 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
48778
48779 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
48780 * LOG(SBOT1/SBOT2)
48781 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
48782 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
48783
48784 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
48785 * (-.5D0*LOG(STOP12/STOP22)
48786 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
48787 * G(STOP12,STOP22))
48788
48789 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
48790 * (.5D0*LOG(SBOT12/SBOT22)
48791 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
48792 * G(SBOT12,SBOT22))
48793
48794 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
48795 * (MQ2+MBOT2)/(MD2+MBOT2))
48796 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
48797 * LOG(SBOT1**2/SBOT2**2)) +
48798 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
48799 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
48800
48801 VH3T(1,1) =
48802 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
48803 * -STOP2**2))**2*G(STOP12,STOP22)
48804
48805 VH3B(1,1)=VH3B(1,1)+
48806 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
48807
48808 VH3T(1,1) = VH3T(1,1) +
48809 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
48810
48811 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
48812 * (MQ2+MTOP2)/(MUR2+MTOP2))
48813 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
48814 * LOG(STOP1**2/STOP2**2)) +
48815 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
48816 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
48817
48818 VH3B(2,2) =
48819 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
48820 * -SBOT2**2))**2*G(SBOT12,SBOT22)
48821
48822 VH3T(2,2)=VH3T(2,2)+
48823 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
48824 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
48825 VH3T(1,2) = -
48826 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
48827 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
48828 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
48829
48830 VH3B(1,2) =
48831 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
48832 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
48833 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
48834
48835
48836 VH3T(1,2)=VH3T(1,2) +
48837 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
48838
48839 VH3B(1,2)=VH3B(1,2) +
48840 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
48841
48842 VH3T(2,1) = VH3T(1,2)
48843 VH3B(2,1) = VH3B(1,2)
48844
48845C TQ = LOG((MQ2 + MTOP2)/MTOP2)
48846C TU = LOG((MUR2+MTOP2)/MTOP2)
48847C TQD = LOG((MQ2 + MB**2)/MB**2)
48848C TD = LOG((MD2+MB**2)/MB**2)
48849
48850 DO 110 I = 1,2
48851 DO 100 J = 1,2
48852 VH(I,J) =
48853 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
48854 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
48855 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
48856 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
48857 100 CONTINUE
48858 110 CONTINUE
48859
48860 GOTO 150
48861 120 DO 140 I =1,2
48862 DO 130 J = 1,2
48863 VH(I,J) = -1D15
48864 130 CONTINUE
48865 140 CONTINUE
48866
48867
48868 150 RETURN
48869 END
48870
48871
48872
48873
48874
48875C*********************************************************************
48876
48877C...PYFINT
48878C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
48879
48880 FUNCTION PYFINT(A,B,C)
48881
48882C...Double precision and integer declarations.
48883 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48884 IMPLICIT INTEGER(I-N)
48885 INTEGER PYK,PYCHGE,PYCOMP
48886C...Commonblock.
48887 COMMON/PYINTS/XXM(20)
48888 SAVE/PYINTS/
48889
48890C...Local variables.
48891 EXTERNAL PYFISB
48892 DOUBLE PRECISION PYFISB
48893
48894 XXM(1)=A
48895 XXM(2)=B
48896 XXM(3)=C
48897 XLO=0D0
48898 XHI=1D0
48899 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
48900
48901 RETURN
48902 END
48903
48904C*********************************************************************
48905
48906C...PYFISB
48907C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
48908
48909 FUNCTION PYFISB(X)
48910
48911C...Double precision and integer declarations.
48912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48913 IMPLICIT INTEGER(I-N)
48914 INTEGER PYK,PYCHGE,PYCOMP
48915C...Commonblock.
48916 COMMON/PYINTS/XXM(20)
48917 SAVE/PYINTS/
48918
48919 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
48920 &(X*(XXM(2)-XXM(3))+XXM(3)))
48921
48922 RETURN
48923 END
48924
48925C*********************************************************************
48926
48927C...PYSFDC
48928C...Calculates decays of sfermions.
48929
48930 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
48931
48932C...Double precision and integer declarations.
48933 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48934 IMPLICIT INTEGER(I-N)
48935 INTEGER PYK,PYCHGE,PYCOMP
48936C...Parameter statement to help give large particle numbers.
48937 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48938 &KEXCIT=4000000,KDIMEN=5000000)
48939C...Commonblocks.
48940 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48941 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48942 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48943 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48944 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48945 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48946
48947C...Local variables.
48948 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
48949 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
48950 INTEGER KFIN,KCIN
48951 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
48952 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
48953 DOUBLE PRECISION PYLAMF,XL
48954 DOUBLE PRECISION TANW,XW,AEM,C1,AS
48955 DOUBLE PRECISION AL,AR,BL,BR
48956 DOUBLE PRECISION CH1,CH2,CH3,CH4
48957 DOUBLE PRECISION XMBOT,XMTOP
48958 DOUBLE PRECISION XLAM(0:400)
48959 INTEGER IDLAM(400,3)
48960 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
48961 DOUBLE PRECISION SR2
48962 DOUBLE PRECISION CBETA,SBETA
48963 DOUBLE PRECISION CW
48964 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
48965 DOUBLE PRECISION COSA,SINA,TANB
48966 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
48967 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
48968 INTEGER IG,KF1,KF2
48969 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
48970 DATA IGG/23,25,35,36/
48971 DATA PI/3.141592654D0/
48972 DATA SR2/1.4142136D0/
48973 DATA KFNCHI/1000022,1000023,1000025,1000035/
48974 DATA KFCCHI/1000024,1000037/
48975
48976C...COUNT THE NUMBER OF DECAY MODES
48977 LKNT=0
48978
48979C...NO NU_R DECAYS
48980 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
48981 &KFIN.EQ.KSUSY2+16) RETURN
48982
48983 XMW=PMAS(24,1)
48984 XMW2=XMW**2
48985 XMZ=PMAS(23,1)
48986 XW=PARU(102)
48987 TANW = SQRT(XW/(1D0-XW))
48988 CW=SQRT(1D0-XW)
48989
48990 DO 110 I=1,4
48991 DO 100 J=1,4
48992 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
48993 100 CONTINUE
48994 110 CONTINUE
48995 DO 130 I=1,2
48996 DO 120 J=1,2
48997 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
48998 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
48999 120 CONTINUE
49000 130 CONTINUE
49001
49002C...KCIN
49003 KCIN=PYCOMP(KFIN)
49004C...ILR is 1 for left and 2 for right.
49005 ILR=KFIN/KSUSY1
49006C...IFL is matching non-SUSY flavour.
49007 IFL=MOD(KFIN,KSUSY1)
49008C...IDU is weak isospin, 1 for down and 2 for up.
49009 IDU=2-MOD(IFL,2)
49010
49011 XMI=PMAS(KCIN,1)
49012 XMI2=XMI**2
49013 AEM=PYALEM(XMI2)
49014 AS =PYALPS(XMI2)
49015 C1=AEM/XW
49016 XMI3=XMI**3
49017 EI=KCHG(IFL,1)/3D0
49018
49019 XMBOT=PYMRUN(5,XMI2)
49020 XMTOP=PYMRUN(6,XMI2)
49021
49022 TANB=RMSS(5)
49023 BETA=ATAN(TANB)
49024 ALFA=RMSS(18)
49025 CBETA=COS(BETA)
49026 SBETA=TANB*CBETA
49027 SINA=SIN(ALFA)
49028 COSA=COS(ALFA)
49029 XMU=-RMSS(4)
49030 ATRIT=RMSS(16)
49031 ATRIB=RMSS(15)
49032 ATRIL=RMSS(17)
49033
49034C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
49035
49036 IF(IMSS(11).EQ.1) THEN
49037 XMP=RMSS(29)
49038 IDG=39+KSUSY1
49039 XMGR=PMAS(PYCOMP(IDG),1)
49040 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
49041 IF(IFL.EQ.5) THEN
49042 XMF=XMBOT
49043 ELSEIF(IFL.EQ.6) THEN
49044 XMF=XMTOP
49045 ELSE
49046 XMF=PMAS(IFL,1)
49047 ENDIF
49048 IF(XMI.GT.XMGR+XMF) THEN
49049 LKNT=LKNT+1
49050 IDLAM(LKNT,1)=IDG
49051 IDLAM(LKNT,2)=IFL
49052 IDLAM(LKNT,3)=0
49053 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
49054 ENDIF
49055 ENDIF
49056
49057C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
49058
49059C...CHARGED DECAYS:
49060 DO 140 IX=1,2
49061C...DI -> U CHI1-,CHI2-
49062 IF(IDU.EQ.1) THEN
49063 XMFP=PMAS(IFL+1,1)
49064 XMF =PMAS(IFL,1)
49065C...UI -> D CHI1+,CHI2+
49066 ELSE
49067 XMFP=PMAS(IFL-1,1)
49068 XMF =PMAS(IFL,1)
49069 ENDIF
49070 XMJ=SMW(IX)
49071 AXMJ=ABS(XMJ)
49072 IF(XMI.GE.AXMJ+XMFP) THEN
49073 XMA2=XMJ**2
49074 XMB2=XMFP**2
49075 IF(IDU.EQ.2) THEN
49076 IF(IFL.EQ.6) THEN
49077 XMFP=XMBOT
49078 XMF =XMTOP
49079 ELSEIF(IFL.LT.6) THEN
49080 XMF=0D0
49081 XMFP=0D0
49082 ENDIF
49083 CBL=VMIXC(IX,1)
49084 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
49085 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
49086 CAR=0D0
49087 ELSE
49088 IF(IFL.EQ.5) THEN
49089 XMF =XMBOT
49090 XMFP=XMTOP
49091 ELSEIF(IFL.LT.5) THEN
49092 XMF=0D0
49093 XMFP=0D0
49094 ENDIF
49095 CBL=UMIXC(IX,1)
49096 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
49097 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
49098 CAR=0D0
49099 ENDIF
49100
49101 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49102 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49103 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49104 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49105 CAL=CALP
49106 CBL=CBLP
49107 CAR=CARP
49108 CBR=CBRP
49109
49110C...F1 -> F` CHI
49111 IF(ILR.EQ.1) THEN
49112 CA=CAL
49113 CB=CBL
49114C...F2 -> F` CHI
49115 ELSE
49116 CA=CAR
49117 CB=CBR
49118 ENDIF
49119 LKNT=LKNT+1
49120 XL=PYLAMF(XMI2,XMA2,XMB2)
49121C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49122 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49123 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
49124 IDLAM(LKNT,3)=0
49125 IF(IDU.EQ.1) THEN
49126 IDLAM(LKNT,1)=-KFCCHI(IX)
49127 IDLAM(LKNT,2)=IFL+1
49128 ELSE
49129 IDLAM(LKNT,1)=KFCCHI(IX)
49130 IDLAM(LKNT,2)=IFL-1
49131 ENDIF
49132 ENDIF
49133 140 CONTINUE
49134
49135C...NEUTRAL DECAYS
49136 DO 150 IX=1,4
49137C...DI -> D CHI10
49138 XMF=PMAS(IFL,1)
49139 XMJ=SMZ(IX)
49140 AXMJ=ABS(XMJ)
49141 IF(XMI.GE.AXMJ+XMF) THEN
49142 XMA2=XMJ**2
49143 XMB2=XMF**2
49144 IF(IDU.EQ.1) THEN
49145 IF(IFL.EQ.5) THEN
49146 XMF=XMBOT
49147 ELSEIF(IFL.LT.5) THEN
49148 XMF=0D0
49149 ENDIF
49150 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
49151 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
49152 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49153 CBR=CAL
49154 ELSE
49155 IF(IFL.EQ.6) THEN
49156 XMF=XMTOP
49157 ELSEIF(IFL.LT.5) THEN
49158 XMF=0D0
49159 ENDIF
49160 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
49161 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
49162 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
49163 CBR=CAL
49164 ENDIF
49165
49166 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
49167 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
49168 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
49169 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
49170 CAL=CALP
49171 CBL=CBLP
49172 CAR=CARP
49173 CBR=CBRP
49174
49175C...F1 -> F CHI
49176 IF(ILR.EQ.1) THEN
49177 CA=CAL
49178 CB=CBL
49179C...F2 -> F CHI
49180 ELSE
49181 CA=CAR
49182 CB=CBR
49183 ENDIF
49184 LKNT=LKNT+1
49185 XL=PYLAMF(XMI2,XMA2,XMB2)
49186C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
49187 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49188 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
49189 IDLAM(LKNT,1)=KFNCHI(IX)
49190 IDLAM(LKNT,2)=IFL
49191 IDLAM(LKNT,3)=0
49192 ENDIF
49193 150 CONTINUE
49194
49195C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
49196C...IG=23,25,35,36
49197 DO 160 II=1,4
49198 IG=IGG(II)
49199 IF(ILR.EQ.1) GOTO 160
49200 XMB=PMAS(IG,1)
49201 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
49202 IF(XMI.LT.XMSF1+XMB) GOTO 160
49203 IF(IG.EQ.23) THEN
49204 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
49205 BR=EI*XW/CW
49206 BLR=0D0
49207 ELSEIF(IG.EQ.25) THEN
49208 IF(IFL.EQ.5) THEN
49209 XMF=XMBOT
49210 ELSEIF(IFL.EQ.6) THEN
49211 XMF=XMTOP
49212 ELSEIF(IFL.LT.5) THEN
49213 XMF=0D0
49214 ELSE
49215 XMF=PMAS(IFL,1)
49216 ENDIF
49217 IF(IDU.EQ.2) THEN
49218 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49219 & XMF**2/XMW*COSA/SBETA
49220 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49221 & XMF**2/XMW*COSA/SBETA
49222 ELSE
49223 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
49224 & XMF**2/XMW*(-SINA)/CBETA
49225 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
49226 & XMF**2/XMW*(-SINA)/CBETA
49227 ENDIF
49228 IF(IFL.EQ.5) THEN
49229 AT=ATRIB
49230 ELSEIF(IFL.EQ.6) THEN
49231 AT=ATRIT
49232 ELSEIF(IFL.EQ.15) THEN
49233 AT=ATRIL
49234 ELSE
49235 AT=0D0
49236 ENDIF
49237C.........need to complexify
49238 IF(IDU.EQ.2) THEN
49239 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
49240 & AT*COSA)
49241 ELSE
49242 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
49243 & AT*SINA)
49244 ENDIF
49245 BL=GHLL
49246 BR=GHRR
49247 BLR=-GHLR
49248 ELSEIF(IG.EQ.35) THEN
49249 IF(IFL.EQ.5) THEN
49250 XMF=XMBOT
49251 ELSEIF(IFL.EQ.6) THEN
49252 XMF=XMTOP
49253 ELSEIF(IFL.LT.5) THEN
49254 XMF=0D0
49255 ELSE
49256 XMF=PMAS(IFL,1)
49257 ENDIF
49258 IF(IDU.EQ.2) THEN
49259 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49260 & XMF**2/XMW*SINA/SBETA
49261 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49262 & XMF**2/XMW*SINA/SBETA
49263 ELSE
49264 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
49265 & XMF**2/XMW*COSA/CBETA
49266 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
49267 & XMF**2/XMW*COSA/CBETA
49268 ENDIF
49269 IF(IFL.EQ.5) THEN
49270 AT=ATRIB
49271 ELSEIF(IFL.EQ.6) THEN
49272 AT=ATRIT
49273 ELSEIF(IFL.EQ.15) THEN
49274 AT=ATRIL
49275 ELSE
49276 AT=0D0
49277 ENDIF
49278C.........Need to complexify
49279 IF(IDU.EQ.2) THEN
49280 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
49281 & AT*SINA)
49282 ELSE
49283 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
49284 & AT*COSA)
49285 ENDIF
49286 BL=GHLL
49287 BR=GHRR
49288 BLR=GHLR
49289 ELSEIF(IG.EQ.36) THEN
49290 GHLL=0D0
49291 GHRR=0D0
49292 IF(IFL.EQ.5) THEN
49293 XMF=XMBOT
49294 ELSEIF(IFL.EQ.6) THEN
49295 XMF=XMTOP
49296 ELSEIF(IFL.LT.5) THEN
49297 XMF=0D0
49298 ELSE
49299 XMF=PMAS(IFL,1)
49300 ENDIF
49301 IF(IFL.EQ.5) THEN
49302 AT=ATRIB
49303 ELSEIF(IFL.EQ.6) THEN
49304 AT=ATRIT
49305 ELSEIF(IFL.EQ.15) THEN
49306 AT=ATRIL
49307 ELSE
49308 AT=0D0
49309 ENDIF
49310C.........Need to complexify
49311 IF(IDU.EQ.2) THEN
49312 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
49313 ELSE
49314 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
49315 ENDIF
49316 BL=GHLL
49317 BR=GHRR
49318 BLR=GHLR
49319 ENDIF
49320 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
49321 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
49322 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
49323 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49324 LKNT=LKNT+1
49325 IF(IG.EQ.23) THEN
49326 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49327 ELSE
49328 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
49329 ENDIF
49330 IDLAM(LKNT,3)=0
49331 IDLAM(LKNT,1)=KFIN-KSUSY1
49332 IDLAM(LKNT,2)=IG
49333 160 CONTINUE
49334
49335C...SF -> SF' + W
49336 XMB=PMAS(24,1)
49337 IF(MOD(IFL,2).EQ.0) THEN
49338 KF1=KSUSY1+IFL-1
49339 ELSE
49340 KF1=KSUSY1+IFL+1
49341 ENDIF
49342 KF2=KF1+KSUSY1
49343 XMSF1=PMAS(PYCOMP(KF1),1)
49344 XMSF2=PMAS(PYCOMP(KF2),1)
49345 IF(XMI.GT.XMB+XMSF1) THEN
49346 IF(MOD(IFL,2).EQ.0) THEN
49347 IF(ILR.EQ.1) THEN
49348 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
49349 ELSE
49350 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
49351 ENDIF
49352 ELSE
49353 IF(ILR.EQ.1) THEN
49354 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
49355 ELSE
49356 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
49357 ENDIF
49358 ENDIF
49359 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49360 LKNT=LKNT+1
49361 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49362 IDLAM(LKNT,3)=0
49363 IDLAM(LKNT,1)=KF1
49364 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49365 ENDIF
49366 IF(XMI.GT.XMB+XMSF2) THEN
49367 IF(MOD(IFL,2).EQ.0) THEN
49368 IF(ILR.EQ.1) THEN
49369 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
49370 ELSE
49371 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
49372 ENDIF
49373 ELSE
49374 IF(ILR.EQ.1) THEN
49375 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
49376 ELSE
49377 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
49378 ENDIF
49379 ENDIF
49380 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
49381 LKNT=LKNT+1
49382 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
49383 IDLAM(LKNT,3)=0
49384 IDLAM(LKNT,1)=KF2
49385 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
49386 ENDIF
49387
49388C...SF -> SF' + HC
49389 XMB=PMAS(37,1)
49390 IF(MOD(IFL,2).EQ.0) THEN
49391 KF1=KSUSY1+IFL-1
49392 ELSE
49393 KF1=KSUSY1+IFL+1
49394 ENDIF
49395 KF2=KF1+KSUSY1
49396 XMSF1=PMAS(PYCOMP(KF1),1)
49397 XMSF2=PMAS(PYCOMP(KF2),1)
49398 IF(XMI.GT.XMB+XMSF1) THEN
49399 XMF=0D0
49400 XMFP=0D0
49401 AT=0D0
49402 AB=0D0
49403 IF(MOD(IFL,2).EQ.0) THEN
49404C...T1-> B1 HC
49405 IF(ILR.EQ.1) THEN
49406 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
49407 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
49408 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
49409 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
49410C...T2-> B1 HC
49411 ELSE
49412 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
49413 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
49414 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
49415 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
49416 ENDIF
49417 IF(IFL.EQ.6) THEN
49418 XMF=XMTOP
49419 XMFP=XMBOT
49420 AT=ATRIT
49421 AB=ATRIB
49422 ENDIF
49423 ELSE
49424C...B1 -> T1 HC
49425 IF(ILR.EQ.1) THEN
49426 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
49427 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
49428 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
49429 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
49430C...B2-> T1 HC
49431 ELSE
49432 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
49433 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
49434 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
49435 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
49436 ENDIF
49437 IF(IFL.EQ.5) THEN
49438 XMF=XMTOP
49439 XMFP=XMBOT
49440 AT=ATRIT
49441 AB=ATRIB
49442 ENDIF
49443 ENDIF
49444 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49445 LKNT=LKNT+1
49446C.......Need to complexify
49447 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49448 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49449 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49450 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49451 IDLAM(LKNT,3)=0
49452 IDLAM(LKNT,1)=KF1
49453 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49454 ENDIF
49455 IF(XMI.GT.XMB+XMSF2) THEN
49456 XMF=0D0
49457 XMFP=0D0
49458 AT=0D0
49459 AB=0D0
49460 IF(MOD(IFL,2).EQ.0) THEN
49461C...T1-> B2 HC
49462 IF(ILR.EQ.1) THEN
49463 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
49464 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
49465 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
49466 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
49467C...T2-> B2 HC
49468 ELSE
49469 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
49470 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
49471 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
49472 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
49473 ENDIF
49474 IF(IFL.EQ.6) THEN
49475 XMF=XMTOP
49476 XMFP=XMBOT
49477 AT=ATRIT
49478 AB=ATRIB
49479 ENDIF
49480 ELSE
49481C...B1 -> T2 HC
49482 IF(ILR.EQ.1) THEN
49483 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
49484 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
49485 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
49486 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
49487C...B2-> T2 HC
49488 ELSE
49489 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
49490 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
49491 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
49492 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
49493 ENDIF
49494 IF(IFL.EQ.5) THEN
49495 XMF=XMTOP
49496 XMFP=XMBOT
49497 AT=ATRIT
49498 AB=ATRIB
49499 ENDIF
49500 ENDIF
49501 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
49502 LKNT=LKNT+1
49503C.......Need to complexify
49504 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
49505 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
49506 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
49507 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
49508 IDLAM(LKNT,3)=0
49509 IDLAM(LKNT,1)=KF2
49510 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
49511 ENDIF
49512
49513C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
49514
49515 IF(IFL.LE.6) THEN
49516 XMFP=0D0
49517 XMF=0D0
49518 IF(IFL.EQ.6) XMF=PMAS(6,1)
49519 IF(IFL.EQ.5) XMF=PMAS(5,1)
49520 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
49521 AXMJ=ABS(XMJ)
49522 IF(XMI.GE.AXMJ+XMF) THEN
49523 AL=-SFMIX(IFL,3)
49524 BL=SFMIX(IFL,1)
49525 AR=-SFMIX(IFL,4)
49526 BR=SFMIX(IFL,2)
49527C...F1 -> F CHI
49528 IF(ILR.EQ.1) THEN
49529 XCA=AL
49530 XCB=BL
49531C...F2 -> F CHI
49532 ELSE
49533 XCA=AR
49534 XCB=BR
49535 ENDIF
49536 LKNT=LKNT+1
49537 XMA2=XMJ**2
49538 XMB2=XMF**2
49539 XL=PYLAMF(XMI2,XMA2,XMB2)
49540 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
49541 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
49542 IDLAM(LKNT,1)=KSUSY1+21
49543 IDLAM(LKNT,2)=IFL
49544 IDLAM(LKNT,3)=0
49545 ENDIF
49546 ENDIF
49547
49548C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
49549 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
49550 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
49551C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
49552C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
49553C...M*M = C1**2 * G**2/(16PI**2)
49554C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
49555 LKNT=LKNT+1
49556 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
49557 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
49558 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
49559 IDLAM(LKNT,1)=KSUSY1+22
49560 IDLAM(LKNT,2)=4
49561 IDLAM(LKNT,3)=0
49562 ENDIF
49563
49564C...R-violating sfermion decays (SKANDS).
49565 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
49566
49567 IKNT=LKNT
49568 XLAM(0)=0D0
49569 DO 170 I=1,IKNT
49570 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49571 XLAM(0)=XLAM(0)+XLAM(I)
49572 170 CONTINUE
49573 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
49574
49575 RETURN
49576 END
49577
49578C*********************************************************************
49579
49580C...PYGLUI
49581C...Calculates gluino decay modes.
49582
49583 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
49584
49585C...Double precision and integer declarations.
49586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49587 IMPLICIT INTEGER(I-N)
49588 INTEGER PYK,PYCHGE,PYCOMP
49589C...Parameter statement to help give large particle numbers.
49590 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49591 &KEXCIT=4000000,KDIMEN=5000000)
49592C...Commonblocks.
49593 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49594 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49595 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49596 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49597 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49598CC &SFMIX(16,4),
49599C COMMON/PYINTS/XXM(20)
49600 COMPLEX*16 CXC
49601 COMMON/PYINTC/XXC(10),CXC(8)
49602 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
49603
49604C...Local variables
49605 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
49606 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
49607 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49608 DOUBLE PRECISION PYLAMF,XL
49609 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
49610 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
49611 DOUBLE PRECISION XLAM(0:400)
49612 INTEGER IDLAM(400,3)
49613 INTEGER LKNT,IX,ILR,I,IKNT,IFL
49614 DOUBLE PRECISION SR2
49615 DOUBLE PRECISION GAM
49616 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
49617 EXTERNAL PYGAUS,PYXXZ6
49618 DOUBLE PRECISION PYGAUS,PYXXZ6
49619 DOUBLE PRECISION PREC
49620 INTEGER KFNCHI(4),KFCCHI(2)
49621 DATA PI/3.141592654D0/
49622 DATA SR2/1.4142136D0/
49623 DATA PREC/1D-2/
49624 DATA KFNCHI/1000022,1000023,1000025,1000035/
49625 DATA KFCCHI/1000024,1000037/
49626
49627C...COUNT THE NUMBER OF DECAY MODES
49628 LKNT=0
49629 IF(KFIN.NE.KSUSY1+21) RETURN
49630 KCIN=PYCOMP(KFIN)
49631
49632 XW=PARU(102)
49633 TANW = SQRT(XW/(1D0-XW))
49634
49635 XMI=PMAS(KCIN,1)
49636 AXMI=ABS(XMI)
49637 XMI2=XMI**2
49638 AEM=PYALEM(XMI2)
49639 AS =PYALPS(XMI2)
49640 C1=AEM/XW
49641 XMI3=AXMI**3
49642
49643 XMI=SIGN(XMI,RMSS(3))
49644
49645C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
49646
49647 IF(IMSS(11).EQ.1) THEN
49648 XMP=RMSS(29)
49649 IDG=39+KSUSY1
49650 XMGR=PMAS(PYCOMP(IDG),1)
49651 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
49652 IF(AXMI.GT.XMGR) THEN
49653 LKNT=LKNT+1
49654 IDLAM(LKNT,1)=IDG
49655 IDLAM(LKNT,2)=21
49656 IDLAM(LKNT,3)=0
49657 XLAM(LKNT)=XFAC
49658 ENDIF
49659 ENDIF
49660
49661C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
49662
49663 DO 110 IFL=1,6
49664 DO 100 ILR=1,2
49665 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
49666 AXMJ=ABS(XMJ)
49667 XMF=PMAS(IFL,1)
49668 IF(AXMI.GE.AXMJ+XMF) THEN
49669C...Minus sign difference from gluino-quark-squark feynman rules
49670 AL=SFMIX(IFL,1)
49671 BL=-SFMIX(IFL,3)
49672 AR=SFMIX(IFL,2)
49673 BR=-SFMIX(IFL,4)
49674C...F1 -> F CHI
49675 IF(ILR.EQ.1) THEN
49676 CA=AL
49677 CB=BL
49678C...F2 -> F CHI
49679 ELSE
49680 CA=AR
49681 CB=BR
49682 ENDIF
49683 LKNT=LKNT+1
49684 XMA2=XMJ**2
49685 XMB2=XMF**2
49686 XL=PYLAMF(XMI2,XMA2,XMB2)
49687 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
49688 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
49689 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
49690 IDLAM(LKNT,2)=-IFL
49691 IDLAM(LKNT,3)=0
49692 LKNT=LKNT+1
49693 XLAM(LKNT)=XLAM(LKNT-1)
49694 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49695 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49696 IDLAM(LKNT,3)=0
49697 ENDIF
49698 100 CONTINUE
49699 110 CONTINUE
49700
49701C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
49702C...GLUINO -> NI Q QBAR
49703 DO 170 IX=1,4
49704 XMJ=SMZ(IX)
49705 AXMJ=ABS(XMJ)
49706 IF(AXMI.GE.AXMJ) THEN
49707 DO 120 I=1,4
49708 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
49709 120 CONTINUE
49710 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
49711 ORPP=DCONJG(OLPP)
49712 XXC(1)=0D0
49713 XXC(2)=XMJ
49714 XXC(3)=0D0
49715 XXC(4)=XMI
49716 IA=1
49717 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49718 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49719 XXC(7)=XXC(5)
49720 XXC(8)=XXC(6)
49721 XXC(9)=1D6
49722 XXC(10)=0D0
49723 EI=KCHG(IA,1)/3D0
49724 T3I=SIGN(1D0,EI+1D-6)/2D0
49725 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49726 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49727 CXC(1)=0D0
49728 CXC(2)=-GLIJ
49729 CXC(3)=0D0
49730 CXC(4)=DCONJG(GLIJ)
49731 CXC(5)=0D0
49732 CXC(6)=GRIJ
49733 CXC(7)=0D0
49734 CXC(8)=-DCONJG(GRIJ)
49735 S12MIN=0D0
49736 S12MAX=(AXMI-AXMJ)**2
49737 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
49738 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
49739 LKNT=LKNT+1
49740 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49741 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49742 IDLAM(LKNT,1)=KFNCHI(IX)
49743 IDLAM(LKNT,2)=1
49744 IDLAM(LKNT,3)=-1
49745 ENDIF
49746 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
49747 LKNT=LKNT+1
49748 XLAM(LKNT)=XLAM(LKNT-1)
49749 IDLAM(LKNT,1)=KFNCHI(IX)
49750 IDLAM(LKNT,2)=3
49751 IDLAM(LKNT,3)=-3
49752 ENDIF
49753 130 CONTINUE
49754 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
49755 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
49756 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
49757 GOTO 140
49758 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
49759 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
49760 ENDIF
49761 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
49762 LKNT=LKNT+1
49763 XLAM(LKNT)=GAM
49764 IDLAM(LKNT,1)=KFNCHI(IX)
49765 IDLAM(LKNT,2)=5
49766 IDLAM(LKNT,3)=-5
49767 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
49768 ENDIF
49769C...U-TYPE QUARKS
49770 140 CONTINUE
49771 IA=2
49772 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
49773 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
49774C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
49775 XXC(7)=XXC(5)
49776 XXC(8)=XXC(6)
49777 EI=KCHG(IA,1)/3D0
49778 T3I=SIGN(1D0,EI+1D-6)/2D0
49779 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
49780 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
49781 CXC(2)=-GLIJ
49782 CXC(4)=DCONJG(GLIJ)
49783 CXC(6)=GRIJ
49784 CXC(8)=-DCONJG(GRIJ)
49785 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
49786 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
49787 LKNT=LKNT+1
49788 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
49789 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
49790 IDLAM(LKNT,1)=KFNCHI(IX)
49791 IDLAM(LKNT,2)=2
49792 IDLAM(LKNT,3)=-2
49793 ENDIF
49794 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
49795 LKNT=LKNT+1
49796 XLAM(LKNT)=XLAM(LKNT-1)
49797 IDLAM(LKNT,1)=KFNCHI(IX)
49798 IDLAM(LKNT,2)=4
49799 IDLAM(LKNT,3)=-4
49800 ENDIF
49801 150 CONTINUE
49802C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
49803C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
49804 XMF=PMAS(6,1)
49805 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
49806 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
49807 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
49808 GOTO 160
49809 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
49810 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
49811 ENDIF
49812 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
49813 LKNT=LKNT+1
49814 XLAM(LKNT)=GAM
49815 IDLAM(LKNT,1)=KFNCHI(IX)
49816 IDLAM(LKNT,2)=6
49817 IDLAM(LKNT,3)=-6
49818 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
49819 ENDIF
49820 160 CONTINUE
49821 ENDIF
49822 170 CONTINUE
49823
49824C...GLUINO -> CI Q QBAR'
49825 DO 210 IX=1,2
49826 XMJ=SMW(IX)
49827 AXMJ=ABS(XMJ)
49828 IF(AXMI.GE.AXMJ) THEN
49829 DO 180 I=1,2
49830 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
49831 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
49832 180 CONTINUE
49833 S12MIN=0D0
49834 S12MAX=(AXMI-AXMJ)**2
49835 XXC(1)=0D0
49836 XXC(2)=XMJ
49837 XXC(3)=0D0
49838 XXC(4)=XMI
49839 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
49840 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
49841 XXC(9)=1D6
49842 XXC(10)=0D0
49843 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
49844 ORPP=DCONJG(OLPP)
49845 CXC(1)=DCMPLX(0D0,0D0)
49846 CXC(3)=DCMPLX(0D0,0D0)
49847 CXC(5)=DCMPLX(0D0,0D0)
49848 CXC(7)=DCMPLX(0D0,0D0)
49849 CXC(2)=UMIXC(IX,1)*OLPP/SR2
49850 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
49851 CXC(6)=DCMPLX(0D0,0D0)
49852 CXC(8)=DCMPLX(0D0,0D0)
49853 IF(XXC(5).LT.AXMI) THEN
49854 XXC(5)=1D6
49855 ELSEIF(XXC(6).LT.AXMI) THEN
49856 XXC(6)=1D6
49857 ENDIF
49858 XXC(7)=XXC(6)
49859 XXC(8)=XXC(5)
49860 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
49861 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
49862 LKNT=LKNT+1
49863 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
49864 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
49865 IDLAM(LKNT,1)=KFCCHI(IX)
49866 IDLAM(LKNT,2)=1
49867 IDLAM(LKNT,3)=-2
49868 LKNT=LKNT+1
49869 XLAM(LKNT)=XLAM(LKNT-1)
49870 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49871 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49872 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49873 ENDIF
49874 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
49875 LKNT=LKNT+1
49876 XLAM(LKNT)=XLAM(LKNT-1)
49877 IDLAM(LKNT,1)=KFCCHI(IX)
49878 IDLAM(LKNT,2)=3
49879 IDLAM(LKNT,3)=-4
49880 LKNT=LKNT+1
49881 XLAM(LKNT)=XLAM(LKNT-1)
49882 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49883 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49884 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49885 ENDIF
49886 190 CONTINUE
49887
49888 XMF=PMAS(6,1)
49889 XMFP=PMAS(5,1)
49890 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
49891 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
49892 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
49893 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
49894 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
49895 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
49896 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
49897 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
49898 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
49899 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
49900 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
49901 CALL PYTBBC(IX,100,XMI,GAM)
49902 LKNT=LKNT+1
49903 XLAM(LKNT)=GAM
49904 IDLAM(LKNT,1)=KFCCHI(IX)
49905 IDLAM(LKNT,2)=5
49906 IDLAM(LKNT,3)=-6
49907 LKNT=LKNT+1
49908 XLAM(LKNT)=XLAM(LKNT-1)
49909 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
49910 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
49911 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
49912 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
49913 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
49914 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
49915 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
49916 ENDIF
49917 200 CONTINUE
49918 ENDIF
49919 210 CONTINUE
49920
49921C...R-parity violating (3-body) decays.
49922 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
49923
49924 IKNT=LKNT
49925 XLAM(0)=0D0
49926 DO 220 I=1,IKNT
49927 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
49928 XLAM(0)=XLAM(0)+XLAM(I)
49929 220 CONTINUE
49930 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
49931
49932 RETURN
49933 END
49934
49935
49936C*********************************************************************
49937
49938C...PYTBBN
49939C...Calculates the three-body decay of gluinos into
49940C...neutralinos and third generation fermions.
49941
49942 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
49943
49944C...Double precision and integer declarations.
49945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49946 IMPLICIT INTEGER(I-N)
49947 INTEGER PYK,PYCHGE,PYCOMP
49948C...Parameter statement to help give large particle numbers.
49949 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49950 &KEXCIT=4000000,KDIMEN=5000000)
49951C...Commonblocks.
49952 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49953 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49954 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49955 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49956 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49957 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49958
49959C...Local variables.
49960 EXTERNAL PYSIMP,PYLAMF
49961 DOUBLE PRECISION PYSIMP,PYLAMF
49962 INTEGER LIN,NN
49963 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
49964 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
49965 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
49966 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
49967 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
49968 DOUBLE PRECISION XLN1,XLN2,B1,B2
49969 DOUBLE PRECISION E,XMGLU,GAM
49970 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
49971 SAVE HRB,HLB,FLB,FRB
49972 DOUBLE PRECISION ALPHAW,ALPHAS
49973 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
49974 SAVE HLT,HRT,FLT,FRT
49975 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
49976 SAVE AMN,AN,ZN
49977 DOUBLE PRECISION AMBOT,SINC,COSC
49978 DOUBLE PRECISION AMTOP,SINA,COSA
49979 DOUBLE PRECISION SINW,COSW,TANW
49980 DOUBLE PRECISION ROT1(4,4)
49981 LOGICAL IFIRST
49982 SAVE IFIRST
49983 DATA IFIRST/.TRUE./
49984
49985 TANB=RMSS(5)
49986 SINB=TANB/SQRT(1D0+TANB**2)
49987 COSB=SINB/TANB
49988 XW=PARU(102)
49989 SINW=SQRT(XW)
49990 COSW=SQRT(1D0-XW)
49991 TANW=SINW/COSW
49992 AMW=PMAS(24,1)
49993 COSC=SFMIX(5,1)
49994 SINC=SFMIX(5,3)
49995 COSA=SFMIX(6,1)
49996 SINA=SFMIX(6,3)
49997 AMBOT=PYMRUN(5,XMGLU**2)
49998 AMTOP=PYMRUN(6,XMGLU**2)
49999 W2=SQRT(2D0)
50000 FAKT1=AMBOT/W2/AMW/COSB
50001 FAKT2=AMTOP/W2/AMW/SINB
50002 IF(IFIRST) THEN
50003 DO 110 II=1,4
50004 AMN(II)=SMZ(II)
50005 DO 100 J=1,4
50006 ROT1(II,J)=0D0
50007 AN(II,J)=0D0
50008 100 CONTINUE
50009 110 CONTINUE
50010 ROT1(1,1)=COSW
50011 ROT1(1,2)=-SINW
50012 ROT1(2,1)=-ROT1(1,2)
50013 ROT1(2,2)=ROT1(1,1)
50014 ROT1(3,3)=COSB
50015 ROT1(3,4)=SINB
50016 ROT1(4,3)=-ROT1(3,4)
50017 ROT1(4,4)=ROT1(3,3)
50018 DO 140 II=1,4
50019 DO 130 J=1,4
50020 DO 120 JJ=1,4
50021 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
50022 120 CONTINUE
50023 130 CONTINUE
50024 140 CONTINUE
50025 DO 150 J=1,4
50026 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
50027 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50028 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
50029 & XW)*AN(J,2)/COSW
50030 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
50031 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
50032 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
50033 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
50034C FLU(J)=ZN(3)
50035C FRU(J)=ZN(2)
50036 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
50037 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
50038 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
50039 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
50040 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
50041 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
50042 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
50043C FLD(J)=ZN(3)
50044C FRD(J)=ZN(2)
50045 150 CONTINUE
50046C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50047C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50048C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50049C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50050 IFIRST=.FALSE.
50051 ENDIF
50052
50053 IF(NINT(3D0*E).EQ.2) THEN
50054 HL=HLT(I)
50055 HR=HRT(I)
50056 FL=FLT(I)
50057 FR=FRT(I)
50058 COSD=SFMIX(6,1)
50059 SIND=SFMIX(6,3)
50060 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
50061 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
50062 XM=PMAS(6,1)
50063 ELSE
50064 HL=HLB(I)
50065 HR=HRB(I)
50066 FL=FLB(I)
50067 FR=FRB(I)
50068 COSD=SFMIX(5,1)
50069 SIND=SFMIX(5,3)
50070 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
50071 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
50072 XM=PMAS(5,1)
50073 ENDIF
50074 COSD2=COSD*COSD
50075 SIND2=SIND*SIND
50076 COS2D=COSD2-SIND2
50077 SIN2D=SIND*COSD*2D0
50078 HL2=HL*HL
50079 HR2=HR*HR
50080 FL2=FL*FL
50081 FR2=FR*FR
50082 FF=FL*FR
50083 HH=HL*HR
50084 HFL=HL*FL
50085 HFR=HR*FR
50086 HRFL=HR*FL
50087 HLFR=HL*FR
50088 XM2=XM*XM
50089 XMG=XMGLU
50090 XMG2=XMG*XMG
50091 ALPHAW=PYALEM(XMG2)
50092 ALPHAS=PYALPS(XMG2)
50093 XMR=AMN(I)
50094 XMR2=XMR*XMR
50095 XMQ4=XMG*XM2*XMR
50096 XM24=(XMG2+XM2)*(XM2+XMR2)
50097 SMIN=4D0*XM2
50098 SMAX=(XMG-ABS(XMR))**2
50099 XMQA=XMG2+2D0*XM2+XMR2
50100 DO 170 LIN=1,NN-1
50101 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50102 GRS=SBAR-XMQA
50103 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
50104 W=DSQRT(W)
50105 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
50106 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
50107 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
50108 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
50109 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
50110 & +2D0*(FF*SIND2-HH*COSD2))*W
50111 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
50112 & +4D0*HFL*XM*XMR)*XLN1
50113 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
50114 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
50115 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
50116 & +8D0*HFL*XMQ4*SIN2D)*B1
50117 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
50118 & +4D0*HFR*XMR*XM)*XLN2
50119 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
50120 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
50121 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
50122 & -8D0*HFR*XMQ4*SIN2D)*B2
50123 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
50124 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
50125 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
50126 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
50127 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
50128 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
50129 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
50130 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
50131 G(5)=(2D0*(HH*COSD2-FF*SIND2)
50132 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
50133 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
50134 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
50135 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
50136 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
50137 & +COS2D*XM*(SBAR+XMG2-XMR2))
50138 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
50139 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
50140 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
50141 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
50142 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
50143 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
50144 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
50145 SUMME(LIN)=0D0
50146 DO 160 J=0,6
50147 SUMME(LIN)=SUMME(LIN)+G(J)
50148 160 CONTINUE
50149 170 CONTINUE
50150 SUMME(0)=0D0
50151 SUMME(NN)=0D0
50152 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50153 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50154
50155 RETURN
50156 END
50157
50158C*********************************************************************
50159
50160C...PYTBBC
50161C...Calculates the three-body decay of gluinos into
50162C...charginos and third generation fermions.
50163
50164 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
50165
50166C...Double precision and integer declarations.
50167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50168 IMPLICIT INTEGER(I-N)
50169 INTEGER PYK,PYCHGE,PYCOMP
50170C...Parameter statement to help give large particle numbers.
50171 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50172 &KEXCIT=4000000,KDIMEN=5000000)
50173C...Commonblocks.
50174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50176 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50177 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50178 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50179 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50180
50181C...Local variables.
50182 EXTERNAL PYSIMP,PYLAMF
50183 DOUBLE PRECISION PYSIMP,PYLAMF
50184 INTEGER I,NN,LIN
50185 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
50186 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
50187 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
50188 DOUBLE PRECISION SUMME(0:100),A(4,8)
50189 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
50190 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
50191 DOUBLE PRECISION XMGLU,GAM
50192 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
50193 &DDD(2),EEE(2),FFF(2)
50194 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
50195 DOUBLE PRECISION ALPHAW,ALPHAS
50196 DOUBLE PRECISION AMC(2)
50197 SAVE AMC
50198 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
50199 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
50200 SAVE AMSB,AMST
50201 LOGICAL IFIRST
50202 SAVE IFIRST
50203 DATA IFIRST/.TRUE./
50204
50205 TANB=RMSS(5)
50206 SINB=TANB/SQRT(1D0+TANB**2)
50207 COSB=SINB/TANB
50208 XW=PARU(102)
50209 AMW=PMAS(24,1)
50210 COSC=SFMIX(5,1)
50211 SINC=SFMIX(5,3)
50212 COSA=SFMIX(6,1)
50213 SINA=SFMIX(6,3)
50214 AMBOT=PYMRUN(5,XMGLU**2)
50215 AMTOP=PYMRUN(6,XMGLU**2)
50216 W2=SQRT(2D0)
50217 AMW=PMAS(24,1)
50218 FAKT1=AMBOT/W2/AMW/COSB
50219 FAKT2=AMTOP/W2/AMW/SINB
50220 IF(IFIRST) THEN
50221 AMC(1)=SMW(1)
50222 AMC(2)=SMW(2)
50223 DO 100 JJ=1,2
50224 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
50225 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
50226 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
50227 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
50228 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
50229 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
50230 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
50231 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
50232 100 CONTINUE
50233 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
50234 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
50235 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
50236 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
50237 IFIRST=.FALSE.
50238 ENDIF
50239
50240 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
50241 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
50242 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
50243 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
50244
50245 COS2A=COSA**2-SINA**2
50246 SIN2A=SINA*COSA*2D0
50247 COS2C=COSC**2-SINC**2
50248 SIN2C=SINC*COSC*2D0
50249
50250 XMG=XMGLU
50251 XMT=PMAS(6,1)
50252 XMB=PMAS(5,1)
50253 XMR=AMC(I)
50254 XMG2=XMG*XMG
50255 ALPHAW=PYALEM(XMG2)
50256 ALPHAS=PYALPS(XMG2)
50257 XMT2=XMT*XMT
50258 XMB2=XMB*XMB
50259 XMR2=XMR*XMR
50260 XMQ2=XMG2+XMT2+XMB2+XMR2
50261 XMQ4=XMG*XMT*XMB*XMR
50262 XMQ3=XMG2*XMR2+XMT2*XMB2
50263 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
50264 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
50265
50266 XMST(1)=AMST(1)*AMST(1)
50267 XMST(2)=AMST(1)*AMST(1)
50268 XMST(3)=AMST(2)*AMST(2)
50269 XMST(4)=AMST(2)*AMST(2)
50270 XMSB(1)=AMSB(1)*AMSB(1)
50271 XMSB(2)=AMSB(2)*AMSB(2)
50272 XMSB(3)=AMSB(1)*AMSB(1)
50273 XMSB(4)=AMSB(2)*AMSB(2)
50274
50275 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
50276 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
50277 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
50278 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
50279 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
50280 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
50281 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
50282 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
50283
50284 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
50285 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
50286 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
50287 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
50288 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
50289 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
50290 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
50291 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
50292
50293 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
50294 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
50295 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
50296 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
50297 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
50298 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
50299 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
50300 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
50301
50302 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
50303 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
50304 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
50305 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
50306 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
50307 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
50308 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
50309 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
50310
50311 SMAX=(XMG-ABS(XMR))**2
50312 SMIN=(XMB+XMT)**2+0.1D0
50313
50314 DO 120 LIN=0,NN-1
50315 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
50316 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
50317 GRS=SBAR-XMQ2
50318 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
50319 W=DSQRT(W)/2D0/SBAR
50320 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
50321 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
50322 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
50323 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
50324 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
50325 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
50326 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
50327 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
50328 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
50329 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
50330 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
50331 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
50332 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
50333 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
50334 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
50335 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
50336 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
50337 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
50338 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
50339 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
50340 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
50341 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
50342 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
50343 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
50344 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
50345 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
50346 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
50347 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
50348 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
50349 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
50350 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
50351 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
50352 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
50353 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
50354 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
50355 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
50356 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
50357 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
50358 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
50359 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
50360 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
50361 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
50362 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
50363 DO 110 J=1,4
50364 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
50365 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
50366 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
50367 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
50368 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
50369 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
50370 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
50371 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
50372 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
50373 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
50374 & -A(J,6)*(XMG2+XMR2-SBAR)
50375 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
50376 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
50377 & /(GRS+XMSB(J)+XMST(J))
50378 110 CONTINUE
50379 120 CONTINUE
50380 SUMME(NN)=0D0
50381 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
50382 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
50383
50384 RETURN
50385 END
50386
50387C*********************************************************************
50388
50389C...PYNJDC
50390C...Calculates decay widths for the neutralinos (admixtures of
50391C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
50392
50393C...Input: KCIN = KF code for particle
50394C...Output: XLAM = widths
50395C... IDLAM = KF codes for decay particles
50396C... IKNT = number of decay channels defined
50397C...AUTHOR: STEPHEN MRENNA
50398C...Last change:
50399C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
50400C...when CHIGAMMA .NE. 0
50401C...10 FEB 96: Calculate this decay for small tan(beta)
50402
50403 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
50404
50405C...Double precision and integer declarations.
50406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50407 IMPLICIT INTEGER(I-N)
50408 INTEGER PYK,PYCHGE,PYCOMP
50409C...Parameter statement to help give large particle numbers.
50410 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50411 &KEXCIT=4000000,KDIMEN=5000000)
50412C...Commonblocks.
50413 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50414 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50415 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50416c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50417c &SFMIX(16,4)
50418 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50419 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50420C COMMON/PYINTS/XXM(20)
50421 COMPLEX*16 CXC
50422 COMMON/PYINTC/XXC(10),CXC(8)
50423 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50424
50425C...Local variables.
50426 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50427 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
50428 INTEGER KFIN
50429 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
50430 &XMZ,XMZ2,AXMJ,AXMI
50431 DOUBLE PRECISION S12MIN,S12MAX
50432 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
50433 DOUBLE PRECISION PYLAMF,XL
50434 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
50435 DOUBLE PRECISION PYX2XH,PYX2XG
50436 DOUBLE PRECISION XLAM(0:400)
50437 INTEGER IDLAM(400,3)
50438 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
50439 INTEGER ITH(3),KF1,KF2
50440 INTEGER ITHC
50441 DOUBLE PRECISION DH(3),EH(3)
50442 DOUBLE PRECISION SR2
50443 DOUBLE PRECISION CBETA,SBETA
50444 DOUBLE PRECISION GAMCON,XMT1,XMT2
50445 DOUBLE PRECISION PYALEM,PI,PYALPS
50446 DOUBLE PRECISION RAT1,RAT2
50447 DOUBLE PRECISION T3T,FCOL
50448 DOUBLE PRECISION ALFA,BETA,TANB
50449 DOUBLE PRECISION PYXXGA
50450 EXTERNAL PYGAUS,PYXXZ6
50451 DOUBLE PRECISION PYGAUS,PYXXZ6
50452 DOUBLE PRECISION PREC
50453 INTEGER KFNCHI(4),KFCCHI(2)
50454 DATA ITH/25,35,36/
50455 DATA ITHC/37/
50456 DATA PREC/1D-2/
50457 DATA PI/3.141592654D0/
50458 DATA SR2/1.4142136D0/
50459 DATA KFNCHI/1000022,1000023,1000025,1000035/
50460 DATA KFCCHI/1000024,1000037/
50461
50462C...COUNT THE NUMBER OF DECAY MODES
50463 LKNT=0
50464
50465 XMW=PMAS(24,1)
50466 XMW2=XMW**2
50467 XMZ=PMAS(23,1)
50468 XMZ2=XMZ**2
50469 XW=1D0-XMW2/XMZ2
50470 XW1=1D0-XW
50471 TANW = SQRT(XW/XW1)
50472
50473C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
50474 IX=1
50475 IF(KFIN.EQ.KFNCHI(2)) IX=2
50476 IF(KFIN.EQ.KFNCHI(3)) IX=3
50477 IF(KFIN.EQ.KFNCHI(4)) IX=4
50478
50479 XMI=SMZ(IX)
50480 XMI2=XMI**2
50481 AXMI=ABS(XMI)
50482 AEM=PYALEM(XMI2)
50483 AS =PYALPS(XMI2)
50484 C1=AEM/XW
50485 XMI3=ABS(XMI**3)
50486
50487 TANB=RMSS(5)
50488 BETA=ATAN(TANB)
50489 ALFA=RMSS(18)
50490 CBETA=COS(BETA)
50491 SBETA=TANB*CBETA
50492 CALFA=COS(ALFA)
50493 SALFA=SIN(ALFA)
50494
50495 DO 110 I=1,4
50496 DO 100 J=1,4
50497 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50498 100 CONTINUE
50499 110 CONTINUE
50500 DO 130 I=1,2
50501 DO 120 J=1,2
50502 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50503 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50504 120 CONTINUE
50505 130 CONTINUE
50506
50507C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
50508 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
50509
50510C...FORCE CHI0_2 -> CHI0_1 + GAMMA
50511 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
50512 XMJ=SMZ(1)
50513 AXMJ=ABS(XMJ)
50514 LKNT=LKNT+1
50515 GAMCON=AEM**3/8D0/PI/XMW2/XW
50516 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50517 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50518 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50519 IDLAM(LKNT,1)=KSUSY1+22
50520 IDLAM(LKNT,2)=22
50521 IDLAM(LKNT,3)=0
50522 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
50523 GOTO 340
50524 ENDIF
50525
50526C...GRAVITINO DECAY MODES
50527
50528 IF(IMSS(11).EQ.1) THEN
50529 XMP=RMSS(29)
50530 IDG=39+KSUSY1
50531 XMGR=PMAS(PYCOMP(IDG),1)
50532 SINW=SQRT(XW)
50533 COSW=SQRT(1D0-XW)
50534 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50535 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
50536 LKNT=LKNT+1
50537 IDLAM(LKNT,1)=IDG
50538 IDLAM(LKNT,2)=22
50539 IDLAM(LKNT,3)=0
50540 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
50541 ENDIF
50542 IF(AXMI.GT.XMGR+XMZ) THEN
50543 LKNT=LKNT+1
50544 IDLAM(LKNT,1)=IDG
50545 IDLAM(LKNT,2)=23
50546 IDLAM(LKNT,3)=0
50547 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
50548 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
50549 & (1D0-XMZ2/XMI2)**4
50550 ENDIF
50551 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
50552 LKNT=LKNT+1
50553 IDLAM(LKNT,1)=IDG
50554 IDLAM(LKNT,2)=25
50555 IDLAM(LKNT,3)=0
50556 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
50557 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
50558 ENDIF
50559 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
50560 LKNT=LKNT+1
50561 IDLAM(LKNT,1)=IDG
50562 IDLAM(LKNT,2)=35
50563 IDLAM(LKNT,3)=0
50564 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
50565 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
50566 ENDIF
50567 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
50568 LKNT=LKNT+1
50569 IDLAM(LKNT,1)=IDG
50570 IDLAM(LKNT,2)=36
50571 IDLAM(LKNT,3)=0
50572 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
50573 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
50574 ENDIF
50575 IF(IX.EQ.1) GOTO 300
50576 ENDIF
50577
50578 DO 220 IJ=1,IX-1
50579 XMJ=SMZ(IJ)
50580 AXMJ=ABS(XMJ)
50581 XMJ2=XMJ**2
50582
50583C...CHI0_I -> CHI0_J + GAMMA
50584 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
50585 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
50586 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
50587 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
50588 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
50589 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
50590 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
50591 LKNT=LKNT+1
50592 IDLAM(LKNT,1)=KFNCHI(IJ)
50593 IDLAM(LKNT,2)=22
50594 IDLAM(LKNT,3)=0
50595 GAMCON=AEM**3/8D0/PI/XMW2/XW
50596 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
50597 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
50598 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
50599 ENDIF
50600 ENDIF
50601
50602C...CHI0_I -> CHI0_J + Z0
50603 IF(AXMI.GE.AXMJ+XMZ) THEN
50604 LKNT=LKNT+1
50605 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50606 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50607 ORPP=-DCONJG(OLPP)
50608 GX2=ABS(OLPP)**2+ABS(ORPP)**2
50609 GLR=DBLE(OLPP*DCONJG(ORPP))
50610 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
50611 IDLAM(LKNT,1)=KFNCHI(IJ)
50612 IDLAM(LKNT,2)=23
50613 IDLAM(LKNT,3)=0
50614 ELSEIF(AXMI.GE.AXMJ) THEN
50615 XXC(1)=0D0
50616 XXC(2)=XMJ
50617 XXC(3)=0D0
50618 XXC(4)=XMI
50619 XXC(9)=XMZ
50620 XXC(10)=PMAS(23,2)
50621 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
50622 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
50623 ORPP=DCONJG(OLPP)
50624C...CHARGED LEPTONS
50625 FID=11
50626 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50627 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50628 EI=KCHG(FID,1)/3D0
50629 T3I=SIGN(1D0,EI+1D-6)/2D0
50630 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50631 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50632 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50633 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50634 CXC(2)=-GLIJ
50635 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50636 CXC(4)=DCONJG(GLIJ)
50637 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50638 CXC(6)=GRIJ
50639 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50640 CXC(8)=-DCONJG(GRIJ)
50641 S12MIN=0D0
50642 S12MAX=(AXMI-AXMJ)**2
50643 IF( XXC(5).LT.AXMI ) THEN
50644 XXC(5)=1D6
50645 ENDIF
50646 IF(XXC(6).LT.AXMI ) THEN
50647 XXC(6)=1D6
50648 ENDIF
50649 XXC(7)=XXC(5)
50650 XXC(8)=XXC(6)
50651
50652 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
50653 LKNT=LKNT+1
50654 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50655 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50656 IDLAM(LKNT,1)=KFNCHI(IJ)
50657 IDLAM(LKNT,2)=FID
50658 IDLAM(LKNT,3)=-FID
50659 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
50660 LKNT=LKNT+1
50661 XLAM(LKNT)=XLAM(LKNT-1)
50662 IDLAM(LKNT,1)=KFNCHI(IJ)
50663 IDLAM(LKNT,2)=13
50664 IDLAM(LKNT,3)=-13
50665 ENDIF
50666 ENDIF
50667 140 CONTINUE
50668 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50669 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50670 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
50671 ELSE
50672 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
50673 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50674 ENDIF
50675 IF( XXC(5).LT.AXMI ) THEN
50676 XXC(5)=1D6
50677 ENDIF
50678 IF(XXC(6).LT.AXMI ) THEN
50679 XXC(6)=1D6
50680 ENDIF
50681 XXC(7)=XXC(5)
50682 XXC(8)=XXC(6)
50683
50684 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
50685 LKNT=LKNT+1
50686 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50687 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50688 IDLAM(LKNT,1)=KFNCHI(IJ)
50689 IDLAM(LKNT,2)=15
50690 IDLAM(LKNT,3)=-15
50691 ENDIF
50692
50693C...NEUTRINOS
50694 150 CONTINUE
50695 FID=12
50696 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50697 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50698 EI=KCHG(FID,1)/3D0
50699 T3I=SIGN(1D0,EI+1D-6)/2D0
50700 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50701 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50702 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50703 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50704 CXC(2)=-GLIJ
50705 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50706 CXC(4)=DCONJG(GLIJ)
50707 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50708 CXC(6)=GRIJ
50709 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50710 CXC(8)=-DCONJG(GRIJ)
50711 S12MIN=0D0
50712 S12MAX=(AXMI-AXMJ)**2
50713 IF( XXC(5).LT.AXMI ) THEN
50714 XXC(5)=1D6
50715 ENDIF
50716 IF( XXC(6).LT.AXMI ) THEN
50717 XXC(6)=1D6
50718 ENDIF
50719 XXC(7)=XXC(5)
50720 XXC(8)=XXC(6)
50721
50722 LKNT=LKNT+1
50723 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50724 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50725 IDLAM(LKNT,1)=KFNCHI(IJ)
50726 IDLAM(LKNT,2)=12
50727 IDLAM(LKNT,3)=-12
50728 LKNT=LKNT+1
50729 XLAM(LKNT)=XLAM(LKNT-1)
50730 IDLAM(LKNT,1)=KFNCHI(IJ)
50731 IDLAM(LKNT,2)=14
50732 IDLAM(LKNT,3)=-14
50733 160 CONTINUE
50734
50735 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
50736 & THEN
50737 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
50738 IF( XXC(5).LT.AXMI ) THEN
50739 XXC(5)=1D6
50740 ENDIF
50741 XXC(7)=XXC(5)
50742 LKNT=LKNT+1
50743 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50744 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
50745 ELSE
50746 LKNT=LKNT+1
50747 XLAM(LKNT)=XLAM(LKNT-1)
50748 ENDIF
50749 IDLAM(LKNT,1)=KFNCHI(IJ)
50750 IDLAM(LKNT,2)=16
50751 IDLAM(LKNT,3)=-16
50752C...D-TYPE QUARKS
50753 170 CONTINUE
50754 FID=1
50755 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50756 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50757 EI=KCHG(FID,1)/3D0
50758 T3I=SIGN(1D0,EI+1D-6)/2D0
50759 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50760 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50761 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50762 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50763 CXC(2)=-GLIJ
50764 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50765 CXC(4)=DCONJG(GLIJ)
50766 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50767 CXC(6)=GRIJ
50768 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50769 CXC(8)=-DCONJG(GRIJ)
50770 S12MIN=0D0
50771 S12MAX=(AXMI-AXMJ)**2
50772 IF( XXC(5).LT.AXMI ) THEN
50773 XXC(5)=1D6
50774 ENDIF
50775 IF( XXC(6).LT.AXMI ) THEN
50776 XXC(6)=1D6
50777 ENDIF
50778 XXC(7)=XXC(5)
50779 XXC(8)=XXC(6)
50780
50781 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50782 LKNT=LKNT+1
50783 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50784 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50785 IDLAM(LKNT,1)=KFNCHI(IJ)
50786 IDLAM(LKNT,2)=1
50787 IDLAM(LKNT,3)=-1
50788 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50789 LKNT=LKNT+1
50790 XLAM(LKNT)=XLAM(LKNT-1)
50791 IDLAM(LKNT,1)=KFNCHI(IJ)
50792 IDLAM(LKNT,2)=3
50793 IDLAM(LKNT,3)=-3
50794 ENDIF
50795 ENDIF
50796 180 CONTINUE
50797 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
50798 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
50799 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
50800 ELSE
50801 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
50802 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
50803 ENDIF
50804 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
50805 IF(XXC(5).LT.AXMI) THEN
50806 XXC(5)=1D6
50807 ELSEIF(XXC(6).LT.AXMI) THEN
50808 XXC(6)=1D6
50809 ENDIF
50810 XXC(7)=XXC(5)
50811 XXC(8)=XXC(6)
50812 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50813 LKNT=LKNT+1
50814 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50815 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50816 IDLAM(LKNT,1)=KFNCHI(IJ)
50817 IDLAM(LKNT,2)=5
50818 IDLAM(LKNT,3)=-5
50819 ENDIF
50820
50821C...U-TYPE QUARKS
50822 190 CONTINUE
50823 FID=2
50824 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
50825 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
50826 EI=KCHG(FID,1)/3D0
50827 T3I=SIGN(1D0,EI+1D-6)/2D0
50828 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
50829 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
50830 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
50831 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
50832 CXC(2)=-GLIJ
50833 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
50834 CXC(4)=DCONJG(GLIJ)
50835 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
50836 CXC(6)=GRIJ
50837 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
50838 CXC(8)=-DCONJG(GRIJ)
50839
50840 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
50841 IF(XXC(5).LT.AXMI) THEN
50842 XXC(5)=1D6
50843 ELSEIF(XXC(6).LT.AXMI) THEN
50844 XXC(6)=1D6
50845 ENDIF
50846 XXC(7)=XXC(5)
50847 XXC(8)=XXC(6)
50848
50849 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50850 LKNT=LKNT+1
50851 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50852 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
50853 IDLAM(LKNT,1)=KFNCHI(IJ)
50854 IDLAM(LKNT,2)=2
50855 IDLAM(LKNT,3)=-2
50856 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50857 LKNT=LKNT+1
50858 XLAM(LKNT)=XLAM(LKNT-1)
50859 IDLAM(LKNT,1)=KFNCHI(IJ)
50860 IDLAM(LKNT,2)=4
50861 IDLAM(LKNT,3)=-4
50862 ENDIF
50863 ENDIF
50864 200 CONTINUE
50865 ENDIF
50866
50867C...CHI0_I -> CHI0_J + H0_K
50868 EH(1)=SIN(ALFA)
50869 EH(2)=COS(ALFA)
50870 EH(3)=-SIN(BETA)
50871 DH(1)=COS(ALFA)
50872 DH(2)=-SIN(ALFA)
50873 DH(3)=COS(BETA)
50874 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
50875 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
50876 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
50877 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
50878 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
50879 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
50880 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
50881 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
50882 DO 210 IH=1,3
50883 XMH=PMAS(ITH(IH),1)
50884 XMH2=XMH**2
50885 IF(AXMI.GE.AXMJ+XMH) THEN
50886 LKNT=LKNT+1
50887 XL=PYLAMF(XMI2,XMJ2,XMH2)
50888 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
50889 F12K=F21K
50890C...SIGN OF MASSES I,J
50891 XMK=XMJ
50892 IF(IH.EQ.3) XMK=-XMK
50893 GX2=ABS(F21K)**2+ABS(F12K)**2
50894 GLR=DBLE(F21K*DCONJG(F12K))
50895 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
50896 IDLAM(LKNT,1)=KFNCHI(IJ)
50897 IDLAM(LKNT,2)=ITH(IH)
50898 IDLAM(LKNT,3)=0
50899 ENDIF
50900 210 CONTINUE
50901 220 CONTINUE
50902
50903C...CHI0_I -> CHI+_J + W-
50904 DO 260 IJ=1,2
50905 XMJ=SMW(IJ)
50906 AXMJ=ABS(XMJ)
50907 XMJ2=XMJ**2
50908 IF(AXMI.GE.AXMJ+XMW) THEN
50909 LKNT=LKNT+1
50910 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50911 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
50912 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50913 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
50914 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
50915 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
50916 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
50917 IDLAM(LKNT,1)=KFCCHI(IJ)
50918 IDLAM(LKNT,2)=-24
50919 IDLAM(LKNT,3)=0
50920 LKNT=LKNT+1
50921 XLAM(LKNT)=XLAM(LKNT-1)
50922 IDLAM(LKNT,1)=-KFCCHI(IJ)
50923 IDLAM(LKNT,2)=24
50924 IDLAM(LKNT,3)=0
50925 ELSEIF(AXMI.GE.AXMJ) THEN
50926 S12MIN=0D0
50927 S12MAX=(AXMI-AXMJ)**2
50928 RT2I = 1D0/SQRT(2D0)
50929 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
50930 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
50931 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
50932 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
50933 CXC(5)=DCMPLX(0D0,0D0)
50934 CXC(7)=DCMPLX(0D0,0D0)
50935 IA=11
50936 JA=12
50937 EI=KCHG(IA,1)/3D0
50938 T3I=SIGN(1D0,EI+1D-6)/2D0
50939 EJ=KCHG(JA,1)/3D0
50940 T3J=SIGN(1D0,EJ+1D-6)/2D0
50941 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
50942 & TANW+ZMIXC(IX,2)*T3J)*RT2I
50943 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
50944 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
50945 CXC(6)=DCMPLX(0D0,0D0)
50946 CXC(8)=DCMPLX(0D0,0D0)
50947 XXC(1)=0D0
50948 XXC(2)=XMJ
50949 XXC(3)=0D0
50950 XXC(4)=XMI
50951 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
50952 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
50953 XXC(9)=PMAS(24,1)
50954 XXC(10)=PMAS(24,2)
50955 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
50956 IF(XXC(5).LT.AXMI) THEN
50957 XXC(5)=1D6
50958 ELSEIF(XXC(6).LT.AXMI) THEN
50959 XXC(6)=1D6
50960 ENDIF
50961 XXC(7)=XXC(6)
50962 XXC(8)=XXC(5)
50963 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
50964 LKNT=LKNT+1
50965 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
50966 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50967 IDLAM(LKNT,1)=KFCCHI(IJ)
50968 IDLAM(LKNT,2)=11
50969 IDLAM(LKNT,3)=-12
50970 LKNT=LKNT+1
50971 XLAM(LKNT)=XLAM(LKNT-1)
50972 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50973 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50974 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50975 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
50976 LKNT=LKNT+1
50977 XLAM(LKNT)=XLAM(LKNT-1)
50978 IDLAM(LKNT,1)=KFCCHI(IJ)
50979 IDLAM(LKNT,2)=13
50980 IDLAM(LKNT,3)=-14
50981 LKNT=LKNT+1
50982 XLAM(LKNT)=XLAM(LKNT-1)
50983 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50984 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50985 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50986 ENDIF
50987 ENDIF
50988 230 CONTINUE
50989 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
50990 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
50991 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50992 ELSE
50993 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
50994 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
50995 ENDIF
50996 IF(XXC(5).LT.AXMI) THEN
50997 XXC(5)=1D6
50998 ENDIF
50999 IF(XXC(6).LT.AXMI) THEN
51000 XXC(6)=1D6
51001 ENDIF
51002 XXC(7)=XXC(6)
51003 XXC(8)=XXC(5)
51004 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51005 LKNT=LKNT+1
51006 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51007 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51008 XLAM(LKNT)=XLAM(LKNT-1)
51009 IDLAM(LKNT,1)=KFCCHI(IJ)
51010 IDLAM(LKNT,2)=15
51011 IDLAM(LKNT,3)=-16
51012 LKNT=LKNT+1
51013 XLAM(LKNT)=XLAM(LKNT-1)
51014 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51015 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51016 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51017 ENDIF
51018
51019C...NOW, DO THE QUARKS
51020 240 CONTINUE
51021 IA=1
51022 JA=2
51023 EI=KCHG(IA,1)/3D0
51024 T3I=SIGN(1D0,EI+1D-6)/2D0
51025 EJ=KCHG(JA,1)/3D0
51026 T3J=SIGN(1D0,EJ+1D-6)/2D0
51027 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51028 & TANW+ZMIXC(IX,2)*T3J)
51029 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51030 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
51031 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51032 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
51033 IF(XXC(5).LT.AXMI) THEN
51034 XXC(5)=1D6
51035 ENDIF
51036 IF(XXC(6).LT.AXMI) THEN
51037 XXC(6)=1D6
51038 ENDIF
51039 XXC(7)=XXC(6)
51040 XXC(8)=XXC(5)
51041 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
51042 LKNT=LKNT+1
51043 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51044 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51045 IDLAM(LKNT,1)=KFCCHI(IJ)
51046 IDLAM(LKNT,2)=1
51047 IDLAM(LKNT,3)=-2
51048 LKNT=LKNT+1
51049 XLAM(LKNT)=XLAM(LKNT-1)
51050 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51051 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51052 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51053 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51054 LKNT=LKNT+1
51055 XLAM(LKNT)=XLAM(LKNT-1)
51056 IDLAM(LKNT,1)=KFCCHI(IJ)
51057 IDLAM(LKNT,2)=3
51058 IDLAM(LKNT,3)=-4
51059 LKNT=LKNT+1
51060 XLAM(LKNT)=XLAM(LKNT-1)
51061 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51062 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51063 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51064 ENDIF
51065 ENDIF
51066 250 CONTINUE
51067 ENDIF
51068 260 CONTINUE
51069 270 CONTINUE
51070
51071C...CHI0_I -> CHI+_I + H-
51072 DO 280 IJ=1,2
51073 XMJ=SMW(IJ)
51074 AXMJ=ABS(XMJ)
51075 XMJ2=XMJ**2
51076 XMHP=PMAS(ITHC,1)
51077 IF(AXMI.GE.AXMJ+XMHP) THEN
51078 LKNT=LKNT+1
51079 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
51080 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
51081 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
51082 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
51083 & UMIXC(IJ,2)/SR2)
51084 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51085 GLR=DBLE(OLPP*DCONJG(ORPP))
51086 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51087 IDLAM(LKNT,1)=KFCCHI(IJ)
51088 IDLAM(LKNT,2)=-ITHC
51089 IDLAM(LKNT,3)=0
51090 LKNT=LKNT+1
51091 XLAM(LKNT)=XLAM(LKNT-1)
51092 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51093 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51094 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51095 ELSE
51096
51097 ENDIF
51098 280 CONTINUE
51099
51100C...2-BODY DECAYS TO FERMION SFERMION
51101 DO 290 J=1,16
51102 IF(J.GE.7.AND.J.LE.10) GOTO 290
51103 KF1=KSUSY1+J
51104 KF2=KSUSY2+J
51105 XMSF1=PMAS(PYCOMP(KF1),1)
51106 XMSF2=PMAS(PYCOMP(KF2),1)
51107 XMF=PMAS(J,1)
51108 IF(J.LE.6) THEN
51109 FCOL=3D0
51110 ELSE
51111 FCOL=1D0
51112 ENDIF
51113
51114 EI=KCHG(J,1)/3D0
51115 T3T=SIGN(1D0,EI)
51116 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
51117 IF(MOD(J,2).EQ.0) THEN
51118 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51119 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
51120 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51121 CBR=CAL
51122 ELSE
51123 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
51124 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
51125 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
51126 CBR=CAL
51127 ENDIF
51128
51129C...D~ D_L
51130 IF(AXMI.GE.XMF+XMSF1) THEN
51131 LKNT=LKNT+1
51132 XMA2=XMSF1**2
51133 XMB2=XMF**2
51134 XL=PYLAMF(XMI2,XMA2,XMB2)
51135 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
51136 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
51137 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51138 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51139 IDLAM(LKNT,1)=KF1
51140 IDLAM(LKNT,2)=-J
51141 IDLAM(LKNT,3)=0
51142 LKNT=LKNT+1
51143 XLAM(LKNT)=XLAM(LKNT-1)
51144 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51145 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51146 IDLAM(LKNT,3)=0
51147 ENDIF
51148
51149C...D~ D_R
51150 IF(AXMI.GE.XMF+XMSF2) THEN
51151 LKNT=LKNT+1
51152 XMA2=XMSF2**2
51153 XMB2=XMF**2
51154 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
51155 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
51156 XL=PYLAMF(XMI2,XMA2,XMB2)
51157 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51158 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51159 IDLAM(LKNT,1)=KF2
51160 IDLAM(LKNT,2)=-J
51161 IDLAM(LKNT,3)=0
51162 LKNT=LKNT+1
51163 XLAM(LKNT)=XLAM(LKNT-1)
51164 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51165 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51166 IDLAM(LKNT,3)=0
51167 ENDIF
51168 290 CONTINUE
51169 300 CONTINUE
51170C...3-BODY DECAY TO Q Q~ GLUINO
51171 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51172 IF(AXMI.GE.XMJ) THEN
51173 RT2I = 1D0/SQRT(2D0)
51174 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
51175 ORPP=DCONJG(OLPP)
51176 AXMJ=ABS(XMJ)
51177 XXC(1)=0D0
51178 XXC(2)=XMJ
51179 XXC(3)=0D0
51180 XXC(4)=XMI
51181 FID=1
51182 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51183 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51184 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
51185 XXC(7)=XXC(5)
51186 XXC(8)=XXC(6)
51187 XXC(9)=1D6
51188 XXC(10)=0D0
51189 EI=KCHG(FID,1)/3D0
51190 T3I=SIGN(1D0,EI+1D-6)/2D0
51191 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51192 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51193 CXC(1)=0D0
51194 CXC(2)=-GLIJ
51195 CXC(3)=0D0
51196 CXC(4)=DCONJG(GLIJ)
51197 CXC(5)=0D0
51198 CXC(6)=GRIJ
51199 CXC(7)=0D0
51200 CXC(8)=-DCONJG(GRIJ)
51201 S12MIN=0D0
51202 S12MAX=(AXMI-AXMJ)**2
51203C...ALL QUARKS BUT T
51204 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51205 LKNT=LKNT+1
51206 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51207 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51208 IDLAM(LKNT,1)=KSUSY1+21
51209 IDLAM(LKNT,2)=1
51210 IDLAM(LKNT,3)=-1
51211 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51212 LKNT=LKNT+1
51213 XLAM(LKNT)=XLAM(LKNT-1)
51214 IDLAM(LKNT,1)=KSUSY1+21
51215 IDLAM(LKNT,2)=3
51216 IDLAM(LKNT,3)=-3
51217 ENDIF
51218 ENDIF
51219 310 CONTINUE
51220 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51221 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51222 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51223 ELSE
51224 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51225 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51226 ENDIF
51227 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
51228 XXC(7)=XXC(5)
51229 XXC(8)=XXC(6)
51230 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51231 LKNT=LKNT+1
51232 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51233 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51234 IDLAM(LKNT,1)=KSUSY1+21
51235 IDLAM(LKNT,2)=5
51236 IDLAM(LKNT,3)=-5
51237 ENDIF
51238C...U-TYPE QUARKS
51239 320 CONTINUE
51240 FID=2
51241 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51242 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51243 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
51244 XXC(7)=XXC(5)
51245 XXC(8)=XXC(6)
51246 EI=KCHG(FID,1)/3D0
51247 T3I=SIGN(1D0,EI+1D-6)/2D0
51248 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51249 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51250 CXC(2)=-GLIJ
51251 CXC(4)=DCONJG(GLIJ)
51252 CXC(6)=GRIJ
51253 CXC(8)=-DCONJG(GRIJ)
51254 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51255 LKNT=LKNT+1
51256 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51257 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51258 IDLAM(LKNT,1)=KSUSY1+21
51259 IDLAM(LKNT,2)=2
51260 IDLAM(LKNT,3)=-2
51261 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51262 LKNT=LKNT+1
51263 XLAM(LKNT)=XLAM(LKNT-1)
51264 IDLAM(LKNT,1)=KSUSY1+21
51265 IDLAM(LKNT,2)=4
51266 IDLAM(LKNT,3)=-4
51267 ENDIF
51268 ENDIF
51269 330 CONTINUE
51270 ENDIF
51271
51272C...R-violating decay modes (SKANDS).
51273 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
51274
51275 340 IKNT=LKNT
51276 XLAM(0)=0D0
51277 DO 350 I=1,IKNT
51278 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51279 XLAM(0)=XLAM(0)+XLAM(I)
51280 350 CONTINUE
51281 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51282
51283 RETURN
51284 END
51285
51286C*********************************************************************
51287
51288C...PYCJDC
51289C...Calculate decay widths for the charginos (admixtures of
51290C...charged Wino and charged Higgsino.
51291
51292C...Input: KCIN = KF code for particle
51293C...Output: XLAM = widths
51294C... IDLAM = KF codes for decay particles
51295C... IKNT = number of decay channels defined
51296C...AUTHOR: STEPHEN MRENNA
51297C...Last change:
51298C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
51299C...when CHIENU .NE. 0
51300
51301 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
51302
51303C...Double precision and integer declarations.
51304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51305 IMPLICIT INTEGER(I-N)
51306 INTEGER PYK,PYCHGE,PYCOMP
51307C...Parameter statement to help give large particle numbers.
51308 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51309 &KEXCIT=4000000,KDIMEN=5000000)
51310C...Commonblocks.
51311 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51312 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51313 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51314 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51315 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51316CC &SFMIX(16,4),
51317C COMMON/PYINTS/XXM(20)
51318 COMPLEX*16 CXC
51319 COMMON/PYINTC/XXC(10),CXC(8)
51320 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51321
51322C...Local variables
51323 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
51324 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
51325 INTEGER KFIN,KCIN
51326 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51327 &XMZ,XMZ2,AXMJ,AXMI
51328 DOUBLE PRECISION S12MIN,S12MAX
51329 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
51330 DOUBLE PRECISION PYLAMF,XL
51331 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
51332 DOUBLE PRECISION PYX2XH,PYX2XG
51333 DOUBLE PRECISION XLAM(0:400)
51334 INTEGER IDLAM(400,3)
51335 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
51336 INTEGER ITH(3)
51337 INTEGER ITHC
51338 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
51339 DOUBLE PRECISION SR2
51340 DOUBLE PRECISION CBETA,SBETA,TANB
51341
51342 DOUBLE PRECISION PYALEM,PI,PYALPS
51343 DOUBLE PRECISION FCOL
51344 INTEGER KF1,KF2,ISF
51345 INTEGER KFNCHI(4),KFCCHI(2)
51346
51347 DOUBLE PRECISION TEMP
51348 EXTERNAL PYGAUS,PYXXZ6
51349 DOUBLE PRECISION PYGAUS,PYXXZ6
51350 DOUBLE PRECISION PREC
51351 DATA ITH/25,35,36/
51352 DATA ITHC/37/
51353 DATA ETAH/1D0,1D0,-1D0/
51354 DATA SR2/1.4142136D0/
51355 DATA PI/3.141592654D0/
51356 DATA PREC/1D-2/
51357 DATA KFNCHI/1000022,1000023,1000025,1000035/
51358 DATA KFCCHI/1000024,1000037/
51359
51360C...COUNT THE NUMBER OF DECAY MODES
51361 LKNT=0
51362 XMW=PMAS(24,1)
51363 XMW2=XMW**2
51364 XMZ=PMAS(23,1)
51365 XMZ2=XMZ**2
51366 XW=1D0-XMW2/XMZ2
51367 XW1=1D0-XW
51368 TANW = SQRT(XW/XW1)
51369
51370C...1 OR 2 DEPENDING ON CHARGINO TYPE
51371 IX=1
51372 IF(KFIN.EQ.KFCCHI(2)) IX=2
51373 KCIN=PYCOMP(KFIN)
51374
51375 XMI=SMW(IX)
51376 XMI2=XMI**2
51377 AXMI=ABS(XMI)
51378 AEM=PYALEM(XMI2)
51379 AS =PYALPS(XMI2)
51380 C1=AEM/XW
51381 XMI3=ABS(XMI**3)
51382 TANB=RMSS(5)
51383 BETA=ATAN(TANB)
51384 CBETA=COS(BETA)
51385 SBETA=TANB*CBETA
51386 ALFA=RMSS(18)
51387
51388 DO 110 I=1,2
51389 DO 100 J=1,2
51390 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51391 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51392 100 CONTINUE
51393 110 CONTINUE
51394
51395C...GRAVITINO DECAY MODES
51396
51397 IF(IMSS(11).EQ.1) THEN
51398 XMP=RMSS(29)
51399 IDG=39+KSUSY1
51400 XMGR=PMAS(PYCOMP(IDG),1)
51401C SINW=SQRT(XW)
51402C COSW=SQRT(1D0-XW)
51403 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51404 IF(AXMI.GT.XMGR+XMW) THEN
51405 LKNT=LKNT+1
51406 IDLAM(LKNT,1)=IDG
51407 IDLAM(LKNT,2)=24
51408 IDLAM(LKNT,3)=0
51409 XLAM(LKNT)=XFAC*(
51410 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
51411 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
51412 & (1D0-XMW2/XMI2)**4
51413 ENDIF
51414 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
51415 LKNT=LKNT+1
51416 IDLAM(LKNT,1)=IDG
51417 IDLAM(LKNT,2)=37
51418 IDLAM(LKNT,3)=0
51419 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
51420 & (ABS(UMIXC(IX,2))*SBETA)**2))
51421 & *(1D0-PMAS(37,1)**2/XMI2)**4
51422 ENDIF
51423 ENDIF
51424
51425C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51426 IF(IX.EQ.1) GOTO 170
51427 XMJ=SMW(1)
51428 AXMJ=ABS(XMJ)
51429 XMJ2=XMJ**2
51430
51431C...CHI_2+ -> CHI_1+ + Z0
51432 IF(AXMI.GE.AXMJ+XMZ) THEN
51433 LKNT=LKNT+1
51434 IJ=1
51435 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51436 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51437 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51438 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51439 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51440 GLR=DBLE(OLPP*DCONJG(ORPP))
51441 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51442 IDLAM(LKNT,1)=KFCCHI(1)
51443 IDLAM(LKNT,2)=23
51444 IDLAM(LKNT,3)=0
51445
51446C...CHARGED LEPTONS
51447 ELSEIF(AXMI.GE.AXMJ) THEN
51448 S12MIN=0D0
51449 S12MAX=(AXMI-AXMJ)**2
51450 IA=11
51451 JA=12
51452 EI=KCHG(IABS(IA),1)/3D0
51453 T3I=SIGN(1D0,EI+1D-6)/2D0
51454 XXC(1)=0D0
51455 XXC(2)=XMJ
51456 XXC(3)=0D0
51457 XXC(4)=XMI
51458 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51459 XXC(6)=1D6
51460 XXC(9)=PMAS(23,1)
51461 XXC(10)=PMAS(23,2)
51462 IJ=1
51463 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
51464 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
51465 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
51466 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
51467 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51468 CXC(2)=DCMPLX(0D0,0D0)
51469 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51470 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51471 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51472 CXC(6)=DCMPLX(0D0,0D0)
51473 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51474 CXC(8)=DCMPLX(0D0,0D0)
51475 IF( XXC(5).LT.AXMI ) THEN
51476 XXC(5)=1D6
51477 ENDIF
51478 XXC(7)=XXC(5)
51479 XXC(8)=XXC(6)
51480 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51481 LKNT=LKNT+1
51482 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51483 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51484 IDLAM(LKNT,1)=KFCCHI(1)
51485 IDLAM(LKNT,2)=11
51486 IDLAM(LKNT,3)=-11
51487 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51488 LKNT=LKNT+1
51489 XLAM(LKNT)=XLAM(LKNT-1)
51490 IDLAM(LKNT,1)=KFCCHI(1)
51491 IDLAM(LKNT,2)=13
51492 IDLAM(LKNT,3)=-13
51493 ENDIF
51494 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51495 LKNT=LKNT+1
51496 XLAM(LKNT)=XLAM(LKNT-1)
51497 IDLAM(LKNT,1)=KFCCHI(1)
51498 IDLAM(LKNT,2)=15
51499 IDLAM(LKNT,3)=-15
51500 ENDIF
51501 ENDIF
51502
51503C...NEUTRINOS
51504 120 CONTINUE
51505 IA=12
51506 JA=11
51507 EI=KCHG(IABS(IA),1)/3D0
51508 T3I=SIGN(1D0,EI+1D-6)/2D0
51509 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51510 XXC(6)=1D6
51511 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51512 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51513 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51514 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51515 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51516 IF( XXC(5).LT.AXMI ) THEN
51517 XXC(5)=1D6
51518 ENDIF
51519 XXC(7)=XXC(5)
51520 XXC(8)=XXC(6)
51521 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
51522 LKNT=LKNT+1
51523 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51524 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51525 IDLAM(LKNT,1)=KFCCHI(1)
51526 IDLAM(LKNT,2)=12
51527 IDLAM(LKNT,3)=-12
51528 LKNT=LKNT+1
51529 XLAM(LKNT)=XLAM(LKNT-1)
51530 IDLAM(LKNT,1)=KFCCHI(1)
51531 IDLAM(LKNT,2)=14
51532 IDLAM(LKNT,3)=-14
51533 ENDIF
51534 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
51535 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51536 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51537 ELSE
51538 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51539 ENDIF
51540 IF( XXC(5).LT.AXMI ) THEN
51541 XXC(5)=1D6
51542 ENDIF
51543 XXC(7)=XXC(5)
51544 LKNT=LKNT+1
51545 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51547 IDLAM(LKNT,1)=KFCCHI(1)
51548 IDLAM(LKNT,2)=16
51549 IDLAM(LKNT,3)=-16
51550 ENDIF
51551
51552C...D-TYPE QUARKS
51553 130 CONTINUE
51554 IA=1
51555 JA=2
51556 EI=KCHG(IABS(IA),1)/3D0
51557 T3I=SIGN(1D0,EI+1D-6)/2D0
51558 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51559 XXC(6)=1D6
51560 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51561 CXC(2)=DCMPLX(0D0,0D0)
51562 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51563 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
51564 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51565 CXC(6)=DCMPLX(0D0,0D0)
51566 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51567 CXC(8)=DCMPLX(0D0,0D0)
51568 IF( XXC(5).LT.AXMI ) THEN
51569 XXC(5)=1D6
51570 ENDIF
51571 XXC(7)=XXC(5)
51572 XXC(8)=XXC(6)
51573 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51574 LKNT=LKNT+1
51575 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51576 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51577 IDLAM(LKNT,1)=KFCCHI(1)
51578 IDLAM(LKNT,2)=1
51579 IDLAM(LKNT,3)=-1
51580 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51581 LKNT=LKNT+1
51582 XLAM(LKNT)=XLAM(LKNT-1)
51583 IDLAM(LKNT,1)=KFCCHI(1)
51584 IDLAM(LKNT,2)=3
51585 IDLAM(LKNT,3)=-3
51586 ENDIF
51587 ENDIF
51588 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51589 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51590 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51591 ELSE
51592 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51593 ENDIF
51594 IF( XXC(5).LT.AXMI ) THEN
51595 XXC(5)=1D6
51596 ENDIF
51597 XXC(7)=XXC(5)
51598 LKNT=LKNT+1
51599 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51600 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51601 IDLAM(LKNT,1)=KFCCHI(1)
51602 IDLAM(LKNT,2)=5
51603 IDLAM(LKNT,3)=-5
51604 ENDIF
51605
51606C...U-TYPE QUARKS
51607 140 CONTINUE
51608 IA=2
51609 JA=1
51610 EI=KCHG(IABS(IA),1)/3D0
51611 T3I=SIGN(1D0,EI+1D-6)/2D0
51612 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51613 XXC(6)=1D6
51614 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
51615 CXC(2)=DCMPLX(0D0,0D0)
51616 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
51617 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
51618 CXC(5)=-DCMPLX(EI/XW1)*ORPP
51619 CXC(6)=DCMPLX(0D0,0D0)
51620 CXC(7)=-DCMPLX(EI/XW1)*OLPP
51621 CXC(8)=DCMPLX(0D0,0D0)
51622 IF( XXC(5).LT.AXMI ) THEN
51623 XXC(5)=1D6
51624 ENDIF
51625 XXC(7)=XXC(5)
51626 XXC(8)=XXC(6)
51627 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51628 LKNT=LKNT+1
51629 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51630 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51631 IDLAM(LKNT,1)=KFCCHI(1)
51632 IDLAM(LKNT,2)=2
51633 IDLAM(LKNT,3)=-2
51634 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51635 LKNT=LKNT+1
51636 XLAM(LKNT)=XLAM(LKNT-1)
51637 IDLAM(LKNT,1)=KFCCHI(1)
51638 IDLAM(LKNT,2)=4
51639 IDLAM(LKNT,3)=-4
51640 ENDIF
51641 ENDIF
51642 150 CONTINUE
51643 ENDIF
51644
51645C...CHI_2+ -> CHI_1+ + H0_K
51646 EH(2)=COS(ALFA)
51647 EH(1)=SIN(ALFA)
51648 EH(3)=-SBETA
51649 DH(2)=-SIN(ALFA)
51650 DH(1)=COS(ALFA)
51651 DH(3)=COS(BETA)
51652 DO 160 IH=1,3
51653 XMH=PMAS(ITH(IH),1)
51654 XMH2=XMH**2
51655C...NO 3-BODY OPTION
51656 IF(AXMI.GE.AXMJ+XMH) THEN
51657 LKNT=LKNT+1
51658 XL=PYLAMF(XMI2,XMJ2,XMH2)
51659 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
51660 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
51661 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
51662 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
51663 XMK=XMJ*ETAH(IH)
51664 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51665 GLR=DBLE(OLPP*DCONJG(ORPP))
51666 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51667 IDLAM(LKNT,1)=KFCCHI(1)
51668 IDLAM(LKNT,2)=ITH(IH)
51669 IDLAM(LKNT,3)=0
51670 ENDIF
51671 160 CONTINUE
51672
51673C...CHI1 JUMPS TO HERE
51674 170 CONTINUE
51675
51676C...CHI+_I -> CHI0_J + W+
51677 DO 220 IJ=1,4
51678 XMJ=SMZ(IJ)
51679 AXMJ=ABS(XMJ)
51680 XMJ2=XMJ**2
51681 IF(AXMI.GE.AXMJ+XMW) THEN
51682 LKNT=LKNT+1
51683 DO 180 I=1,4
51684 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51685 180 CONTINUE
51686 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51687 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
51688 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51689 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
51690 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51691 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51692 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51693 IDLAM(LKNT,1)=KFNCHI(IJ)
51694 IDLAM(LKNT,2)=24
51695 IDLAM(LKNT,3)=0
51696C...LEPTONS
51697 ELSEIF(AXMI.GE.AXMJ) THEN
51698 S12MIN=0D0
51699 S12MAX=(AXMI-AXMJ)**2
51700 DO 190 I=1,4
51701 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
51702 190 CONTINUE
51703 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
51704 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
51705 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
51706 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
51707 CXC(5)=DCMPLX(0D0,0D0)
51708 CXC(7)=DCMPLX(0D0,0D0)
51709 IA=11
51710 JA=12
51711 EI=KCHG(IA,1)/3D0
51712 T3I=SIGN(1D0,EI+1D-6)/2D0
51713 EJ=KCHG(JA,1)/3D0
51714 T3J=SIGN(1D0,EJ+1D-6)/2D0
51715 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51716 & TANW+ZMIXC(IJ,2)*T3J)/SR2
51717 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51718 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
51719 CXC(6)=DCMPLX(0D0,0D0)
51720 CXC(8)=DCMPLX(0D0,0D0)
51721 XXC(1)=0D0
51722 XXC(2)=XMJ
51723 XXC(3)=0D0
51724 XXC(4)=XMI
51725 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51726 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51727 XXC(9)=PMAS(24,1)
51728 XXC(10)=PMAS(24,2)
51729CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51730 IF(XXC(5).LT.AXMI) THEN
51731 XXC(5)=1D6
51732 ELSEIF(XXC(6).LT.AXMI) THEN
51733 XXC(6)=1D6
51734 ENDIF
51735 XXC(7)=XXC(6)
51736 XXC(8)=XXC(5)
51737C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
51738C...--> 1/(16PI)/M**3*(AEM/XW)**2
51739 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51740 LKNT=LKNT+1
51741 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51742 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51743 IDLAM(LKNT,1)=KFNCHI(IJ)
51744 IDLAM(LKNT,2)=-11
51745 IDLAM(LKNT,3)=12
51746C...ONLY DECAY CHI+1 -> E+ NU_E
51747 IF( IMSS(12).NE. 0 ) GOTO 260
51748 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51749 LKNT=LKNT+1
51750 XLAM(LKNT)=XLAM(LKNT-1)
51751 IDLAM(LKNT,1)=KFNCHI(IJ)
51752 IDLAM(LKNT,2)=-13
51753 IDLAM(LKNT,3)=14
51754 ENDIF
51755 ENDIF
51756 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51757 LKNT=LKNT+1
51758 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51759 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51760 ELSE
51761 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51762 ENDIF
51763 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51764 IF(XXC(5).LT.AXMI) THEN
51765 XXC(5)=1D6
51766 ELSEIF(XXC(6).LT.AXMI) THEN
51767 XXC(6)=1D6
51768 ENDIF
51769 XXC(7)=XXC(6)
51770 XXC(8)=XXC(5)
51771 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51772 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
51773 IDLAM(LKNT,1)=KFNCHI(IJ)
51774 IDLAM(LKNT,2)=-15
51775 IDLAM(LKNT,3)=16
51776 ENDIF
51777
51778C...NOW, DO THE QUARKS
51779 200 CONTINUE
51780 IA=1
51781 JA=2
51782 EI=KCHG(IA,1)/3D0
51783 T3I=SIGN(1D0,EI+1D-6)/2D0
51784 EJ=KCHG(JA,1)/3D0
51785 T3J=SIGN(1D0,EJ+1D-6)/2D0
51786 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
51787 & TANW+ZMIXC(IJ,2)*T3J)
51788 CXC(4)=-DCONJG(UMIXC(IX,1))*(
51789 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
51790 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51791 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51792 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
51793 IF(XXC(5).LT.AXMI) THEN
51794 XXC(5)=1D6
51795 ENDIF
51796 IF(XXC(6).LT.AXMI) THEN
51797 XXC(6)=1D6
51798 ENDIF
51799 XXC(7)=XXC(6)
51800 XXC(8)=XXC(5)
51801 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51802 LKNT=LKNT+1
51803 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
51804 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51805 IDLAM(LKNT,1)=KFNCHI(IJ)
51806 IDLAM(LKNT,2)=-1
51807 IDLAM(LKNT,3)=2
51808 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51809 LKNT=LKNT+1
51810 XLAM(LKNT)=XLAM(LKNT-1)
51811 IDLAM(LKNT,1)=KFNCHI(IJ)
51812 IDLAM(LKNT,2)=-3
51813 IDLAM(LKNT,3)=4
51814 ENDIF
51815 ENDIF
51816 210 CONTINUE
51817 ENDIF
51818 220 CONTINUE
51819
51820C...CHI+_I -> CHI0_J + H+
51821 DO 230 IJ=1,4
51822 XMJ=SMZ(IJ)
51823 AXMJ=ABS(XMJ)
51824 XMJ2=XMJ**2
51825 XMHP=PMAS(ITHC,1)
51826 IF(AXMI.GE.AXMJ+XMHP) THEN
51827 LKNT=LKNT+1
51828 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
51829 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
51830 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
51831 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
51832 & UMIXC(IX,2)/SR2)
51833 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51834 GLR=DBLE(OLPP*DCONJG(ORPP))
51835 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
51836 IDLAM(LKNT,1)=KFNCHI(IJ)
51837 IDLAM(LKNT,2)=ITHC
51838 IDLAM(LKNT,3)=0
51839 ELSE
51840
51841 ENDIF
51842 230 CONTINUE
51843
51844C...2-BODY DECAYS TO FERMION SFERMION
51845 DO 240 J=1,16
51846 IF(J.GE.7.AND.J.LE.10) GOTO 240
51847 IF(MOD(J,2).EQ.0) THEN
51848 KF1=KSUSY1+J-1
51849 ELSE
51850 KF1=KSUSY1+J+1
51851 ENDIF
51852 KF2=KF1+KSUSY1
51853 XMSF1=PMAS(PYCOMP(KF1),1)
51854 XMSF2=PMAS(PYCOMP(KF2),1)
51855 XMF=PMAS(J,1)
51856 IF(J.LE.6) THEN
51857 FCOL=3D0
51858 ELSE
51859 FCOL=1D0
51860 ENDIF
51861
51862C...U~ D_L
51863 IF(MOD(J,2).EQ.0) THEN
51864 XMFP=PMAS(J-1,1)
51865 CAL=UMIXC(IX,1)
51866 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
51867 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
51868 CBR=0D0
51869 ISF=J-1
51870 ELSE
51871 XMFP=PMAS(J+1,1)
51872 CAL=VMIXC(IX,1)
51873 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
51874 CBR=0D0
51875 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
51876 ISF=J+1
51877 ENDIF
51878
51879C...~U_L D
51880 IF(AXMI.GE.XMF+XMSF1) THEN
51881 LKNT=LKNT+1
51882 XMA2=XMSF1**2
51883 XMB2=XMF**2
51884 XL=PYLAMF(XMI2,XMA2,XMB2)
51885 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
51886 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
51887 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51888 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51889 IDLAM(LKNT,3)=0
51890 IF(MOD(J,2).EQ.0) THEN
51891 IDLAM(LKNT,1)=-KF1
51892 IDLAM(LKNT,2)=J
51893 ELSE
51894 IDLAM(LKNT,1)=KF1
51895 IDLAM(LKNT,2)=-J
51896 ENDIF
51897 ENDIF
51898
51899C...U~ D_R
51900 IF(AXMI.GE.XMF+XMSF2) THEN
51901 LKNT=LKNT+1
51902 XMA2=XMSF2**2
51903 XMB2=XMF**2
51904 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
51905 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
51906 XL=PYLAMF(XMI2,XMA2,XMB2)
51907 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
51908 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
51909 IDLAM(LKNT,3)=0
51910 IF(MOD(J,2).EQ.0) THEN
51911 IDLAM(LKNT,1)=-KF2
51912 IDLAM(LKNT,2)=J
51913 ELSE
51914 IDLAM(LKNT,1)=KF2
51915 IDLAM(LKNT,2)=-J
51916 ENDIF
51917 ENDIF
51918 240 CONTINUE
51919
51920C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
51921C...A 2-BODY -- 2-BODY CHAIN
51922 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51923 IF(AXMI.GE.XMJ) THEN
51924 AXMJ=ABS(XMJ)
51925 S12MIN=0D0
51926 S12MAX=(AXMI-AXMJ)**2
51927 XXC(1)=0D0
51928 XXC(2)=XMJ
51929 XXC(3)=0D0
51930 XXC(4)=XMI
51931 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51932 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51933 XXC(9)=1D6
51934 XXC(10)=0D0
51935 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51936 ORPP=DCONJG(OLPP)
51937 CXC(1)=DCMPLX(0D0,0D0)
51938 CXC(3)=DCMPLX(0D0,0D0)
51939 CXC(5)=DCMPLX(0D0,0D0)
51940 CXC(7)=DCMPLX(0D0,0D0)
51941 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51942 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51943 CXC(6)=DCMPLX(0D0,0D0)
51944 CXC(8)=DCMPLX(0D0,0D0)
51945 IF(XXC(5).LT.AXMI) THEN
51946 XXC(5)=1D6
51947 ELSEIF(XXC(6).LT.AXMI) THEN
51948 XXC(6)=1D6
51949 ENDIF
51950 XXC(7)=XXC(6)
51951 XXC(8)=XXC(5)
51952 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
51953 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51954 LKNT=LKNT+1
51955 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
51956 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51957 IDLAM(LKNT,1)=KSUSY1+21
51958 IDLAM(LKNT,2)=-1
51959 IDLAM(LKNT,3)=2
51960 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51961 LKNT=LKNT+1
51962 XLAM(LKNT)=XLAM(LKNT-1)
51963 IDLAM(LKNT,1)=KSUSY1+21
51964 IDLAM(LKNT,2)=-3
51965 IDLAM(LKNT,3)=4
51966 ENDIF
51967 ENDIF
51968 250 CONTINUE
51969 ENDIF
51970
51971C...R-violating decay modes (SKANDS).
51972 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
51973
51974 260 IKNT=LKNT
51975 XLAM(0)=0D0
51976 DO 270 I=1,IKNT
51977 XLAM(0)=XLAM(0)+XLAM(I)
51978 IF(XLAM(I).LT.0D0) THEN
51979 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
51980 & (IDLAM(I,J),J=1,3)
51981 XLAM(I)=0D0
51982 ENDIF
51983 270 CONTINUE
51984 IF(XLAM(0).EQ.0D0) THEN
51985 XLAM(0)=1D-6
51986 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
51987 WRITE(MSTU(11),*) LKNT
51988 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
51989 ENDIF
51990
51991 RETURN
51992 END
51993
51994C*********************************************************************
51995
51996C...PYXXZ6
51997C...Used in the calculation of inoi -> inoj + f + ~f.
51998
51999 FUNCTION PYXXZ6(X)
52000
52001C...Double precision and integer declarations.
52002 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52003 IMPLICIT INTEGER(I-N)
52004 INTEGER PYK,PYCHGE,PYCOMP
52005C...Parameter statement to help give large particle numbers.
52006 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52007 &KEXCIT=4000000,KDIMEN=5000000)
52008C...Commonblocks.
52009 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52010C COMMON/PYINTS/XXM(20)
52011 COMPLEX*16 CXC
52012 COMMON/PYINTC/XXC(10),CXC(8)
52013 SAVE /PYDAT1/,/PYINTC/
52014
52015C...Local variables.
52016 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
52017 DOUBLE PRECISION PYXXZ6,X
52018 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
52019 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
52020 DOUBLE PRECISION SIJ
52021 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
52022 DOUBLE PRECISION OL2
52023 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
52024 INTEGER I
52025
52026C...Statement functions.
52027C...Integral from x to y of (t-a)(b-t) dt.
52028 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
52029C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
52030 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
52031 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
52032C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
52033 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
52034 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
52035C...Integral from x to y of (t-a)/(b-t) dt.
52036 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
52037C...Integral from x to y of 1/(t-a) dt.
52038 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
52039
52040 XM12=XXC(1)**2
52041 XM22=XXC(2)**2
52042 XM32=XXC(3)**2
52043 S=XXC(4)**2
52044 S13=X
52045
52046 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
52047 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
52048 &( (X-XM22-S)**2 -4D0*XM22*S ) )
52049
52050 S23MIN=(S23AVE-S23DEL)
52051 S23MAX=(S23AVE+S23DEL)
52052
52053 XMSD1=XXC(5)**2
52054 XMSD2=XXC(7)**2
52055 XMSU1=XXC(6)**2
52056 XMSU2=XXC(8)**2
52057
52058 XMV=XXC(9)
52059 XMG=XXC(10)
52060 QLLS=CXC(1)
52061 QLLU=CXC(2)
52062 QLRS=CXC(3)
52063 QLRT=CXC(4)
52064 QRLS=CXC(5)
52065 QRLT=CXC(6)
52066 QRRS=CXC(7)
52067 QRRU=CXC(8)
52068 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
52069 SIJ=2D0*XXC(2)*XXC(4)*S13
52070 IF(XMV.LE.1000D0) THEN
52071 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
52072 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
52073 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
52074 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
52075 IF(XXC(5).LE.10000D0) THEN
52076 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
52077 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
52078 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
52079 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
52080 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
52081 & *(S13-XMV**2)/WPROP2
52082 ELSE
52083 WFL1=0D0
52084 ENDIF
52085
52086 IF(XXC(6).LE.10000D0) THEN
52087 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
52088 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
52089 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
52090 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
52091 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
52092 & *(S13-XMV**2)/WPROP2
52093 ELSE
52094 WFL2=0D0
52095 ENDIF
52096 ELSE
52097 WW=0D0
52098 WFL1=0D0
52099 WFL2=0D0
52100 ENDIF
52101 IF(XXC(5).LE.10000D0) THEN
52102 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
52103 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
52104 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
52105 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
52106 ELSE
52107 WF1=0D0
52108 ENDIF
52109 IF(XXC(6).LE.10000D0) THEN
52110 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
52111 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
52112 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
52113 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
52114 ELSE
52115 WF2=0D0
52116 ENDIF
52117
52118 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
52119
52120 IF(PYXXZ6.LT.0D0) THEN
52121 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
52122 WRITE(MSTU(11),*) (XXC(I),I=1,5)
52123 WRITE(MSTU(11),*) (XXC(I),I=6,10)
52124 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
52125 WRITE(MSTU(11),*) S23MIN,S23MAX
52126 PYXXZ6=0D0
52127 ENDIF
52128
52129 RETURN
52130 END
52131
52132
52133C*********************************************************************
52134
52135C...PYXXGA
52136C...Calculates chi0_i -> chi0_j + gamma.
52137
52138 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
52139
52140C...Double precision and integer declarations.
52141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52142 IMPLICIT INTEGER(I-N)
52143 INTEGER PYK,PYCHGE,PYCOMP
52144
52145C...Local variables.
52146 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
52147 DOUBLE PRECISION F1,F2
52148
52149 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
52150 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
52151 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
52152 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
52153
52154 RETURN
52155 END
52156
52157C*********************************************************************
52158
52159C...PYX2XG
52160C...Calculates the decay rate for ino -> ino + gauge boson.
52161
52162 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
52163
52164C...Double precision and integer declarations.
52165 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52166 IMPLICIT INTEGER(I-N)
52167 INTEGER PYK,PYCHGE,PYCOMP
52168
52169C...Local variables.
52170 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
52171 DOUBLE PRECISION XL,PYLAMF,C1
52172 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52173
52174 XMI2=XM1**2
52175 XMI3=ABS(XM1**3)
52176 XMJ2=XM2**2
52177 XMV2=XM3**2
52178 XL=PYLAMF(XMI2,XMJ2,XMV2)
52179 PYX2XG=C1/8D0/XMI3*SQRT(XL)
52180 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
52181 &12D0*GLR*XM1*XM2*XMV2)
52182
52183 RETURN
52184 END
52185
52186C*********************************************************************
52187
52188C...PYX2XH
52189C...Calculates the decay rate for ino -> ino + H.
52190
52191 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
52192
52193C...Double precision and integer declarations.
52194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52195 IMPLICIT INTEGER(I-N)
52196 INTEGER PYK,PYCHGE,PYCOMP
52197
52198C...Local variables.
52199 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
52200 DOUBLE PRECISION XL,PYLAMF,C1
52201 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
52202
52203 XMI2=XM1**2
52204 XMI3=ABS(XM1**3)
52205 XMJ2=XM2**2
52206 XMV2=XM3**2
52207 XL=PYLAMF(XMI2,XMJ2,XMV2)
52208 PYX2XH=C1/8D0/XMI3*SQRT(XL)
52209 &*(GX2*(XMI2+XMJ2-XMV2)+
52210 &4D0*GLR*XM1*XM2)
52211
52212 RETURN
52213 END
52214
52215C*********************************************************************
52216
52217C...PYHEXT
52218C...Calculates the non-standard decay modes of the Higgs boson.
52219C...
52220C...Author: Stephen Mrenna
52221C...Last Update: April 2001
52222C......Allow complex values for Z,U, and V
52223
52224 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
52225
52226C...Double precision and integer declarations.
52227 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52228 IMPLICIT INTEGER(I-N)
52229 INTEGER PYK,PYCHGE,PYCOMP
52230C...Parameter statement to help give large particle numbers.
52231 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52232 &KEXCIT=4000000,KDIMEN=5000000)
52233C...Commonblocks.
52234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52236 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52237 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52238 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52239 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52240 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
52241
52242C...Local variables.
52243 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52244 COMPLEX*16 QIJ,RIJ,F21K,F12K
52245 INTEGER KFIN
52246 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
52247 DOUBLE PRECISION XMI2,XMI3,XMJ2
52248 DOUBLE PRECISION PYLAMF,XL,CF,EI
52249 INTEGER IDU,IFL
52250 DOUBLE PRECISION TANW,XW,AEM,C1,AS
52251 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
52252 DOUBLE PRECISION XLAM(0:400)
52253 INTEGER IDLAM(400,3)
52254 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
52255 INTEGER ITH(4)
52256 INTEGER KFNCHI(4),KFCCHI(2)
52257 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
52258 DOUBLE PRECISION SR2
52259 DOUBLE PRECISION BETA,ALFA
52260 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
52261 DOUBLE PRECISION PYALEM
52262 DOUBLE PRECISION AL,AR,ALR
52263 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
52264 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
52265 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
52266 DATA ITH/25,35,36,37/
52267 DATA ETAH/1D0,1D0,-1D0/
52268 DATA SR2/1.4142136D0/
52269 DATA KFNCHI/1000022,1000023,1000025,1000035/
52270 DATA KFCCHI/1000024,1000037/
52271
52272C...COUNT THE NUMBER OF DECAY MODES
52273 LKNT=IKNT
52274
52275 XMW=PMAS(24,1)
52276 XMW2=XMW**2
52277 XMZ=PMAS(23,1)
52278 XW=PARU(102)
52279 TANW = SQRT(XW/(1D0-XW))
52280 CW=SQRT(1D0-XW)
52281
52282C...1 - 4 DEPENDING ON Higgs species.
52283 IH=1
52284 IF(KFIN.EQ.ITH(2)) IH=2
52285 IF(KFIN.EQ.ITH(3)) IH=3
52286 IF(KFIN.EQ.ITH(4)) IH=4
52287
52288 XMI=PMAS(KFIN,1)
52289 XMI2=XMI**2
52290 AXMI=ABS(XMI)
52291 AEM=PYALEM(XMI2)
52292 C1=AEM/XW
52293 XMI3=ABS(XMI**3)
52294
52295 TANB=RMSS(5)
52296 BETA=ATAN(TANB)
52297 CBETA=COS(BETA)
52298 SBETA=TANB*CBETA
52299 ALFA=RMSS(18)
52300 COSA=COS(ALFA)
52301 SINA=SIN(ALFA)
52302 ATRIT=RMSS(16)
52303 ATRIB=RMSS(15)
52304 ATRIL=RMSS(17)
52305 XMUZ=-RMSS(4)
52306
52307 DO 110 I=1,4
52308 DO 100 J=1,4
52309 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52310 100 CONTINUE
52311 110 CONTINUE
52312 DO 130 I=1,2
52313 DO 120 J=1,2
52314 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52315 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52316 120 CONTINUE
52317 130 CONTINUE
52318
52319
52320 IF(IH.EQ.4) GOTO 220
52321
52322C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52323C...H0_K -> CHI0_I + CHI0_J
52324 EH(2)=SINA
52325 EH(1)=COSA
52326 EH(3)=CBETA
52327 DH(2)=COSA
52328 DH(1)=-SINA
52329 DH(3)=SBETA
52330 DO 150 IJ=1,4
52331 XMJ=SMZ(IJ)
52332 AXMJ=ABS(XMJ)
52333 DO 140 IK=1,IJ
52334 XMK=SMZ(IK)
52335 AXMK=ABS(XMK)
52336 IF(AXMI.GE.AXMJ+AXMK) THEN
52337 LKNT=LKNT+1
52338 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
52339 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
52340 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
52341 & ZMIXC(IJ,3)*ZMIXC(IK,1))
52342 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
52343 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
52344 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
52345 & ZMIXC(IJ,4)*ZMIXC(IK,1))
52346 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
52347 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
52348C...SIGN OF MASSES I,J
52349 XML=XMK*ETAH(IH)
52350 GX2=ABS(F12K)**2+ABS(F21K)**2
52351 GLR=DBLE(F12K*DCONJG(F21K))
52352 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52353 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
52354 IDLAM(LKNT,1)=KFNCHI(IJ)
52355 IDLAM(LKNT,2)=KFNCHI(IK)
52356 IDLAM(LKNT,3)=0
52357 ENDIF
52358 140 CONTINUE
52359 150 CONTINUE
52360
52361C...H0_K -> CHI+_I CHI-_J
52362 DO 170 IJ=1,2
52363 XMJ=SMW(IJ)
52364 AXMJ=ABS(XMJ)
52365 DO 160 IK=1,2
52366 XMK=SMW(IK)
52367 AXMK=ABS(XMK)
52368 IF(AXMI.GE.AXMJ+AXMK) THEN
52369 LKNT=LKNT+1
52370 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
52371 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
52372 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
52373 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
52374 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52375 GLR=DBLE(OLPP*DCONJG(ORPP))
52376 XML=XMK*ETAH(IH)
52377 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
52378 IDLAM(LKNT,1)=KFCCHI(IJ)
52379 IDLAM(LKNT,2)=-KFCCHI(IK)
52380 IDLAM(LKNT,3)=0
52381 ENDIF
52382 160 CONTINUE
52383 170 CONTINUE
52384
52385C...HIGGS TO SFERMION SFERMION
52386 DO 200 IFL=1,16
52387 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
52388 IJ=KSUSY1+IFL
52389 XMJL=PMAS(PYCOMP(IJ),1)
52390 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
52391 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
52392 XMJ=XMJL
52393 XMJ2=XMJ**2
52394 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52395 XMF=PMAS(IFL,1)
52396 EI=KCHG(IFL,1)/3D0
52397 IDU=2-MOD(IFL,2)
52398
52399 IF(IH.EQ.1) THEN
52400 IF(IDU.EQ.1) THEN
52401 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
52402 & XMF**2/XMW*SINA/CBETA
52403 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
52404 & XMF**2/XMW*SINA/CBETA
52405 IF(IFL.EQ.5) THEN
52406 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52407 & ATRIB*SINA)
52408 ELSEIF(IFL.EQ.15) THEN
52409 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
52410 & ATRIL*SINA)
52411 ELSE
52412 GHLR=0D0
52413 ENDIF
52414 ELSE
52415 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
52416 & XMF**2/XMW*COSA/SBETA
52417 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
52418 & XMF**2/XMW*COSA/SBETA
52419 IF(IFL.EQ.6) THEN
52420 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
52421 & ATRIT*COSA)
52422 ELSE
52423 GHLR=0D0
52424 ENDIF
52425 ENDIF
52426
52427 ELSEIF(IH.EQ.2) THEN
52428 IF(IDU.EQ.1) THEN
52429 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
52430 & XMF**2/XMW*COSA/CBETA
52431 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52432 & XMF**2/XMW*COSA/CBETA
52433 IF(IFL.EQ.5) THEN
52434 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52435 & ATRIB*COSA)
52436 ELSEIF(IFL.EQ.15) THEN
52437 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
52438 & ATRIL*COSA)
52439 ELSE
52440 GHLR=0D0
52441 ENDIF
52442 ELSE
52443 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
52444 & XMF**2/XMW*SINA/SBETA
52445 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
52446 & XMF**2/XMW*SINA/SBETA
52447 IF(IFL.EQ.6) THEN
52448 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
52449 & ATRIT*SINA)
52450 ELSE
52451 GHLR=0D0
52452 ENDIF
52453 ENDIF
52454
52455 ELSEIF(IH.EQ.3) THEN
52456 GHLL=0D0
52457 GHRR=0D0
52458 GHLR=0D0
52459 IF(IDU.EQ.1) THEN
52460 IF(IFL.EQ.5) THEN
52461 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
52462 ELSEIF(IFL.EQ.15) THEN
52463 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
52464 ENDIF
52465 ELSE
52466 IF(IFL.EQ.6) THEN
52467 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
52468 ENDIF
52469 ENDIF
52470 ENDIF
52471 IF(IH.EQ.3) GOTO 180
52472
52473 AL=SFMIX(IFL,1)**2
52474 AR=SFMIX(IFL,2)**2
52475 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
52476 IF(IFL.LE.6) THEN
52477 CF=3D0
52478 ELSE
52479 CF=1D0
52480 ENDIF
52481
52482 IF(AXMI.GE.2D0*XMJ) THEN
52483 LKNT=LKNT+1
52484 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52485 & (GHLL*AL+GHRR*AR
52486 & +2D0*GHLR*ALR)**2
52487 IDLAM(LKNT,1)=IJ
52488 IDLAM(LKNT,2)=-IJ
52489 IDLAM(LKNT,3)=0
52490 ENDIF
52491
52492 IF(AXMI.GE.2D0*XMJR) THEN
52493 LKNT=LKNT+1
52494 AL=SFMIX(IFL,3)**2
52495 AR=SFMIX(IFL,4)**2
52496 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
52497 XMJ=XMJR
52498 XMJ2=XMJ**2
52499 XL=PYLAMF(XMI2,XMJ2,XMJ2)
52500 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52501 & (GHLL*AL+GHRR*AR
52502 & +2D0*GHLR*ALR)**2
52503 IDLAM(LKNT,1)=IJ+KSUSY1
52504 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52505 IDLAM(LKNT,3)=0
52506 ENDIF
52507 180 CONTINUE
52508
52509 IF(AXMI.GE.XMJL+XMJR) THEN
52510 LKNT=LKNT+1
52511 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
52512 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
52513 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
52514 XMJ=XMJR
52515 XMJ2=XMJ**2
52516 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
52517 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52518 & (GHLL*AL+GHRR*AR)**2
52519 IDLAM(LKNT,1)=IJ
52520 IDLAM(LKNT,2)=-(IJ+KSUSY1)
52521 IDLAM(LKNT,3)=0
52522 LKNT=LKNT+1
52523 IDLAM(LKNT,1)=-IJ
52524 IDLAM(LKNT,2)=IJ+KSUSY1
52525 IDLAM(LKNT,3)=0
52526 XLAM(LKNT)=XLAM(LKNT-1)
52527 ENDIF
52528 ENDIF
52529 190 CONTINUE
52530 200 CONTINUE
52531 210 CONTINUE
52532
52533 GOTO 270
52534 220 CONTINUE
52535
52536C...H+ -> CHI+_I + CHI0_J
52537 DO 240 IJ=1,4
52538 XMJ=SMZ(IJ)
52539 AXMJ=ABS(XMJ)
52540 XMJ2=XMJ**2
52541 DO 230 IK=1,2
52542 XMK=SMW(IK)
52543 AXMK=ABS(XMK)
52544 IF(AXMI.GE.AXMJ+AXMK) THEN
52545 LKNT=LKNT+1
52546 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
52547 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
52548 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
52549 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
52550 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52551 GLR=DBLE(OLPP*DCONJG(ORPP))
52552 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
52553 IDLAM(LKNT,1)=KFNCHI(IJ)
52554 IDLAM(LKNT,2)=KFCCHI(IK)
52555 IDLAM(LKNT,3)=0
52556 ENDIF
52557 230 CONTINUE
52558 240 CONTINUE
52559
52560 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
52561 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
52562 AL=0D0
52563 AR=0D0
52564 CF=3D0
52565
52566C...H+ -> T_1 B_1~
52567 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52568 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52569 IF(XMI.GE.XM1+XM2) THEN
52570 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52571 LKNT=LKNT+1
52572 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52573 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
52574 IDLAM(LKNT,1)=KSUSY1+6
52575 IDLAM(LKNT,2)=-(KSUSY1+5)
52576 IDLAM(LKNT,3)=0
52577 ENDIF
52578
52579C...H+ -> T_2 B_1~
52580 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52581 XM2=PMAS(PYCOMP(KSUSY1+5),1)
52582 IF(XMI.GE.XM1+XM2) THEN
52583 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52584 LKNT=LKNT+1
52585 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52586 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
52587 IDLAM(LKNT,1)=KSUSY2+6
52588 IDLAM(LKNT,2)=-(KSUSY1+5)
52589 IDLAM(LKNT,3)=0
52590 ENDIF
52591
52592C...H+ -> T_1 B_2~
52593 XM1=PMAS(PYCOMP(KSUSY1+6),1)
52594 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52595 IF(XMI.GE.XM1+XM2) THEN
52596 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52597 LKNT=LKNT+1
52598 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52599 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
52600 IDLAM(LKNT,1)=KSUSY1+6
52601 IDLAM(LKNT,2)=-(KSUSY2+5)
52602 IDLAM(LKNT,3)=0
52603 ENDIF
52604
52605C...H+ -> T_2 B_2~
52606 XM1=PMAS(PYCOMP(KSUSY2+6),1)
52607 XM2=PMAS(PYCOMP(KSUSY2+5),1)
52608 IF(XMI.GE.XM1+XM2) THEN
52609 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52610 LKNT=LKNT+1
52611 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
52612 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
52613 IDLAM(LKNT,1)=KSUSY2+6
52614 IDLAM(LKNT,2)=-(KSUSY2+5)
52615 IDLAM(LKNT,3)=0
52616 ENDIF
52617
52618C...H+ -> UL DL~
52619 GL=-XMW/SR2*SIN(2D0*BETA)
52620 DO 250 IJ=1,3,2
52621 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52622 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52623 IF(XMI.GE.XM1+XM2) THEN
52624 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52625 LKNT=LKNT+1
52626 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52627 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52628 IDLAM(LKNT,2)=KSUSY1+IJ+1
52629 IDLAM(LKNT,3)=0
52630 ENDIF
52631 250 CONTINUE
52632
52633C...H+ -> EL~ NUL
52634 CF=1D0
52635 DO 260 IJ=11,13,2
52636 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
52637 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
52638 IF(XMI.GE.XM1+XM2) THEN
52639 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52640 LKNT=LKNT+1
52641 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
52642 IDLAM(LKNT,1)=-(KSUSY1+IJ)
52643 IDLAM(LKNT,2)=KSUSY1+IJ+1
52644 IDLAM(LKNT,3)=0
52645 ENDIF
52646 260 CONTINUE
52647
52648C...H+ -> TAU1 NUTAUL
52649 XM1=PMAS(PYCOMP(KSUSY1+15),1)
52650 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52651 IF(XMI.GE.XM1+XM2) THEN
52652 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52653 LKNT=LKNT+1
52654 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
52655 IDLAM(LKNT,1)=-(KSUSY1+15)
52656 IDLAM(LKNT,2)= KSUSY1+16
52657 IDLAM(LKNT,3)=0
52658 ENDIF
52659
52660C...H+ -> TAU2 NUTAUL
52661 XM1=PMAS(PYCOMP(KSUSY2+15),1)
52662 XM2=PMAS(PYCOMP(KSUSY1+16),1)
52663 IF(XMI.GE.XM1+XM2) THEN
52664 XL=PYLAMF(XMI2,XM1**2,XM2**2)
52665 LKNT=LKNT+1
52666 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
52667 IDLAM(LKNT,1)=-(KSUSY2+15)
52668 IDLAM(LKNT,2)= KSUSY1+16
52669 IDLAM(LKNT,3)=0
52670 ENDIF
52671
52672 270 CONTINUE
52673 IKNT=LKNT
52674 XLAM(0)=0D0
52675 DO 280 I=1,IKNT
52676 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
52677 XLAM(0)=XLAM(0)+XLAM(I)
52678 280 CONTINUE
52679 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52680
52681 RETURN
52682 END
52683
52684C*********************************************************************
52685
52686C...PYH2XX
52687C...Calculates the decay rate for a Higgs to an ino pair.
52688
52689 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
52690
52691C...Double precision and integer declarations.
52692 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52693 IMPLICIT INTEGER(I-N)
52694 INTEGER PYK,PYCHGE,PYCOMP
52695C...Commonblocks.
52696 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52697 SAVE /PYDAT1/
52698
52699C...Local variables.
52700 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
52701 DOUBLE PRECISION XL,PYLAMF,C1
52702 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
52703
52704 XMI2=XM1**2
52705 XMI3=ABS(XM1**3)
52706 XMJ2=XM2**2
52707 XMK2=XM3**2
52708 XL=PYLAMF(XMI2,XMJ2,XMK2)
52709 PYH2XX=C1/4D0/XMI3*SQRT(XL)
52710 &*(GX2*(XMI2-XMJ2-XMK2)-
52711 &4D0*GLR*XM3*XM2)
52712 IF(PYH2XX.LT.0D0) PYH2XX=0D0
52713
52714 RETURN
52715 END
52716
52717C*********************************************************************
52718
52719C...PYGAUS
52720C...Integration by adaptive Gaussian quadrature.
52721C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52722
52723 FUNCTION PYGAUS(F, A, B, EPS)
52724
52725C...Double precision and integer declarations.
52726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52727 IMPLICIT INTEGER(I-N)
52728 INTEGER PYK,PYCHGE,PYCOMP
52729
52730C...Local declarations.
52731 EXTERNAL F
52732 DOUBLE PRECISION F,W(12), X(12)
52733 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52734 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52735 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52736 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52737 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52738 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52739 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52740 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52741 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52742 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52743 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52744 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52745
52746C...The Gaussian quadrature algorithm.
52747 H = 0D0
52748 IF(B .EQ. A) GOTO 140
52749 CONST = 5D-3 / ABS(B-A)
52750 BB = A
52751 100 CONTINUE
52752 AA = BB
52753 BB = B
52754 110 CONTINUE
52755 C1 = 0.5D0*(BB+AA)
52756 C2 = 0.5D0*(BB-AA)
52757 S8 = 0D0
52758 DO 120 I = 1, 4
52759 U = C2*X(I)
52760 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52761 120 CONTINUE
52762 S16 = 0D0
52763 DO 130 I = 5, 12
52764 U = C2*X(I)
52765 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52766 130 CONTINUE
52767 S16 = C2*S16
52768 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52769 H = H + S16
52770 IF(BB .NE. B) GOTO 100
52771 ELSE
52772 BB = C1
52773 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52774 H = 0D0
52775 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
52776 GOTO 140
52777 ENDIF
52778 140 CONTINUE
52779 PYGAUS = H
52780
52781 RETURN
52782 END
52783
52784C*********************************************************************
52785
52786C...PYGAU2
52787C...Integration by adaptive Gaussian quadrature.
52788C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
52789C...Carbon copy of PYGAUS, but avoids having to use it recursively.
52790
52791 FUNCTION PYGAU2(F, A, B, EPS)
52792
52793C...Double precision and integer declarations.
52794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52795 IMPLICIT INTEGER(I-N)
52796 INTEGER PYK,PYCHGE,PYCOMP
52797
52798C...Local declarations.
52799 EXTERNAL F
52800 DOUBLE PRECISION F,W(12), X(12)
52801 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
52802 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
52803 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
52804 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
52805 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
52806 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
52807 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
52808 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
52809 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
52810 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
52811 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
52812 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
52813
52814C...The Gaussian quadrature algorithm.
52815 H = 0D0
52816 IF(B .EQ. A) GOTO 140
52817 CONST = 5D-3 / ABS(B-A)
52818 BB = A
52819 100 CONTINUE
52820 AA = BB
52821 BB = B
52822 110 CONTINUE
52823 C1 = 0.5D0*(BB+AA)
52824 C2 = 0.5D0*(BB-AA)
52825 S8 = 0D0
52826 DO 120 I = 1, 4
52827 U = C2*X(I)
52828 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
52829 120 CONTINUE
52830 S16 = 0D0
52831 DO 130 I = 5, 12
52832 U = C2*X(I)
52833 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
52834 130 CONTINUE
52835 S16 = C2*S16
52836 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
52837 H = H + S16
52838 IF(BB .NE. B) GOTO 100
52839 ELSE
52840 BB = C1
52841 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
52842 H = 0D0
52843 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
52844 GOTO 140
52845 ENDIF
52846 140 CONTINUE
52847 PYGAU2 = H
52848
52849 RETURN
52850 END
52851
52852C*********************************************************************
52853
52854C...PYSIMP
52855C...Simpson formula for an integral.
52856
52857 FUNCTION PYSIMP(Y,X0,X1,N)
52858
52859C...Double precision and integer declarations.
52860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52861 IMPLICIT INTEGER(I-N)
52862 INTEGER PYK,PYCHGE,PYCOMP
52863
52864C...Local variables.
52865 DOUBLE PRECISION Y,X0,X1,H,S
52866 DIMENSION Y(0:N)
52867
52868 S=0D0
52869 H=(X1-X0)/N
52870 DO 100 I=0,N-2,2
52871 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
52872 100 CONTINUE
52873 PYSIMP=S*H/3D0
52874
52875 RETURN
52876 END
52877
52878C*********************************************************************
52879
52880C...PYLAMF
52881C...The standard lambda function.
52882
52883 FUNCTION PYLAMF(X,Y,Z)
52884
52885C...Double precision and integer declarations.
52886 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52887 IMPLICIT INTEGER(I-N)
52888 INTEGER PYK,PYCHGE,PYCOMP
52889
52890C...Local variables.
52891 DOUBLE PRECISION PYLAMF,X,Y,Z
52892
52893 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
52894 IF(PYLAMF.LT.0D0) PYLAMF=0D0
52895
52896 RETURN
52897 END
52898
52899C*********************************************************************
52900
52901C...PYTBDY
52902C...Generates 3-body decays of gauginos.
52903
52904 SUBROUTINE PYTBDY(IDIN)
52905
52906C...Double precision and integer declarations.
52907 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52908 IMPLICIT INTEGER(I-N)
52909 INTEGER PYK,PYCHGE,PYCOMP
52910C...Parameter statement to help give large particle numbers.
52911 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52912 &KEXCIT=4000000,KDIMEN=5000000)
52913C...Commonblocks.
52914 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
52915 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52916 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52917C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
52918C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
52919 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52920 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52921C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
52922 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
52923
52924C...Local variables.
52925 DOUBLE PRECISION XM(5)
52926 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
52927 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
52928 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
52929 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
52930 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
52931 DOUBLE PRECISION CPHI1,SPHI1
52932 DOUBLE PRECISION S23DEL,EPS
52933 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
52934 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
52935 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
52936 INTEGER INOID(4)
52937 DATA INOID/22,23,25,35/
52938 DATA EPS/1D-6/
52939
52940 ID=IDIN
52941 ISKIP=1
52942 XM(1)=P(N+1,5)
52943 XM(2)=P(N+2,5)
52944 XM(3)=P(N+3,5)
52945 XM(5)=P(ID,5)
52946
52947C...GENERATE S12
52948 S12MIN=(XM(1)+XM(2))**2
52949 S12MAX=(XM(5)-XM(3))**2
52950 YJACO1=S12MAX-S12MIN
52951
52952C...Initialize some parameters
52953 XW=PARU(102)
52954 XW1=1D0-XW
52955 TANW=SQRT(XW/XW1)
52956 IZID1=0
52957 IWID1=0
52958 IZID2=0
52959 IWID2=0
52960
52961 IA=K(N+2,2)
52962 JA=K(N+3,2)
52963
52964C...Mrenna: check that we are indeed decaying a SUSY particle
52965 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
52966
52967 ELSE
52968 DO 100 I1=1,4
52969 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
52970 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
52971 100 CONTINUE
52972 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
52973 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
52974 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
52975 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
52976 ZM12=XM(5)**2
52977 ZM22=XM(1)**2
52978 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
52979 T3I=SIGN(1D0,EI+1D-6)/2D0
52980 ENDIF
52981
52982 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
52983 ISKIP=0
52984 ELSEIF(IZID1*IZID2.NE.0) THEN
52985 SQMZ=PMAS(23,1)**2
52986 GMMZ=PMAS(23,1)*PMAS(23,2)
52987 DO 110 I=1,4
52988 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
52989 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
52990 110 CONTINUE
52991 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
52992 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
52993 ORPP=DCONJG(OLPP)
52994 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
52995 XLR2=XLL2
52996 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
52997 XRL2=XRR2
52998 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
52999 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53000 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53001 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53002 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53003 QLLU=-GLIJ
53004 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53005 QLRT=DCONJG(GLIJ)
53006 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53007 QRLT=GRIJ
53008 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53009 QRRU=-DCONJG(GRIJ)
53010 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53011 IF(IZID1.NE.0) THEN
53012 XM1M2=SMZ(IZID1)*SMW(IWID2)
53013 IZID1=IWID2
53014 IZID2=IZID1
53015 ELSE
53016 XM1M2=SMZ(IZID2)*SMW(IWID1)
53017 IZID1=IWID1
53018 ENDIF
53019 RT2I = 1D0/SQRT(2D0)
53020 SQMZ=PMAS(24,1)**2
53021 GMMZ=PMAS(24,1)*PMAS(24,2)
53022 DO 120 I=1,2
53023 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53024 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53025 120 CONTINUE
53026 DO 130 I=1,4
53027 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53028 130 CONTINUE
53029 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
53030 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
53031 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
53032 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
53033 EJ=KCHG(IABS(JA),1)/3D0
53034 T3J=SIGN(1D0,EJ+1D-6)/2D0
53035 QRLS=DCMPLX(0D0,0D0)
53036 QRLT=QRLS
53037 QRRS=QRLS
53038 QRRU=QRLS
53039 XRR2=1D6**2
53040 XRL2=XRR2
53041 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
53042 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53043 IF(MOD(IA,2).EQ.0) THEN
53044 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
53045 & TANW+ZMIXC(IZID2,2)*T3I)
53046 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53047 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
53048 ELSE
53049 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
53050 & TANW+ZMIXC(IZID2,2)*T3J)
53051 QLRT=-DCONJG(UMIXC(IZID1,1))*(
53052 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
53053 ENDIF
53054 ELSEIF(IWID1*IWID2.NE.0) THEN
53055 IZID1=IWID1
53056 IZID2=IWID2
53057 XM1M2=SMW(IWID1)*SMW(IWID2)
53058 SQMZ=PMAS(23,1)**2
53059 GMMZ=PMAS(23,1)*PMAS(23,2)
53060 DO 140 I=1,2
53061 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
53062 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
53063 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
53064 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
53065 140 CONTINUE
53066 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
53067 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
53068 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
53069 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
53070 QRLS=-DCMPLX(EI/XW1)*ORPP
53071 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53072 QRRS=-DCMPLX(EI/XW1)*OLPP
53073 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53074 IF(MOD(IA,2).EQ.0) THEN
53075 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
53076 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
53077 ELSE
53078 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
53079 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
53080 ENDIF
53081 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
53082 &THEN
53083 ISKIP=0
53084 ELSE
53085 ISKIP=0
53086 ENDIF
53087
53088 IF(ISKIP.NE.0) THEN
53089 WTMAX=0D0
53090 DO 160 KT=1,100
53091 S12=S12MIN+YJACO1*(KT-1)/99
53092 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53093 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53094 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53095 & -(2D0*XM(1)*XM(2))**2
53096 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53097 & -(2D0*XM(3)*XM(5))**2
53098 S23DF1=S23DF1*EPS
53099 S23DF2=S23DF2*EPS
53100 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53101 S23DEL=S23DEL/EPS
53102 S23MIN=S23AVE-S23DEL
53103 S23MAX=S23AVE+S23DEL
53104 YJACO2=S23MAX-S23MIN
53105 TH=S12
53106 DO 150 KS=1,100
53107 S23=S23MIN+YJACO2*(KS-1)/99
53108 SH=S23
53109 UH=ZM12+ZM22-SH-TH
53110 WU2 = (UH-ZM12)*(UH-ZM22)
53111 WT2 = (TH-ZM12)*(TH-ZM22)
53112 WS2 = XM1M2*SH
53113 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53114 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53115 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53116 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53117 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53118 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53119 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53120 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
53121 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53122 IF(WT0.GT.WTMAX) WTMAX=WT0
53123 150 CONTINUE
53124 160 CONTINUE
53125
53126 WTMAX=WTMAX*1.05D0
53127 ENDIF
53128
53129C...FIND S12*
53130 AX=S12MIN
53131 CX=S12MAX
53132 BX=S12MIN+0.5D0*YJACO1
53133 X0=AX
53134 X3=CX
53135 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
53136 X1=BX
53137 X2=BX+C*(CX-BX)
53138 ELSE
53139 X2=BX
53140 X1=BX-C*(BX-AX)
53141 ENDIF
53142
53143C...SOLVE FOR F1 AND F2
53144 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53145 &-(2D0*XM(1)*XM(2))**2
53146 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53147 &-(2D0*XM(3)*XM(5))**2
53148 S23DF1=S23DF1*EPS
53149 S23DF2=S23DF2*EPS
53150 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53151 F1=-2D0*S23DEL/EPS
53152 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53153 &-(2D0*XM(1)*XM(2))**2
53154 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53155 &-(2D0*XM(3)*XM(5))**2
53156 S23DF1=S23DF1*EPS
53157 S23DF2=S23DF2*EPS
53158 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53159 F2=-2D0*S23DEL/EPS
53160
53161 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
53162C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
53163 IF(F2.LE.F1)THEN
53164 X0=X1
53165 X1=X2
53166 X2=R*X1+C*X3
53167 F1=F2
53168 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
53169 & -(2D0*XM(1)*XM(2))**2
53170 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
53171 & -(2D0*XM(3)*XM(5))**2
53172 S23DF1=S23DF1*EPS
53173 S23DF2=S23DF2*EPS
53174 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
53175 F2=-2D0*S23DEL/EPS
53176 ELSE
53177 X3=X2
53178 X2=X1
53179 X1=R*X2+C*X0
53180 F2=F1
53181 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
53182 & -(2D0*XM(1)*XM(2))**2
53183 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
53184 & -(2D0*XM(3)*XM(5))**2
53185 S23DF1=S23DF1*EPS
53186 S23DF2=S23DF2*EPS
53187 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
53188 F1=-2D0*S23DEL/EPS
53189 ENDIF
53190 GOTO 170
53191 ENDIF
53192C...WE WANT THE MAXIMUM, NOT THE MINIMUM
53193 IF(F1.LT.F2)THEN
53194 GOLDEN=-F1
53195 XMIN=X1
53196 ELSE
53197 GOLDEN=-F2
53198 XMIN=X2
53199 ENDIF
53200
53201 IKNT=0
53202 180 S12=S12MIN+PYR(0)*YJACO1
53203 IKNT=IKNT+1
53204C...GENERATE S23
53205 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
53206 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
53207 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
53208 &-(2D0*XM(1)*XM(2))**2
53209 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
53210 &-(2D0*XM(3)*XM(5))**2
53211 S23DF1=S23DF1*EPS
53212 S23DF2=S23DF2*EPS
53213 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
53214 S23DEL=S23DEL/EPS
53215 S23MIN=S23AVE-S23DEL
53216 S23MAX=S23AVE+S23DEL
53217 YJACO2=S23MAX-S23MIN
53218 S23=S23MIN+PYR(0)*YJACO2
53219
53220C...CHECK THE SAMPLING
53221 IF(IKNT.GT.100) THEN
53222 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
53223 GOTO 190
53224 ENDIF
53225 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
53226
53227 IF(ISKIP.EQ.0) GOTO 190
53228
53229 SH=S23
53230 TH=S12
53231 UH=ZM12+ZM22-SH-TH
53232
53233 WU2 = (UH-ZM12)*(UH-ZM22)
53234 WT2 = (TH-ZM12)*(TH-ZM22)
53235 WS2 = XM1M2*SH
53236 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
53237 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
53238
53239 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
53240 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
53241 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
53242 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
53243c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
53244c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
53245c &/DCMPLX(TH-XML2)
53246c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
53247c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
53248c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
53249 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
53250 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
53251 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
53252
53253 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
53254 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
53255
53256 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
53257 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
53258 D2=XM(5)-D1-D3
53259 P1=SQRT(D1*D1-XM(1)**2)
53260 P2=SQRT(D2*D2-XM(2)**2)
53261 P3=SQRT(D3*D3-XM(3)**2)
53262 CTHE1=2D0*PYR(0)-1D0
53263 ANG1=2D0*PYR(0)*PARU(1)
53264 CPHI1=COS(ANG1)
53265 SPHI1=SIN(ANG1)
53266 ARG=1D0-CTHE1**2
53267 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53268 STHE1=SQRT(ARG)
53269 P(N+1,1)=P1*STHE1*CPHI1
53270 P(N+1,2)=P1*STHE1*SPHI1
53271 P(N+1,3)=P1*CTHE1
53272 P(N+1,4)=D1
53273
53274C...GET CPHI3
53275 ANG3=2D0*PYR(0)*PARU(1)
53276 CPHI3=COS(ANG3)
53277 SPHI3=SIN(ANG3)
53278 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
53279 ARG=1D0-CTHE3**2
53280 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
53281 STHE3=SQRT(ARG)
53282 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
53283 &+P3*STHE3*SPHI3*SPHI1
53284 &+P3*CTHE3*STHE1*CPHI1
53285 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
53286 &-P3*STHE3*SPHI3*CPHI1
53287 &+P3*CTHE3*STHE1*SPHI1
53288 P(N+3,3)=P3*STHE3*CPHI3*STHE1
53289 &+P3*CTHE3*CTHE1
53290 P(N+3,4)=D3
53291
53292 DO 200 I=1,3
53293 P(N+2,I)=-P(N+1,I)-P(N+3,I)
53294 200 CONTINUE
53295 P(N+2,4)=D2
53296
53297 RETURN
53298 END
53299
53300
53301C*********************************************************************
53302
53303C...PYTECM
53304C...Finds the s-hat dependent eigenvalues of the inverse propagator
53305C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
53306C...phase space generation. Extended to include techni-a meson, and
53307C...to return the width.
53308
53309 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
53310
53311C...Double precision and integer declarations.
53312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53313 IMPLICIT INTEGER(I-N)
53314 INTEGER PYK,PYCHGE,PYCOMP
53315C...Parameter statement to help give large particle numbers.
53316 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53317 &KEXCIT=4000000,KDIMEN=5000000)
53318C...Commonblocks.
53319 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53320 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53321 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53322 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
53323 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
53324
53325C...Local variables.
53326 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
53327 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
53328 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
53329 INTEGER i,j,ierr
53330
53331 SH=SMIN
53332 SHR=SQRT(SH)
53333 AEM=PYALEM(SH)
53334
53335 SINW=MIN(SQRT(PARU(102)),1D0)
53336 COSW=SQRT(1D0-SINW**2)
53337 TANW=SINW/COSW
53338 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
53339 QUPD=2D0*RTCM(2)-1D0
53340
53341 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
53342 FAR=SQRT(AEM/ALPRHT)
53343 FAO=FAR*QUPD
53344 FZR=FAR*CT2W
53345 FZO=-FAO*TANW
53346 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
53347 FWR=FAR/(2D0*SINW)
53348 FWX=-FWR/RTCM(47)
53349
53350 DO 110 I=1,5
53351 DO 100 J=1,5
53352 AT(I,J)=0D0
53353 100 CONTINUE
53354 110 CONTINUE
53355
53356C...NC
53357 IF(IOPT.EQ.1) THEN
53358 AR(1,1) = SH
53359 AR(2,2) = SH-PMAS(23,1)**2
53360 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
53361 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
53362 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
53363 AR(1,2) = 0D0
53364 AR(2,1) = 0D0
53365 AR(1,3) = SH*FAR
53366 AR(3,1) = AR(1,3)
53367 AR(1,4) = SH*FAO
53368 AR(4,1) = AR(1,4)
53369 AR(2,3) = SH*FZR
53370 AR(3,2) = AR(2,3)
53371 AR(2,4) = SH*FZO
53372 AR(4,2) = AR(2,4)
53373 AR(3,4) = 0D0
53374 AR(4,3) = 0D0
53375 AR(2,5) = SH*FZX
53376 AR(5,2) = AR(2,5)
53377 AR(1,5) = 0D0
53378 AR(5,1) = AR(1,5)
53379 AR(3,5) = 0D0
53380 AR(5,3) = AR(3,5)
53381 AR(4,5) = 0D0
53382 AR(5,4) = AR(4,5)
53383 CALL PYWIDT(23,SH,WDTP,WDTE)
53384 AT(2,2) = WDTP(0)*SHR
53385 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
53386 AT(3,3) = WDTP(0)*SHR
53387 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
53388 AT(4,4) = WDTP(0)*SHR
53389 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
53390 AT(5,5) = WDTP(0)*SHR
53391 IDIM=5
53392C...CC
53393 ELSE
53394 AR(1,1) = SH-PMAS(24,1)**2
53395 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
53396 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
53397 AR(1,2) = SH*FWR
53398 AR(2,1) = AR(1,2)
53399 AR(1,3) = SH*FWX
53400 AR(3,1) = AR(1,3)
53401 AR(2,3) = 0D0
53402 AR(3,2) = 0D0
53403 CALL PYWIDT(24,SH,WDTP,WDTE)
53404 AT(1,1) = WDTP(0)*SHR
53405 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
53406 AT(2,2) = WDTP(0)*SHR
53407 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
53408 AT(3,3) = WDTP(0)*SHR
53409 IDIM=3
53410 ENDIF
53411 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
53412
53413 IMIN=1
53414 SXMN=1D20
53415 DO 120 I=1,IDIM
53416 WX(I)=SQRT(ABS(SH-WR(I)))
53417 WR(I)=ABS(WR(I))
53418 IF(WR(I).LT.SXMN) THEN
53419 SXMN=WR(I)
53420 IMIN=I
53421 ENDIF
53422 120 CONTINUE
53423 SMOU=WX(IMIN)**2
53424 WIDO=WI(IMIN)/SHR
53425
53426 RETURN
53427 END
53428
53429C*********************************************************************
53430
53431C...PYEIGC
53432C...Finds eigenvalues of a general complex matrix
53433C
53434C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
53435C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
53436C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
53437C OF A COMPLEX GENERAL MATRIX.
53438C
53439C ON INPUT
53440C
53441C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
53442C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53443C DIMENSION STATEMENT.
53444C
53445C N IS THE ORDER OF THE MATRIX A=(AR,AI).
53446C
53447C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
53448C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
53449C
53450C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
53451C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
53452C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
53453C
53454C ON OUTPUT
53455C
53456C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53457C RESPECTIVELY, OF THE EIGENVALUES.
53458C
53459C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53460C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
53461C
53462C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
53463C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
53464C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
53465C
53466C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
53467C
53468C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53469C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53470C
53471C THIS VERSION DATED AUGUST 1983.
53472C
53473
53474 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
53475
53476 INTEGER N,NM,IS1,IS2,IERR,MATZ
53477 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53478 X FV1(5),FV2(5),FV3(5)
53479 IF (N .LE. NM) GOTO 100
53480 IERR = 10 * N
53481 GOTO 120
53482C
53483 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
53484 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
53485 IF (MATZ .NE. 0) GOTO 110
53486C .......... FIND EIGENVALUES ONLY ..........
53487 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
53488 GOTO 120
53489C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
53490 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
53491 IF (IERR .NE. 0) GOTO 120
53492 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
53493 120 RETURN
53494 END
53495
53496C*********************************************************************
53497
53498C...PYCMQR
53499C...Auxiliary to PYEICG.
53500C
53501C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53502C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
53503C AND WILKINSON.
53504C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
53505C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53506C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53507C
53508C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
53509C UPPER HESSENBERG MATRIX BY THE QR METHOD.
53510C
53511C ON INPUT
53512C
53513C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53514C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53515C DIMENSION STATEMENT.
53516C
53517C N IS THE ORDER OF THE MATRIX.
53518C
53519C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53520C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53521C SET LOW=1, IGH=N.
53522C
53523C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53524C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53525C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
53526C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
53527C THE REDUCTION BY CORTH, IF PERFORMED.
53528C
53529C ON OUTPUT
53530C
53531C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
53532C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
53533C CALLING COMQR IF SUBSEQUENT CALCULATION OF
53534C EIGENVECTORS IS TO BE PERFORMED.
53535C
53536C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53537C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53538C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53539C FOR INDICES IERR+1,...,N.
53540C
53541C IERR IS SET TO
53542C ZERO FOR NORMAL RETURN,
53543C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53544C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53545C
53546C CALLS PYCDIV FOR COMPLEX DIVISION.
53547C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53548C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53549C
53550C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53551C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53552C
53553C THIS VERSION DATED AUGUST 1983.
53554C
53555
53556 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
53557
53558 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
53559 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
53560 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53561 X PYTHAG
53562
53563 IERR = 0
53564 IF (LOW .EQ. IGH) GOTO 130
53565C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53566 L = LOW + 1
53567C
53568 DO 120 I = L, IGH
53569 LL = MIN0(I+1,IGH)
53570 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
53571 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53572 YR = HR(I,I-1) / NORM
53573 YI = HI(I,I-1) / NORM
53574 HR(I,I-1) = NORM
53575 HI(I,I-1) = 0.0D0
53576C
53577 DO 100 J = I, IGH
53578 SI = YR * HI(I,J) - YI * HR(I,J)
53579 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53580 HI(I,J) = SI
53581 100 CONTINUE
53582C
53583 DO 110 J = LOW, LL
53584 SI = YR * HI(J,I) + YI * HR(J,I)
53585 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53586 HI(J,I) = SI
53587 110 CONTINUE
53588C
53589 120 CONTINUE
53590C .......... STORE ROOTS ISOLATED BY CBAL ..........
53591 130 DO 140 I = 1, N
53592 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
53593 WR(I) = HR(I,I)
53594 WI(I) = HI(I,I)
53595 140 CONTINUE
53596C
53597 EN = IGH
53598 TR = 0.0D0
53599 TI = 0.0D0
53600 ITN = 30*N
53601C .......... SEARCH FOR NEXT EIGENVALUE ..........
53602 150 IF (EN .LT. LOW) GOTO 320
53603 ITS = 0
53604 ENM1 = EN - 1
53605C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53606C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
53607 160 DO 170 LL = LOW, EN
53608 L = EN + LOW - LL
53609 IF (L .EQ. LOW) GOTO 180
53610 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53611 X + DABS(HR(L,L)) + DABS(HI(L,L))
53612 TST2 = TST1 + DABS(HR(L,L-1))
53613 IF (TST2 .EQ. TST1) GOTO 180
53614 170 CONTINUE
53615C .......... FORM SHIFT ..........
53616 180 IF (L .EQ. EN) GOTO 300
53617 IF (ITN .EQ. 0) GOTO 310
53618 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
53619 SR = HR(EN,EN)
53620 SI = HI(EN,EN)
53621 XR = HR(ENM1,EN) * HR(EN,ENM1)
53622 XI = HI(ENM1,EN) * HR(EN,ENM1)
53623 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
53624 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53625 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53626 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53627 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
53628 ZZR = -ZZR
53629 ZZI = -ZZI
53630 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53631 SR = SR - XR
53632 SI = SI - XI
53633 GOTO 210
53634C .......... FORM EXCEPTIONAL SHIFT ..........
53635 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53636 SI = 0.0D0
53637C
53638 210 DO 220 I = LOW, EN
53639 HR(I,I) = HR(I,I) - SR
53640 HI(I,I) = HI(I,I) - SI
53641 220 CONTINUE
53642C
53643 TR = TR + SR
53644 TI = TI + SI
53645 ITS = ITS + 1
53646 ITN = ITN - 1
53647C .......... REDUCE TO TRIANGLE (ROWS) ..........
53648 LP1 = L + 1
53649C
53650 DO 240 I = LP1, EN
53651 SR = HR(I,I-1)
53652 HR(I,I-1) = 0.0D0
53653 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53654 XR = HR(I-1,I-1) / NORM
53655 WR(I-1) = XR
53656 XI = HI(I-1,I-1) / NORM
53657 WI(I-1) = XI
53658 HR(I-1,I-1) = NORM
53659 HI(I-1,I-1) = 0.0D0
53660 HI(I,I-1) = SR / NORM
53661C
53662 DO 230 J = I, EN
53663 YR = HR(I-1,J)
53664 YI = HI(I-1,J)
53665 ZZR = HR(I,J)
53666 ZZI = HI(I,J)
53667 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53668 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53669 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53670 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53671 230 CONTINUE
53672C
53673 240 CONTINUE
53674C
53675 SI = HI(EN,EN)
53676 IF (SI .EQ. 0.0D0) GOTO 250
53677 NORM = PYTHAG(HR(EN,EN),SI)
53678 SR = HR(EN,EN) / NORM
53679 SI = SI / NORM
53680 HR(EN,EN) = NORM
53681 HI(EN,EN) = 0.0D0
53682C .......... INVERSE OPERATION (COLUMNS) ..........
53683 250 DO 280 J = LP1, EN
53684 XR = WR(J-1)
53685 XI = WI(J-1)
53686C
53687 DO 270 I = L, J
53688 YR = HR(I,J-1)
53689 YI = 0.0D0
53690 ZZR = HR(I,J)
53691 ZZI = HI(I,J)
53692 IF (I .EQ. J) GOTO 260
53693 YI = HI(I,J-1)
53694 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
53695 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
53696 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
53697 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
53698 270 CONTINUE
53699C
53700 280 CONTINUE
53701C
53702 IF (SI .EQ. 0.0D0) GOTO 160
53703C
53704 DO 290 I = L, EN
53705 YR = HR(I,EN)
53706 YI = HI(I,EN)
53707 HR(I,EN) = SR * YR - SI * YI
53708 HI(I,EN) = SR * YI + SI * YR
53709 290 CONTINUE
53710C
53711 GOTO 160
53712C .......... A ROOT FOUND ..........
53713 300 WR(EN) = HR(EN,EN) + TR
53714 WI(EN) = HI(EN,EN) + TI
53715 EN = ENM1
53716 GOTO 150
53717C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
53718C CONVERGED AFTER 30*N ITERATIONS ..........
53719 310 IERR = EN
53720 320 RETURN
53721 END
53722
53723C*********************************************************************
53724
53725C...PYCMQ2
53726C...Auxiliary to PYEICG.
53727C
53728C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
53729C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
53730C AND WILKINSON.
53731C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
53732C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
53733C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
53734C
53735C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
53736C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
53737C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
53738C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
53739C THIS GENERAL MATRIX TO HESSENBERG FORM.
53740C
53741C ON INPUT
53742C
53743C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
53744C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
53745C DIMENSION STATEMENT.
53746C
53747C N IS THE ORDER OF THE MATRIX.
53748C
53749C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
53750C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
53751C SET LOW=1, IGH=N.
53752C
53753C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
53754C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
53755C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
53756C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
53757C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
53758C
53759C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
53760C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
53761C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
53762C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
53763C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
53764C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
53765C ARBITRARY.
53766C
53767C ON OUTPUT
53768C
53769C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
53770C HAVE BEEN DESTROYED.
53771C
53772C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
53773C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
53774C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
53775C FOR INDICES IERR+1,...,N.
53776C
53777C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
53778C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
53779C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
53780C THE EIGENVECTORS HAS BEEN FOUND.
53781C
53782C IERR IS SET TO
53783C ZERO FOR NORMAL RETURN,
53784C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
53785C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
53786C
53787C CALLS PYCDIV FOR COMPLEX DIVISION.
53788C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
53789C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
53790C
53791C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
53792C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
53793C
53794C THIS VERSION DATED OCTOBER 1989.
53795C
53796C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
53797C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
53798C
53799
53800 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
53801
53802 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
53803 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
53804 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
53805 X ORTR(5),ORTI(5)
53806 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
53807 X PYTHAG
53808
53809 IERR = 0
53810C .......... INITIALIZE EIGENVECTOR MATRIX ..........
53811 DO 110 J = 1, N
53812C
53813 DO 100 I = 1, N
53814 ZR(I,J) = 0.0D0
53815 ZI(I,J) = 0.0D0
53816 100 CONTINUE
53817 ZR(J,J) = 1.0D0
53818 110 CONTINUE
53819C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
53820C FROM THE INFORMATION LEFT BY CORTH ..........
53821 IEND = IGH - LOW - 1
53822 IF (IEND.LT.0) GOTO 220
53823 IF (IEND.EQ.0) GOTO 170
53824C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
53825 DO 160 II = 1, IEND
53826 I = IGH - II
53827 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
53828 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
53829C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
53830 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
53831 IP1 = I + 1
53832C
53833 DO 120 K = IP1, IGH
53834 ORTR(K) = HR(K,I-1)
53835 ORTI(K) = HI(K,I-1)
53836 120 CONTINUE
53837C
53838 DO 150 J = I, IGH
53839 SR = 0.0D0
53840 SI = 0.0D0
53841C
53842 DO 130 K = I, IGH
53843 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
53844 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
53845 130 CONTINUE
53846C
53847 SR = SR / NORM
53848 SI = SI / NORM
53849C
53850 DO 140 K = I, IGH
53851 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
53852 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
53853 140 CONTINUE
53854C
53855 150 CONTINUE
53856C
53857 160 CONTINUE
53858C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
53859 170 L = LOW + 1
53860C
53861 DO 210 I = L, IGH
53862 LL = MIN0(I+1,IGH)
53863 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
53864 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
53865 YR = HR(I,I-1) / NORM
53866 YI = HI(I,I-1) / NORM
53867 HR(I,I-1) = NORM
53868 HI(I,I-1) = 0.0D0
53869C
53870 DO 180 J = I, N
53871 SI = YR * HI(I,J) - YI * HR(I,J)
53872 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
53873 HI(I,J) = SI
53874 180 CONTINUE
53875C
53876 DO 190 J = 1, LL
53877 SI = YR * HI(J,I) + YI * HR(J,I)
53878 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
53879 HI(J,I) = SI
53880 190 CONTINUE
53881C
53882 DO 200 J = LOW, IGH
53883 SI = YR * ZI(J,I) + YI * ZR(J,I)
53884 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
53885 ZI(J,I) = SI
53886 200 CONTINUE
53887C
53888 210 CONTINUE
53889C .......... STORE ROOTS ISOLATED BY CBAL ..........
53890 220 DO 230 I = 1, N
53891 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
53892 WR(I) = HR(I,I)
53893 WI(I) = HI(I,I)
53894 230 CONTINUE
53895C
53896 EN = IGH
53897 TR = 0.0D0
53898 TI = 0.0D0
53899 ITN = 30*N
53900C .......... SEARCH FOR NEXT EIGENVALUE ..........
53901 240 IF (EN .LT. LOW) GOTO 430
53902 ITS = 0
53903 ENM1 = EN - 1
53904C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
53905C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
53906 250 DO 260 LL = LOW, EN
53907 L = EN + LOW - LL
53908 IF (L .EQ. LOW) GOTO 270
53909 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
53910 X + DABS(HR(L,L)) + DABS(HI(L,L))
53911 TST2 = TST1 + DABS(HR(L,L-1))
53912 IF (TST2 .EQ. TST1) GOTO 270
53913 260 CONTINUE
53914C .......... FORM SHIFT ..........
53915 270 IF (L .EQ. EN) GOTO 420
53916 IF (ITN .EQ. 0) GOTO 550
53917 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
53918 SR = HR(EN,EN)
53919 SI = HI(EN,EN)
53920 XR = HR(ENM1,EN) * HR(EN,ENM1)
53921 XI = HI(ENM1,EN) * HR(EN,ENM1)
53922 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
53923 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
53924 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
53925 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
53926 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
53927 ZZR = -ZZR
53928 ZZI = -ZZI
53929 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
53930 SR = SR - XR
53931 SI = SI - XI
53932 GOTO 300
53933C .......... FORM EXCEPTIONAL SHIFT ..........
53934 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
53935 SI = 0.0D0
53936C
53937 300 DO 310 I = LOW, EN
53938 HR(I,I) = HR(I,I) - SR
53939 HI(I,I) = HI(I,I) - SI
53940 310 CONTINUE
53941C
53942 TR = TR + SR
53943 TI = TI + SI
53944 ITS = ITS + 1
53945 ITN = ITN - 1
53946C .......... REDUCE TO TRIANGLE (ROWS) ..........
53947 LP1 = L + 1
53948C
53949 DO 330 I = LP1, EN
53950 SR = HR(I,I-1)
53951 HR(I,I-1) = 0.0D0
53952 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
53953 XR = HR(I-1,I-1) / NORM
53954 WR(I-1) = XR
53955 XI = HI(I-1,I-1) / NORM
53956 WI(I-1) = XI
53957 HR(I-1,I-1) = NORM
53958 HI(I-1,I-1) = 0.0D0
53959 HI(I,I-1) = SR / NORM
53960C
53961 DO 320 J = I, N
53962 YR = HR(I-1,J)
53963 YI = HI(I-1,J)
53964 ZZR = HR(I,J)
53965 ZZI = HI(I,J)
53966 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
53967 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
53968 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
53969 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
53970 320 CONTINUE
53971C
53972 330 CONTINUE
53973C
53974 SI = HI(EN,EN)
53975 IF (SI .EQ. 0.0D0) GOTO 350
53976 NORM = PYTHAG(HR(EN,EN),SI)
53977 SR = HR(EN,EN) / NORM
53978 SI = SI / NORM
53979 HR(EN,EN) = NORM
53980 HI(EN,EN) = 0.0D0
53981 IF (EN .EQ. N) GOTO 350
53982 IP1 = EN + 1
53983C
53984 DO 340 J = IP1, N
53985 YR = HR(EN,J)
53986 YI = HI(EN,J)
53987 HR(EN,J) = SR * YR + SI * YI
53988 HI(EN,J) = SR * YI - SI * YR
53989 340 CONTINUE
53990C .......... INVERSE OPERATION (COLUMNS) ..........
53991 350 DO 390 J = LP1, EN
53992 XR = WR(J-1)
53993 XI = WI(J-1)
53994C
53995 DO 370 I = 1, J
53996 YR = HR(I,J-1)
53997 YI = 0.0D0
53998 ZZR = HR(I,J)
53999 ZZI = HI(I,J)
54000 IF (I .EQ. J) GOTO 360
54001 YI = HI(I,J-1)
54002 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54003 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54004 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54005 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54006 370 CONTINUE
54007C
54008 DO 380 I = LOW, IGH
54009 YR = ZR(I,J-1)
54010 YI = ZI(I,J-1)
54011 ZZR = ZR(I,J)
54012 ZZI = ZI(I,J)
54013 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
54014 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
54015 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
54016 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
54017 380 CONTINUE
54018C
54019 390 CONTINUE
54020C
54021 IF (SI .EQ. 0.0D0) GOTO 250
54022C
54023 DO 400 I = 1, EN
54024 YR = HR(I,EN)
54025 YI = HI(I,EN)
54026 HR(I,EN) = SR * YR - SI * YI
54027 HI(I,EN) = SR * YI + SI * YR
54028 400 CONTINUE
54029C
54030 DO 410 I = LOW, IGH
54031 YR = ZR(I,EN)
54032 YI = ZI(I,EN)
54033 ZR(I,EN) = SR * YR - SI * YI
54034 ZI(I,EN) = SR * YI + SI * YR
54035 410 CONTINUE
54036C
54037 GOTO 250
54038C .......... A ROOT FOUND ..........
54039 420 HR(EN,EN) = HR(EN,EN) + TR
54040 WR(EN) = HR(EN,EN)
54041 HI(EN,EN) = HI(EN,EN) + TI
54042 WI(EN) = HI(EN,EN)
54043 EN = ENM1
54044 GOTO 240
54045C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
54046C VECTORS OF UPPER TRIANGULAR FORM ..........
54047 430 NORM = 0.0D0
54048C
54049 DO 440 I = 1, N
54050C
54051 DO 440 J = I, N
54052 TR = DABS(HR(I,J)) + DABS(HI(I,J))
54053 IF (TR .GT. NORM) NORM = TR
54054 440 CONTINUE
54055C
54056 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
54057C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
54058 DO 500 NN = 2, N
54059 EN = N + 2 - NN
54060 XR = WR(EN)
54061 XI = WI(EN)
54062 HR(EN,EN) = 1.0D0
54063 HI(EN,EN) = 0.0D0
54064 ENM1 = EN - 1
54065C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
54066 DO 490 II = 1, ENM1
54067 I = EN - II
54068 ZZR = 0.0D0
54069 ZZI = 0.0D0
54070 IP1 = I + 1
54071C
54072 DO 450 J = IP1, EN
54073 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
54074 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
54075 450 CONTINUE
54076C
54077 YR = XR - WR(I)
54078 YI = XI - WI(I)
54079 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
54080 TST1 = NORM
54081 YR = TST1
54082 460 YR = 0.01D0 * YR
54083 TST2 = NORM + YR
54084 IF (TST2 .GT. TST1) GOTO 460
54085 470 CONTINUE
54086 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
54087C .......... OVERFLOW CONTROL ..........
54088 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
54089 IF (TR .EQ. 0.0D0) GOTO 490
54090 TST1 = TR
54091 TST2 = TST1 + 1.0D0/TST1
54092 IF (TST2 .GT. TST1) GOTO 490
54093 DO 480 J = I, EN
54094 HR(J,EN) = HR(J,EN)/TR
54095 HI(J,EN) = HI(J,EN)/TR
54096 480 CONTINUE
54097C
54098 490 CONTINUE
54099C
54100 500 CONTINUE
54101C .......... END BACKSUBSTITUTION ..........
54102C .......... VECTORS OF ISOLATED ROOTS ..........
54103 DO 520 I = 1, N
54104 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
54105C
54106 DO 510 J = I, N
54107 ZR(I,J) = HR(I,J)
54108 ZI(I,J) = HI(I,J)
54109 510 CONTINUE
54110C
54111 520 CONTINUE
54112C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
54113C VECTORS OF ORIGINAL FULL MATRIX.
54114C FOR J=N STEP -1 UNTIL LOW DO -- ..........
54115 DO 540 JJ = LOW, N
54116 J = N + LOW - JJ
54117 M = MIN0(J,IGH)
54118C
54119 DO 540 I = LOW, IGH
54120 ZZR = 0.0D0
54121 ZZI = 0.0D0
54122C
54123 DO 530 K = LOW, M
54124 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
54125 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
54126 530 CONTINUE
54127C
54128 ZR(I,J) = ZZR
54129 ZI(I,J) = ZZI
54130 540 CONTINUE
54131C
54132 GOTO 560
54133C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
54134C CONVERGED AFTER 30*N ITERATIONS ..........
54135 550 IERR = EN
54136 560 RETURN
54137 END
54138
54139C*********************************************************************
54140
54141C...PYCDIV
54142C...Auxiliary to PYCMQR
54143C
54144C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
54145C
54146
54147 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
54148
54149 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
54150 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
54151
54152 S = DABS(BR) + DABS(BI)
54153 ARS = AR/S
54154 AIS = AI/S
54155 BRS = BR/S
54156 BIS = BI/S
54157 S = BRS**2 + BIS**2
54158 CR = (ARS*BRS + AIS*BIS)/S
54159 CI = (AIS*BRS - ARS*BIS)/S
54160 RETURN
54161 END
54162
54163C*********************************************************************
54164
54165C...PYCSRT
54166C...Auxiliary to PYCMQR
54167C
54168C (YR,YI) = COMPLEX DSQRT(XR,XI)
54169C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
54170C
54171
54172 SUBROUTINE PYCSRT(XR,XI,YR,YI)
54173
54174 DOUBLE PRECISION XR,XI,YR,YI
54175 DOUBLE PRECISION S,TR,TI,PYTHAG
54176
54177 TR = XR
54178 TI = XI
54179 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
54180 IF (TR .GE. 0.0D0) YR = S
54181 IF (TI .LT. 0.0D0) S = -S
54182 IF (TR .LE. 0.0D0) YI = S
54183 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
54184 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
54185 RETURN
54186 END
54187
54188 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
54189 DOUBLE PRECISION A,B
54190C
54191C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
54192C
54193 DOUBLE PRECISION P,R,S,T,U
54194 P = DMAX1(DABS(A),DABS(B))
54195 IF (P .EQ. 0.0D0) GOTO 110
54196 R = (DMIN1(DABS(A),DABS(B))/P)**2
54197 100 CONTINUE
54198 T = 4.0D0 + R
54199 IF (T .EQ. 4.0D0) GOTO 110
54200 S = R/T
54201 U = 1.0D0 + 2.0D0*S
54202 P = U*P
54203 R = (S/U)**2 * R
54204 GOTO 100
54205 110 PYTHAG = P
54206 RETURN
54207 END
54208
54209C*********************************************************************
54210
54211C...PYCBAL
54212C...Auxiliary to PYEICG
54213C
54214C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54215C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
54216C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54217C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54218C
54219C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
54220C EIGENVALUES WHENEVER POSSIBLE.
54221C
54222C ON INPUT
54223C
54224C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54225C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54226C DIMENSION STATEMENT.
54227C
54228C N IS THE ORDER OF THE MATRIX.
54229C
54230C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54231C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
54232C
54233C ON OUTPUT
54234C
54235C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54236C RESPECTIVELY, OF THE BALANCED MATRIX.
54237C
54238C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
54239C ARE EQUAL TO ZERO IF
54240C (1) I IS GREATER THAN J AND
54241C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
54242C
54243C SCALE CONTAINS INFORMATION DETERMINING THE
54244C PERMUTATIONS AND SCALING FACTORS USED.
54245C
54246C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
54247C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
54248C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
54249C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
54250C SCALE(J) = P(J), FOR J = 1,...,LOW-1
54251C = D(J,J) J = LOW,...,IGH
54252C = P(J) J = IGH+1,...,N.
54253C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
54254C THEN 1 TO LOW-1.
54255C
54256C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
54257C
54258C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
54259C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
54260C K,L HAVE BEEN REVERSED.)
54261C
54262C ARITHMETIC IS REAL THROUGHOUT.
54263C
54264C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54265C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54266C
54267C THIS VERSION DATED AUGUST 1983.
54268C
54269
54270 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
54271
54272 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
54273 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
54274 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
54275 LOGICAL NOCONV
54276
54277 RADIX = 16.0D0
54278C
54279 B2 = RADIX * RADIX
54280 K = 1
54281 L = N
54282 GOTO 150
54283C .......... IN-LINE PROCEDURE FOR ROW AND
54284C COLUMN EXCHANGE ..........
54285 100 SCALE(M) = J
54286 IF (J .EQ. M) GOTO 130
54287C
54288 DO 110 I = 1, L
54289 F = AR(I,J)
54290 AR(I,J) = AR(I,M)
54291 AR(I,M) = F
54292 F = AI(I,J)
54293 AI(I,J) = AI(I,M)
54294 AI(I,M) = F
54295 110 CONTINUE
54296C
54297 DO 120 I = K, N
54298 F = AR(J,I)
54299 AR(J,I) = AR(M,I)
54300 AR(M,I) = F
54301 F = AI(J,I)
54302 AI(J,I) = AI(M,I)
54303 AI(M,I) = F
54304 120 CONTINUE
54305C
54306 130 IF(IEXC.EQ.1) GOTO 140
54307 IF(IEXC.EQ.2) GOTO 180
54308C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
54309C AND PUSH THEM DOWN ..........
54310 140 IF (L .EQ. 1) GOTO 320
54311 L = L - 1
54312C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
54313 150 DO 170 JJ = 1, L
54314 J = L + 1 - JJ
54315C
54316 DO 160 I = 1, L
54317 IF (I .EQ. J) GOTO 160
54318 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
54319 160 CONTINUE
54320C
54321 M = L
54322 IEXC = 1
54323 GOTO 100
54324 170 CONTINUE
54325C
54326 GOTO 190
54327C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
54328C AND PUSH THEM LEFT ..........
54329 180 K = K + 1
54330C
54331 190 DO 210 J = K, L
54332C
54333 DO 200 I = K, L
54334 IF (I .EQ. J) GOTO 200
54335 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
54336 200 CONTINUE
54337C
54338 M = K
54339 IEXC = 2
54340 GOTO 100
54341 210 CONTINUE
54342C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
54343 DO 220 I = K, L
54344 220 SCALE(I) = 1.0D0
54345C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
54346 230 NOCONV = .FALSE.
54347C
54348 DO 310 I = K, L
54349 C = 0.0D0
54350 R = 0.0D0
54351C
54352 DO 240 J = K, L
54353 IF (J .EQ. I) GOTO 240
54354 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
54355 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
54356 240 CONTINUE
54357C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
54358 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
54359 G = R / RADIX
54360 F = 1.0D0
54361 S = C + R
54362 250 IF (C .GE. G) GOTO 260
54363 F = F * RADIX
54364 C = C * B2
54365 GOTO 250
54366 260 G = R * RADIX
54367 270 IF (C .LT. G) GOTO 280
54368 F = F / RADIX
54369 C = C / B2
54370 GOTO 270
54371C .......... NOW BALANCE ..........
54372 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
54373 G = 1.0D0 / F
54374 SCALE(I) = SCALE(I) * F
54375 NOCONV = .TRUE.
54376C
54377 DO 290 J = K, N
54378 AR(I,J) = AR(I,J) * G
54379 AI(I,J) = AI(I,J) * G
54380 290 CONTINUE
54381C
54382 DO 300 J = 1, L
54383 AR(J,I) = AR(J,I) * F
54384 AI(J,I) = AI(J,I) * F
54385 300 CONTINUE
54386C
54387 310 CONTINUE
54388C
54389 IF (NOCONV) GOTO 230
54390C
54391 320 LOW = K
54392 IGH = L
54393 RETURN
54394 END
54395
54396C*********************************************************************
54397
54398C...PYCBA2
54399C...Auxiliary to PYEICG.
54400C
54401C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
54402C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
54403C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
54404C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
54405C
54406C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
54407C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
54408C BALANCED MATRIX DETERMINED BY CBAL.
54409C
54410C ON INPUT
54411C
54412C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54413C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54414C DIMENSION STATEMENT.
54415C
54416C N IS THE ORDER OF THE MATRIX.
54417C
54418C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
54419C
54420C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
54421C AND SCALING FACTORS USED BY CBAL.
54422C
54423C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
54424C
54425C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54426C RESPECTIVELY, OF THE EIGENVECTORS TO BE
54427C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
54428C
54429C ON OUTPUT
54430C
54431C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
54432C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
54433C IN THEIR FIRST M COLUMNS.
54434C
54435C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54436C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54437C
54438C THIS VERSION DATED AUGUST 1983.
54439C
54440
54441 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
54442
54443 INTEGER I,J,K,M,N,II,NM,IGH,LOW
54444 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
54445 DOUBLE PRECISION S
54446
54447 IF (M .EQ. 0) GOTO 150
54448 IF (IGH .EQ. LOW) GOTO 120
54449C
54450 DO 110 I = LOW, IGH
54451 S = SCALE(I)
54452C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
54453C IF THE FOREGOING STATEMENT IS REPLACED BY
54454C S=1.0D0/SCALE(I). ..........
54455 DO 100 J = 1, M
54456 ZR(I,J) = ZR(I,J) * S
54457 ZI(I,J) = ZI(I,J) * S
54458 100 CONTINUE
54459C
54460 110 CONTINUE
54461C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
54462C IGH+1 STEP 1 UNTIL N DO -- ..........
54463 120 DO 140 II = 1, N
54464 I = II
54465 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
54466 IF (I .LT. LOW) I = LOW - II
54467 K = SCALE(I)
54468 IF (K .EQ. I) GOTO 140
54469C
54470 DO 130 J = 1, M
54471 S = ZR(I,J)
54472 ZR(I,J) = ZR(K,J)
54473 ZR(K,J) = S
54474 S = ZI(I,J)
54475 ZI(I,J) = ZI(K,J)
54476 ZI(K,J) = S
54477 130 CONTINUE
54478C
54479 140 CONTINUE
54480C
54481 150 RETURN
54482 END
54483
54484C*********************************************************************
54485
54486C...PYCRTH
54487C...Auxiliary to PYEICG.
54488C
54489C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
54490C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
54491C BY MARTIN AND WILKINSON.
54492C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
54493C
54494C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
54495C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
54496C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
54497C UNITARY SIMILARITY TRANSFORMATIONS.
54498C
54499C ON INPUT
54500C
54501C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
54502C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
54503C DIMENSION STATEMENT.
54504C
54505C N IS THE ORDER OF THE MATRIX.
54506C
54507C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
54508C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
54509C SET LOW=1, IGH=N.
54510C
54511C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54512C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
54513C
54514C ON OUTPUT
54515C
54516C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
54517C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
54518C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
54519C IS STORED IN THE REMAINING TRIANGLES UNDER THE
54520C HESSENBERG MATRIX.
54521C
54522C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
54523C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
54524C
54525C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
54526C
54527C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
54528C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
54529C
54530C THIS VERSION DATED AUGUST 1983.
54531C
54532
54533 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
54534
54535 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
54536 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
54537 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
54538
54539 LA = IGH - 1
54540 KP1 = LOW + 1
54541 IF (LA .LT. KP1) GOTO 210
54542C
54543 DO 200 M = KP1, LA
54544 H = 0.0D0
54545 ORTR(M) = 0.0D0
54546 ORTI(M) = 0.0D0
54547 SCALE = 0.0D0
54548C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
54549 DO 100 I = M, IGH
54550 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
54551C
54552 IF (SCALE .EQ. 0.0D0) GOTO 200
54553 MP = M + IGH
54554C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54555 DO 110 II = M, IGH
54556 I = MP - II
54557 ORTR(I) = AR(I,M-1) / SCALE
54558 ORTI(I) = AI(I,M-1) / SCALE
54559 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
54560 110 CONTINUE
54561C
54562 G = DSQRT(H)
54563 F = PYTHAG(ORTR(M),ORTI(M))
54564 IF (F .EQ. 0.0D0) GOTO 120
54565 H = H + F * G
54566 G = G / F
54567 ORTR(M) = (1.0D0 + G) * ORTR(M)
54568 ORTI(M) = (1.0D0 + G) * ORTI(M)
54569 GOTO 130
54570C
54571 120 ORTR(M) = G
54572 AR(M,M-1) = SCALE
54573C .......... FORM (I-(U*UT)/H) * A ..........
54574 130 DO 160 J = M, N
54575 FR = 0.0D0
54576 FI = 0.0D0
54577C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
54578 DO 140 II = M, IGH
54579 I = MP - II
54580 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
54581 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
54582 140 CONTINUE
54583C
54584 FR = FR / H
54585 FI = FI / H
54586C
54587 DO 150 I = M, IGH
54588 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
54589 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
54590 150 CONTINUE
54591C
54592 160 CONTINUE
54593C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
54594 DO 190 I = 1, IGH
54595 FR = 0.0D0
54596 FI = 0.0D0
54597C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
54598 DO 170 JJ = M, IGH
54599 J = MP - JJ
54600 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
54601 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
54602 170 CONTINUE
54603C
54604 FR = FR / H
54605 FI = FI / H
54606C
54607 DO 180 J = M, IGH
54608 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
54609 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
54610 180 CONTINUE
54611C
54612 190 CONTINUE
54613C
54614 ORTR(M) = SCALE * ORTR(M)
54615 ORTI(M) = SCALE * ORTI(M)
54616 AR(M,M-1) = -G * AR(M,M-1)
54617 AI(M,M-1) = -G * AI(M,M-1)
54618 200 CONTINUE
54619C
54620 210 RETURN
54621 END
54622
54623C*********************************************************************
54624
54625C...PYLDCM
54626C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54627C...processes.
54628
54629 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
54630 IMPLICIT NONE
54631 INTEGER N,NP,INDX(N)
54632 REAL*8 D,TINY
54633 COMPLEX*16 A(NP,NP)
54634 PARAMETER (TINY=1.0D-20)
54635 INTEGER I,IMAX,J,K
54636 REAL*8 AAMAX,VV(6),DUM
54637 COMPLEX*16 SUM,DUMC
54638
54639 D=1D0
54640 DO 110 I=1,N
54641 AAMAX=0D0
54642 DO 100 J=1,N
54643 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
54644 100 CONTINUE
54645 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
54646 VV(I)=1D0/AAMAX
54647 110 CONTINUE
54648 DO 180 J=1,N
54649 DO 130 I=1,J-1
54650 SUM=A(I,J)
54651 DO 120 K=1,I-1
54652 SUM=SUM-A(I,K)*A(K,J)
54653 120 CONTINUE
54654 A(I,J)=SUM
54655 130 CONTINUE
54656 AAMAX=0D0
54657 DO 150 I=J,N
54658 SUM=A(I,J)
54659 DO 140 K=1,J-1
54660 SUM=SUM-A(I,K)*A(K,J)
54661 140 CONTINUE
54662 A(I,J)=SUM
54663 DUM=VV(I)*ABS(SUM)
54664 IF (DUM.GE.AAMAX) THEN
54665 IMAX=I
54666 AAMAX=DUM
54667 ENDIF
54668 150 CONTINUE
54669 IF (J.NE.IMAX)THEN
54670 DO 160 K=1,N
54671 DUMC=A(IMAX,K)
54672 A(IMAX,K)=A(J,K)
54673 A(J,K)=DUMC
54674 160 CONTINUE
54675 D=-D
54676 VV(IMAX)=VV(J)
54677 ENDIF
54678 INDX(J)=IMAX
54679 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
54680 IF(J.NE.N)THEN
54681 DO 170 I=J+1,N
54682 A(I,J)=A(I,J)/A(J,J)
54683 170 CONTINUE
54684 ENDIF
54685 180 CONTINUE
54686
54687 RETURN
54688 END
54689
54690C*********************************************************************
54691
54692C...PYBKSB
54693C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
54694C...processes.
54695
54696 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
54697 IMPLICIT NONE
54698 INTEGER N,NP,INDX(N)
54699 COMPLEX*16 A(NP,NP),B(N)
54700 INTEGER I,II,J,LL
54701 COMPLEX*16 SUM
54702
54703 II=0
54704 DO 110 I=1,N
54705 LL=INDX(I)
54706 SUM=B(LL)
54707 B(LL)=B(I)
54708 IF (II.NE.0)THEN
54709 DO 100 J=II,I-1
54710 SUM=SUM-A(I,J)*B(J)
54711 100 CONTINUE
54712 ELSE IF (ABS(SUM).NE.0D0) THEN
54713 II=I
54714 ENDIF
54715 B(I)=SUM
54716 110 CONTINUE
54717 DO 130 I=N,1,-1
54718 SUM=B(I)
54719 DO 120 J=I+1,N
54720 SUM=SUM-A(I,J)*B(J)
54721 120 CONTINUE
54722 B(I)=SUM/A(I,I)
54723 130 CONTINUE
54724 RETURN
54725 END
54726
54727C***********************************************************************
54728
54729C...PYWIDX
54730C...Calculates full and partial widths of resonances.
54731C....copy of PYWIDT, used for techniparticle widths
54732
54733 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
54734
54735C...Double precision and integer declarations.
54736 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54737 IMPLICIT INTEGER(I-N)
54738 INTEGER PYK,PYCHGE,PYCOMP
54739C...Parameter statement to help give large particle numbers.
54740 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54741 &KEXCIT=4000000,KDIMEN=5000000)
54742C...Commonblocks.
54743 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54744 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54745 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54746 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54747 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54748 COMMON/PYINT1/MINT(400),VINT(400)
54749 COMMON/PYINT4/MWID(500),WIDS(500,5)
54750 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54751 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54752 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
54753 &/PYINT4/,/PYMSSM/,/PYTCSM/
54754C...Local arrays and saved variables.
54755 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
54756 &WID2SV(3,2)
54757 SAVE MOFSV,WIDWSV,WID2SV
54758 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
54759
54760C...Compressed code and sign; mass.
54761 KFLA=IABS(KFLR)
54762 KFLS=ISIGN(1,KFLR)
54763 KC=PYCOMP(KFLA)
54764 SHR=SQRT(SH)
54765 PMR=PMAS(KC,1)
54766
54767C...Reset width information.
54768 DO I=0,400
54769 WDTP(I)=0D0
54770 ENDDO
54771
54772C...Common electroweak and strong constants.
54773 XW=PARU(102)
54774 XWV=XW
54775 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
54776 XW1=1D0-XW
54777 AEM=PYALEM(SH)
54778 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
54779 AS=PYALPS(SH)
54780 RADC=1D0+AS/PARU(1)
54781
54782 IF(KFLA.EQ.23) THEN
54783C...Z0:
54784 XWC=1D0/(16D0*XW*XW1)
54785 FAC=(AEM*XWC/3D0)*SHR
54786 120 CONTINUE
54787 DO 130 I=1,MDCY(KC,3)
54788 IDC=I+MDCY(KC,2)-1
54789 IF(MDME(IDC,1).LT.0) GOTO 130
54790 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54791 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54792 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
54793 IF(I.LE.8) THEN
54794C...Z0 -> q + qbar
54795 EF=KCHG(I,1)/3D0
54796 AF=SIGN(1D0,EF+0.1D0)
54797 VF=AF-4D0*EF*XWV
54798 FCOF=3D0*RADC
54799 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
54800 ELSEIF(I.LE.16) THEN
54801C...Z0 -> l+ + l-, nu + nubar
54802 EF=KCHG(I+2,1)/3D0
54803 AF=SIGN(1D0,EF+0.1D0)
54804 VF=AF-4D0*EF*XWV
54805 FCOF=1D0
54806 ENDIF
54807 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
54808 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
54809 & BE34
54810 WDTP(0)=WDTP(0)+WDTP(I)
54811 130 CONTINUE
54812
54813
54814 ELSEIF(KFLA.EQ.24) THEN
54815C...W+/-:
54816 FAC=(AEM/(24D0*XW))*SHR
54817 DO 140 I=1,MDCY(KC,3)
54818 IDC=I+MDCY(KC,2)-1
54819 IF(MDME(IDC,1).LT.0) GOTO 140
54820 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
54821 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
54822 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
54823 WID2=1D0
54824 IF(I.LE.16) THEN
54825C...W+/- -> q + qbar'
54826 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
54827 ELSEIF(I.LE.20) THEN
54828C...W+/- -> l+/- + nu
54829 FCOF=1D0
54830 ENDIF
54831 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
54832 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
54833 WDTP(0)=WDTP(0)+WDTP(I)
54834 140 CONTINUE
54835
54836C.....V8 -> quark anti-quark
54837 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
54838 FAC=AS/6D0*SHR
54839 TANT3=RTCM(21)
54840 IF(ITCM(2).EQ.0) THEN
54841 IMDL=1
54842 ELSEIF(ITCM(2).EQ.1) THEN
54843 IMDL=2
54844 ENDIF
54845 DO 150 I=1,MDCY(KC,3)
54846 IDC=I+MDCY(KC,2)-1
54847 IF(MDME(IDC,1).LT.0) GOTO 150
54848 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
54849 RM1=PM1**2/SH
54850 IF(RM1.GT.0.25D0) GOTO 150
54851 WID2=1D0
54852 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
54853 FMIX=1D0/TANT3**2
54854 ELSE
54855 FMIX=TANT3**2
54856 ENDIF
54857 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
54858 IF(I.EQ.6) WID2=WIDS(6,1)
54859 WDTP(0)=WDTP(0)+WDTP(I)
54860 150 CONTINUE
54861 ENDIF
54862
54863 RETURN
54864 END
54865
54866C*********************************************************************
54867
54868C...PYRVSF
54869C...Calculates R-violating decays of sfermions.
54870C...P. Z. Skands
54871
54872 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
54873
54874C...Double precision and integer declarations.
54875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54876 IMPLICIT INTEGER(I-N)
54877C...Parameter statement to help give large particle numbers.
54878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54879 &KEXCIT=4000000,KDIMEN=5000000)
54880C...Commonblocks.
54881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54882 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54883 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54884 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54885 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
54886C...Local variables.
54887 DOUBLE PRECISION XLAM(0:400)
54888 INTEGER IDLAM(400,3), PYCOMP
54889 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
54890
54891C...IS R-VIOLATION ON ?
54892 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
54893C...Mass eigenstate counter
54894 ICNT=INT(KFIN/KSUSY1)
54895C...SM KF code of SUSY particle
54896 KFSM=KFIN-ICNT*KSUSY1
54897C...Squared Sparticle Mass
54898 SM=PMAS(PYCOMP(KFIN),1)**2
54899C... Squared mass of top quark
54900 SMT=PMAS(PYCOMP(6),1)**2
54901C...IS L-VIOLATION ON ?
54902 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
54903C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
54904 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
54905 & THEN
54906 K=INT((KFSM-9)/2)
54907 DO 110 I=1,3
54908 DO 100 J=1,3
54909 IF(I.NE.J) THEN
54910C...~e,~mu,~tau -> nu_I + lepton-_J
54911 LKNT = LKNT+1
54912 IDLAM(LKNT,1)= 12 +2*(I-1)
54913 IDLAM(LKNT,2)= 11 +2*(J-1)
54914 IDLAM(LKNT,3)= 0
54915 XLAM(LKNT)=0D0
54916 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
54917 IF (IMSS(51).NE.0) XLAM(LKNT) =
54918 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54919C...KINEMATICS CHECK
54920 IF (XLAM(LKNT).EQ.0D0) THEN
54921 LKNT=LKNT-1
54922 ENDIF
54923 ENDIF
54924 100 CONTINUE
54925 110 CONTINUE
54926C...~e,~mu,~tau -> nu_Ibar + lepton-_K
54927 J=INT((KFSM-9)/2)
54928 DO 130 I=1,3
54929 IF(I.NE.J) THEN
54930 DO 120 K=1,3
54931 LKNT = LKNT+1
54932 IDLAM(LKNT,1)=-12 -2*(I-1)
54933 IDLAM(LKNT,2)= 11 +2*(K-1)
54934 IDLAM(LKNT,3)= 0
54935 XLAM(LKNT)=0D0
54936 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54937 IF (IMSS(51).NE.0) XLAM(LKNT) =
54938 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54939C...KINEMATICS CHECK
54940 IF (XLAM(LKNT).EQ.0D0) THEN
54941 LKNT=LKNT-1
54942 ENDIF
54943 120 CONTINUE
54944 ENDIF
54945 130 CONTINUE
54946C...~e,~mu,~tau -> u_Jbar + d_K
54947 I=INT((KFSM-9)/2)
54948 DO 150 J=1,3
54949 DO 140 K=1,3
54950 LKNT = LKNT+1
54951 IDLAM(LKNT,1)=-2 -2*(J-1)
54952 IDLAM(LKNT,2)= 1 +2*(K-1)
54953 IDLAM(LKNT,3)= 0
54954 XLAM(LKNT)=0
54955 IF (IMSS(52).NE.0) THEN
54956C...Use massive top quark
54957 IF (IDLAM(LKNT,1).EQ.-6) THEN
54958 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
54959 & * (SM-SMT)
54960 XLAM(LKNT) =
54961 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
54962C...If no top quark, all decay products massless
54963 ELSE
54964 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
54965 XLAM(LKNT) =
54966 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54967 ENDIF
54968C...KINEMATICS CHECK
54969 IF (XLAM(LKNT).EQ.0D0) THEN
54970 LKNT=LKNT-1
54971 ENDIF
54972 ENDIF
54973 140 CONTINUE
54974 150 CONTINUE
54975 ENDIF
54976C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
54977C...No right-handed neutrinos
54978 IF(ICNT.EQ.1) THEN
54979 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
54980 J=INT((KFSM-10)/2)
54981 DO 170 I=1,3
54982 DO 160 K=1,3
54983 IF (I.NE.J) THEN
54984C...~nu_J -> lepton+_I + lepton-_K
54985 LKNT = LKNT+1
54986 IDLAM(LKNT,1)=-11 -2*(I-1)
54987 IDLAM(LKNT,2)= 11 +2*(K-1)
54988 IDLAM(LKNT,3)= 0
54989 XLAM(LKNT)=0D0
54990 RM2=RVLAM(I,J,K)**2 * SM
54991 IF (IMSS(51).NE.0) XLAM(LKNT) =
54992 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
54993C...KINEMATICS CHECK
54994 IF (XLAM(LKNT).EQ.0D0) THEN
54995 LKNT=LKNT-1
54996 ENDIF
54997 ENDIF
54998 160 CONTINUE
54999 170 CONTINUE
55000C...~nu_I -> dbar_J + d_K
55001 I=INT((KFSM-10)/2)
55002 DO 190 J=1,3
55003 DO 180 K=1,3
55004 LKNT = LKNT+1
55005 IDLAM(LKNT,1)=-1 -2*(J-1)
55006 IDLAM(LKNT,2)= 1 +2*(K-1)
55007 IDLAM(LKNT,3)= 0
55008 XLAM(LKNT)=0D0
55009 RM2=3*RVLAMP(I,J,K)**2 * SM
55010 IF (IMSS(52).NE.0) XLAM(LKNT) =
55011 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55012C...KINEMATICS CHECK
55013 IF (XLAM(LKNT).EQ.0D0) THEN
55014 LKNT=LKNT-1
55015 ENDIF
55016 180 CONTINUE
55017 190 CONTINUE
55018 ENDIF
55019 ENDIF
55020C * SDOWN -> NU(BAR) + D and LEPTON- + U
55021 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55022 J=INT((KFSM+1)/2)
55023 DO 210 I=1,3
55024 DO 200 K=1,3
55025C...~d_J -> nu_Ibar + d_K
55026 LKNT = LKNT+1
55027 IDLAM(LKNT,1)=-12 -2*(I-1)
55028 IDLAM(LKNT,2)= 1 +2*(K-1)
55029 IDLAM(LKNT,3)= 0
55030 XLAM(LKNT)=0D0
55031 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55032 IF (IMSS(52).NE.0) XLAM(LKNT) =
55033 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55034C...KINEMATICS CHECK
55035 IF (XLAM(LKNT).EQ.0D0) THEN
55036 LKNT=LKNT-1
55037 ENDIF
55038 200 CONTINUE
55039 210 CONTINUE
55040 K=INT((KFSM+1)/2)
55041 DO 240 I=1,3
55042 DO 230 J=1,3
55043C...~d_K -> nu_I + d_J
55044 LKNT = LKNT+1
55045 IDLAM(LKNT,1)= 12 +2*(I-1)
55046 IDLAM(LKNT,2)= 1 +2*(J-1)
55047 IDLAM(LKNT,3)= 0
55048 XLAM(LKNT)=0D0
55049 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55050 IF (IMSS(52).NE.0) XLAM(LKNT) =
55051 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55052C...KINEMATICS CHECK
55053 IF (XLAM(LKNT).EQ.0D0) THEN
55054 LKNT=LKNT-1
55055 ENDIF
55056C...~d_K -> lepton_I- + u_J
55057 220 LKNT = LKNT+1
55058 IDLAM(LKNT,1)= 11 +2*(I-1)
55059 IDLAM(LKNT,2)= 2 +2*(J-1)
55060 IDLAM(LKNT,3)= 0
55061 XLAM(LKNT)=0D0
55062 IF (IMSS(52).NE.0) THEN
55063C...Use massive top quark
55064 IF (IDLAM(LKNT,2).EQ.6) THEN
55065 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
55066 XLAM(LKNT) =
55067 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
55068C...If no top quark, all decay products massless
55069 ELSE
55070 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55071 XLAM(LKNT) =
55072 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55073 ENDIF
55074C...KINEMATICS CHECK
55075 IF (XLAM(LKNT).EQ.0D0) THEN
55076 LKNT=LKNT-1
55077 ENDIF
55078 ENDIF
55079 230 CONTINUE
55080 240 CONTINUE
55081 ENDIF
55082C * SUP -> LEPTON+ + D
55083 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55084 J=NINT(KFSM/2.)
55085 DO 260 I=1,3
55086 DO 250 K=1,3
55087C...~u_J -> lepton_I+ + d_K
55088 LKNT = LKNT+1
55089 IDLAM(LKNT,1)=-11 -2*(I-1)
55090 IDLAM(LKNT,2)= 1 +2*(K-1)
55091 IDLAM(LKNT,3)= 0
55092 XLAM(LKNT)=0D0
55093 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
55094 IF (IMSS(52).NE.0) XLAM(LKNT) =
55095 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55096C...KINEMATICS CHECK
55097 IF (XLAM(LKNT).EQ.0D0) THEN
55098 LKNT=LKNT-1
55099 ENDIF
55100 250 CONTINUE
55101 260 CONTINUE
55102 ENDIF
55103 ENDIF
55104C...BARYON NUMBER VIOLATING DECAYS
55105 IF (IMSS(53).GE.1) THEN
55106C * SUP -> DBAR + DBAR
55107 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
55108 I = KFSM/2
55109 DO 280 J=1,3
55110 DO 270 K=1,3
55111C...~u_I -> dbar_J + dbar_K
55112 IF (J.LT.K) THEN
55113C...(anti-) symmetry J <-> K.
55114 LKNT = LKNT + 1
55115 IDLAM(LKNT,1) = -1 -2*(J-1)
55116 IDLAM(LKNT,2) = -1 -2*(K-1)
55117 IDLAM(LKNT,3) = 0
55118 XLAM(LKNT) = 0D0
55119 RM2 = 2.*(RVLAMB(I,J,K)**2)
55120 & * SFMIX(KFSM,2*ICNT)**2 * SM
55121 XLAM(LKNT) =
55122 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55123C...KINEMATICS CHECK
55124 IF (XLAM(LKNT).EQ.0D0) THEN
55125 LKNT = LKNT-1
55126 ENDIF
55127 ENDIF
55128 270 CONTINUE
55129 280 CONTINUE
55130 ENDIF
55131C * SDOWN -> UBAR + DBAR
55132 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
55133 K=(KFSM+1)/2
55134 DO 300 I=1,3
55135 DO 290 J=1,3
55136C...LAMB coupling antisymmetric in J and K.
55137 IF (J.NE.K) THEN
55138C...~d_K -> ubar_I + dbar_K
55139 LKNT = LKNT + 1
55140 IDLAM(LKNT,1)= -2 -2*(I-1)
55141 IDLAM(LKNT,2)= -1 -2*(J-1)
55142 IDLAM(LKNT,3)= 0
55143 XLAM(LKNT)=0D0
55144C...Use massive top quark
55145 IF (IDLAM(LKNT,1).EQ.-6) THEN
55146 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
55147 & )
55148 XLAM(LKNT) =
55149 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
55150C...If no top quark, all decay products massless
55151 ELSE
55152 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
55153 XLAM(LKNT) =
55154 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
55155 ENDIF
55156C...KINEMATICS CHECK
55157 IF (XLAM(LKNT).EQ.0D0) THEN
55158 LKNT=LKNT-1
55159 ENDIF
55160 ENDIF
55161 290 CONTINUE
55162 300 CONTINUE
55163 ENDIF
55164 ENDIF
55165 ENDIF
55166
55167 RETURN
55168 END
55169
55170C*********************************************************************
55171
55172C...PYRVNE
55173C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
55174C...P. Z. Skands
55175
55176 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
55177
55178C...Double precision and integer declarations.
55179 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55180 IMPLICIT INTEGER(I-N)
55181C...Parameter statement to help give large particle numbers.
55182 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55183 &KEXCIT=4000000,KDIMEN=5000000)
55184C...Commonblocks.
55185 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55186 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55187 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55188 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55189 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55190 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55191C...Local variables.
55192 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55193 & ,DCMASS,KFR(3)
55194 DOUBLE PRECISION XLAM(0:400)
55195 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
55196 INTEGER IDLAM(400,3), PYCOMP
55197 LOGICAL DCMASS
55198 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
55199
55200C...R-VIOLATING DECAYS
55201 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55202 KFSM=KFIN-KSUSY1
55203 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
55204C...WHICH NEUTRALINO ?
55205 NCHI=1
55206 IF (KFSM.EQ.23) NCHI=2
55207 IF (KFSM.EQ.25) NCHI=3
55208 IF (KFSM.EQ.35) NCHI=4
55209C...SIGN OF MASS (Opposite convention as HERWIG)
55210 ISM = 1
55211 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
55212
55213C...Useful parameters for the calculation of the A and B constants.
55214 WMASS = PMAS(PYCOMP(24),1)
55215 ECHG = 2*SQRT(PARU(103)*PARU(1))
55216 COSB=1/(SQRT(1+RMSS(5)**2))
55217 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
55218 COSW=SQRT(1-PARU(102))
55219 SINW=SQRT(PARU(102))
55220 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
55221C...Run quark masses to neutralino mass squared (for Higgs-type
55222C...couplings)
55223 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
55224 DO 100 I=1,6
55225 RMQ(I)=PYMRUN(I,SQMCHI)
55226 100 CONTINUE
55227C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
55228 DO 110 NCHJ=1,4
55229 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
55230 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
55231 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
55232 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
55233 110 CONTINUE
55234 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
55235 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
55236 C2=ECHG*ZPMIX(NCHI,1)
55237 C3=GW*ZPMIX(NCHI,2)/COSW
55238 EU=2D0/3D0
55239 ED=-1D0/3D0
55240C... AB(x,y,z):
55241C x=1-2 : Select A or B constant (1:A ; 2:B)
55242C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55243C 11-16:e,nu_e,mu,...)
55244C z=1-2 : Mass eigenstate number
55245C...CALCULATE COUPLINGS
55246 DO 120 I = 11,15,2
55247 CMS=PMAS(PYCOMP(I),1)
55248C...Intermediate sleptons
55249 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
55250 & *(C2-C3*SINW**2))
55251 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
55252 & *(C2-C3*SINW**2))
55253 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
55254 & **2))
55255 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
55256 & **2))
55257C...Inermediate sneutrinos
55258 AB(1,I+1,1)=0D0
55259 AB(2,I+1,1)=5D-1*C3
55260 AB(1,I+1,2)=0D0
55261 AB(2,I+1,2)=0D0
55262C...Inermediate sdown
55263 J=I-10
55264 CMS=RMQ(J)
55265 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
55266 & *ED*(C2-C3*SINW**2))
55267 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
55268 & *ED*(C2-C3*SINW**2))
55269 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
55270 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55271 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
55272 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
55273C...Inermediate sup
55274 J=J+1
55275 CMS=RMQ(J)
55276 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
55277 & *EU*(C2-C3*SINW**2))
55278 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
55279 & *EU*(C2-C3*SINW**2))
55280 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
55281 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55282 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
55283 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
55284 120 CONTINUE
55285
55286 IF (IMSS(51).GE.1) THEN
55287C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
55288C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
55289C...STEP IN I,J,K USING SINGLE COUNTER
55290 DO 130 ISC=0,26
55291C...LAMBDA COUPLING ASYM IN I,J
55292 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55293 LKNT = LKNT+1
55294 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55295 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55296 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55297 XLAM(LKNT) = 0D0
55298C...Set coupling, and decay product masses on/off
55299 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55300 & ,MOD(ISC,3)+1)**2
55301 DCMASS=.FALSE.
55302 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
55303 & DCMASS = .TRUE.
55304C...Resonance KF codes (1=I,2=J,3=K)
55305 KFR(1)=-IDLAM(LKNT,1)
55306 KFR(2)=-IDLAM(LKNT,2)
55307 KFR(3)=-IDLAM(LKNT,3)
55308C...Calculate width.
55309 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55310 & IDLAM(LKNT,3),XLAM(LKNT))
55311 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55312C...Charge conjugate mode.
55313 LKNT=LKNT+1
55314 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55315 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55316 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55317 XLAM(LKNT)=XLAM(LKNT-1)
55318C...KINEMATICS CHECK
55319 IF (XLAM(LKNT).EQ.0D0) THEN
55320 LKNT=LKNT-2
55321 ENDIF
55322 ENDIF
55323 130 CONTINUE
55324 ENDIF
55325
55326 IF (IMSS(52).GE.1) THEN
55327C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
55328C * CHI0 -> NUBAR_I + DBAR_J + D_K
55329 DO 140 ISC=0,26
55330 LKNT = LKNT+1
55331 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55332 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55333 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55334 XLAM(LKNT) = 0D0
55335C...Set coupling, and decay product masses on/off
55336 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55337 & ,MOD(ISC,3)+1)**2
55338 DCMASS=.FALSE.
55339 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
55340 & DCMASS = .TRUE.
55341C...Resonance KF codes (1=I,2=J,3=K)
55342 KFR(1)=-IDLAM(LKNT,1)
55343 KFR(2)=-IDLAM(LKNT,2)
55344 KFR(3)=-IDLAM(LKNT,3)
55345C...Calculate width.
55346 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55347 & ,XLAM(LKNT))
55348 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55349C...Charge conjugate mode.
55350 LKNT=LKNT+1
55351 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55352 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55353 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55354 XLAM(LKNT)=XLAM(LKNT-1)
55355C...KINEMATICS CHECK
55356 IF (XLAM(LKNT).EQ.0D0) THEN
55357 LKNT=LKNT-2
55358 ENDIF
55359
55360C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
55361 LKNT = LKNT+1
55362 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55363 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55364 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55365 XLAM(LKNT) = 0D0
55366C...Set coupling, and decay product masses on/off
55367 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
55368 & ,MOD(ISC,3)+1)**2
55369 DCMASS=.FALSE.
55370 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
55371 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55372C...Resonance KF codes (1=I,2=J,3=K)
55373 KFR(1)=-IDLAM(LKNT,1)
55374 KFR(2)=-IDLAM(LKNT,2)
55375 KFR(3)=-IDLAM(LKNT,3)
55376C...Calculate width.
55377 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55378 & ,XLAM(LKNT))
55379 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55380C...Charge conjugate mode.
55381 LKNT=LKNT+1
55382 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55383 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55384 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55385 XLAM(LKNT)=XLAM(LKNT-1)
55386C...KINEMATICS CHECK
55387 IF (XLAM(LKNT).EQ.0D0) THEN
55388 LKNT=LKNT-2
55389 ENDIF
55390 140 CONTINUE
55391 ENDIF
55392
55393 IF (IMSS(53).GE.1) THEN
55394C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
55395C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
55396 DO 150 ISC=0,26
55397C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
55398 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
55399 LKNT = LKNT+1
55400 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
55401 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55402 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55403 XLAM(LKNT) = 0D0
55404C...Set coupling, and decay product masses on/off
55405 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
55406 & +1,MOD(ISC,3)+1)**2
55407 DCMASS=.FALSE.
55408 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
55409 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
55410C...Resonance KF codes (1=I,2=J,3=K)
55411 KFR(1) = IDLAM(LKNT,1)
55412 KFR(2) = IDLAM(LKNT,2)
55413 KFR(3) = IDLAM(LKNT,3)
55414C...Calculate width.
55415 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55416 & IDLAM(LKNT,3),XLAM(LKNT))
55417 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55418C...Charge conjugate mode.
55419 LKNT=LKNT+1
55420 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
55421 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
55422 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
55423 XLAM(LKNT)=XLAM(LKNT-1)
55424C...KINEMATICS CHECK
55425 IF (XLAM(LKNT).EQ.0D0) THEN
55426 LKNT=LKNT-2
55427 ENDIF
55428 ENDIF
55429 150 CONTINUE
55430 ENDIF
55431 ENDIF
55432 ENDIF
55433
55434 RETURN
55435 END
55436
55437C*********************************************************************
55438
55439C...PYRVCH
55440C...Calculates R-violating chargino decay widths.
55441C...P. Z. Skands
55442
55443 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
55444
55445C...Double precision and integer declarations.
55446 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55447 IMPLICIT INTEGER(I-N)
55448C...Parameter statement to help give large particle numbers.
55449 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55450 &KEXCIT=4000000,KDIMEN=5000000)
55451C...Commonblocks.
55452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55453 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55454 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55455 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55456 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55457 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55458C...Local variables.
55459 DOUBLE PRECISION XLAM(0:400)
55460 INTEGER IDLAM(400,3), PYCOMP
55461C...Information from main routine to PYRVGW
55462 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55463 & ,DCMASS,KFR(3)
55464C...Auxiliary variables needed for BV (RV Gauge STOre)
55465 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55466 & ,RVLJKI,RVLJIK
55467C...Running quark masses
55468 DOUBLE PRECISION RMQ(6)
55469C...Decay product masses on/off
55470 LOGICAL DCMASS
55471 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55472 & /RVGSTO/
55473
55474
55475C...IF R-VIOLATION ON.
55476 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
55477 KFSM=KFIN-KSUSY1
55478 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
55479C...WHICH CHARGINO ?
55480 NCHI = 1
55481 IF (KFSM.EQ.37) NCHI = 2
55482
55483C...Useful parameters for calculating the A and B constants.
55484C...SIGN OF MASS (Opposite convention as HERWIG)
55485 ISM = 1
55486 IF (SMW(NCHI).LT.0D0) ISM = -1
55487 WMASS = PMAS(PYCOMP(24),1)
55488 COSB = 1/(SQRT(1+RMSS(5)**2))
55489 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
55490 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
55491 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
55492 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
55493 C2 = UMIX(NCHI,1)
55494 C3 = VMIX(NCHI,1)
55495C...Running masses at Q^2=MCHI^2.
55496 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
55497 DO 100 I=1,6
55498 RMQ(I)=PYMRUN(I,SQMCHI)
55499 100 CONTINUE
55500
55501C... AB(x,y,z) coefficients:
55502C x=1-2 : A or B coefficient (1:A ; 2:B)
55503C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55504C 11-16:e,nu_e,mu,...)
55505C z=1-2 : Mass eigenstate number
55506 DO 110 I = 11,15,2
55507C...Intermediate sleptons
55508 AB(1,I,1) = 0D0
55509 AB(1,I,2) = 0D0
55510 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
55511 & SFMIX(I,1)*C2
55512 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
55513 & SFMIX(I,3)*C2
55514C...Intermediate sneutrinos
55515 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
55516 AB(1,I+1,2) = 0D0
55517 AB(2,I+1,1) = ISM*C3
55518 AB(2,I+1,2) = 0D0
55519C...Intermediate sdown
55520 J=I-10
55521 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
55522 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
55523 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
55524 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
55525C...Intermediate sup
55526 J=J+1
55527 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
55528 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
55529 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
55530 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
55531 110 CONTINUE
55532
55533C...LLE TYPE R-VIOLATION
55534 IF (IMSS(51).GE.1) THEN
55535C...LOOP OVER DECAY MODES
55536 DO 140 ISC=0,26
55537
55538C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
55539 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
55540 LKNT = LKNT+1
55541 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
55542 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
55543 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
55544 XLAM(LKNT) = 0D0
55545C...Set coupling, and decay product masses on/off
55546 RVLAMC = GW2 * 5D-1 *
55547 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
55548 & **2
55549 DCMASS=.FALSE.
55550 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
55551C...Resonance KF codes (1=I,2=J,3=K).
55552 KFR(1) = 0
55553 KFR(2) = 0
55554 KFR(3) = -IDLAM(LKNT,3)+1
55555C...Calculate width.
55556 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55557 & IDLAM(LKNT,3),XLAM(LKNT))
55558 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55559C...KINEMATICS CHECK
55560 IF (XLAM(LKNT).EQ.0D0) THEN
55561 LKNT=LKNT-1
55562 ENDIF
55563
55564C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
55565 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
55566 LKNT = LKNT+1
55567 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55568 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
55569 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
55570 XLAM(LKNT) = 0D0
55571C...Set coupling, and decay product masses on/off
55572 RVLAMC = GW2 * 5D-1 *
55573 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55574C...I,J SYMMETRY => FACTOR 2
55575 RVLAMC=2*RVLAMC
55576 DCMASS=.FALSE.
55577 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
55578C...Resonance KF codes (1=I,2=J,3=K)
55579 KFR(1)=IDLAM(LKNT,1)-1
55580 KFR(2)=IDLAM(LKNT,2)-1
55581 KFR(3)=0
55582C...Calculate width.
55583 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55584 & IDLAM(LKNT,3),XLAM(LKNT))
55585 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55586C...KINEMATICS CHECK
55587 IF (XLAM(LKNT).EQ.0D0) THEN
55588 LKNT=LKNT-1
55589 ENDIF
55590 130 ENDIF
55591
55592C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
55593 LKNT = LKNT+1
55594 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55595 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
55596 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
55597 XLAM(LKNT) = 0D0
55598C...Set coupling, and decay product masses on/off
55599 RVLAMC = GW2 * 5D-1 *
55600 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55601C...I,J SYMMETRY => FACTOR 2
55602 RVLAMC=2*RVLAMC
55603 DCMASS=.FALSE.
55604 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
55605 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
55606C...Resonance KF codes (1=I,2=J,3=K)
55607 KFR(1) =-IDLAM(LKNT,1)+1
55608 KFR(2) =-IDLAM(LKNT,2)+1
55609 KFR(3) = 0
55610C...Calculate width.
55611 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55612 & IDLAM(LKNT,3),XLAM(LKNT))
55613 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55614C...KINEMATICS CHECK
55615 IF (XLAM(LKNT).EQ.0D0) THEN
55616 LKNT=LKNT-1
55617 ENDIF
55618 ENDIF
55619 140 CONTINUE
55620 ENDIF
55621
55622C...LQD TYPE R-VIOLATION
55623 IF (IMSS(52).GE.1) THEN
55624C...LOOP OVER DECAY MODES
55625 DO 180 ISC=0,26
55626
55627C...CHI+ -> NUBAR_I + DBAR_J + U_K
55628 LKNT = LKNT+1
55629 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55630 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55631 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55632 XLAM(LKNT) = 0D0
55633C...Set coupling, and decay product masses on/off
55634 RVLAMC = 3. * GW2 * 5D-1 *
55635 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55636 DCMASS=.FALSE.
55637 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
55638 & DCMASS = .TRUE.
55639C...Resonance KF codes (1=I,2=J,3=K)
55640 KFR(1)=0
55641 KFR(2)=0
55642 KFR(3)=-IDLAM(LKNT,3)+1
55643C...Calculate width.
55644 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55645 & ,XLAM(LKNT))
55646 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55647C...KINEMATICS CHECK
55648 IF (XLAM(LKNT).EQ.0D0) THEN
55649 LKNT=LKNT-1
55650 ENDIF
55651
55652C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
55653 150 LKNT = LKNT+1
55654 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55655 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
55656 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
55657 XLAM(LKNT) = 0D0
55658C...Set coupling, and decay product masses on/off
55659 RVLAMC = 3. * GW2 * 5D-1 *
55660 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55661 DCMASS=.FALSE.
55662 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
55663 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
55664C...Resonance KF codes (1=I,2=J,3=K)
55665 KFR(1)=0
55666 KFR(2)=0
55667 KFR(3)=-IDLAM(LKNT,3)+1
55668C...Calculate width.
55669 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55670 & ,XLAM(LKNT))
55671 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55672C...KINEMATICS CHECK
55673 IF (XLAM(LKNT).EQ.0D0) THEN
55674 LKNT=LKNT-1
55675 ENDIF
55676
55677C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
55678 160 LKNT = LKNT+1
55679 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
55680 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55681 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55682 XLAM(LKNT) = 0D0
55683C...Set coupling, and decay product masses on/off
55684 RVLAMC = 3. * GW2 * 5D-1 *
55685 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55686 DCMASS = .FALSE.
55687 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
55688 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
55689C...Resonance KF codes (1=I,2=J,3=K)
55690 KFR(1)=-IDLAM(LKNT,1)+1
55691 KFR(2)=-IDLAM(LKNT,2)+1
55692 KFR(3)=0
55693C...Calculate width.
55694 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55695 & ,XLAM(LKNT))
55696 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55697C...KINEMATICS CHECK
55698 IF (XLAM(LKNT).EQ.0D0) THEN
55699 LKNT=LKNT-1
55700 ENDIF
55701
55702C * CHI+ -> NU_I + U_J + DBAR_K.
55703 170 LKNT = LKNT+1
55704 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
55705 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55706 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55707 XLAM(LKNT) = 0D0
55708C...Set coupling, and decay product masses on/off
55709 DCMASS = .FALSE.
55710 RVLAMC = 3. * GW2 * 5D-1 *
55711 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55712 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
55713 & DCMASS = .TRUE.
55714C...Resonance KF codes (1=I,2=J,3=K)
55715 KFR(1)=IDLAM(LKNT,1)-1
55716 KFR(2)=IDLAM(LKNT,2)-1
55717 KFR(3)=0
55718C...Calculate width.
55719 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55720 & ,XLAM(LKNT))
55721 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55722C...KINEMATICS CHECK
55723 IF (XLAM(LKNT).EQ.0D0) THEN
55724 LKNT=LKNT-1
55725 ENDIF
55726
55727 180 CONTINUE
55728 ENDIF
55729
55730C...UDD TYPE R-VIOLATION
55731C...These decays need special treatment since more than one BV coupling
55732C...contributes (with interference). Consider e.g. (symbolically)
55733C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
55734C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
55735C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
55736C...The problem is that a single call to PYRVGW would evaluate all
55737C...these terms and sum them, but without the different couplings. The
55738C...way out is to call PYRVGW three times, once for the first line, once
55739C...for the second line, and then once for all the lines (it is
55740C...impossible to get just the last line out) without multiplying by
55741C...couplings. The last line is then obtained as the result of the third
55742C...call minus the results of the two first calls. Each term is then
55743C...multiplied by its respective coupling before the whole thing is
55744C...summed up in XLAM.
55745C...Note that with three interfering resonances, this procedure becomes
55746C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
55747
55748 IF (IMSS(53).GE.1) THEN
55749C...LOOP OVER DECAY MODES
55750 DO 190 ISC=1,25
55751
55752C...CHI+ -> U_I + U_J + D_K
55753C...Decay mode I<->J symmetric.
55754 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
55755 LKNT = LKNT+1
55756 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
55757 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
55758 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55759 XLAM(LKNT) = 0D0
55760C...Set coupling, and decay product masses on/off
55761 RVLAMC= 6. * GW2 * 5D-1
55762 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
55763 & +1)
55764 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55765 & +1)
55766 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
55767 & * RVLAMC
55768 DCMASS=.FALSE.
55769 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
55770 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
55771C...Resonance KF codes (1=I,2=J,3=K)
55772 KFR(1) = -IDLAM(LKNT,1)+1
55773 KFR(2) = 0
55774 KFR(3) = 0
55775C...Calculate width.
55776 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55777 & IDLAM(LKNT,3),XRESI)
55778C...Resonance KF codes (1=I,2=J,3=K)
55779 KFR(1) = 0
55780 KFR(2) = -IDLAM(LKNT,2)+1
55781 KFR(3) = 0
55782C...Calculate width.
55783 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55784 & IDLAM(LKNT,3),XRESJ)
55785C...Resonance KF codes (1=I,2=J,3=K)
55786 KFR(1) = -IDLAM(LKNT,1)+1
55787 KFR(2) = -IDLAM(LKNT,2)+1
55788 KFR(3) = 0
55789C...Calculate width.
55790 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55791 & IDLAM(LKNT,3),XRESIJ)
55792 IF (ABS((XRESI+XRESJ)/XRESIJ-1.).GT.1D-4) THEN
55793 XRESIJ = XRESIJ-XRESI-XRESJ
55794 ELSE
55795 XRESIJ = 0D0
55796 ENDIF
55797C...CALCULATE TOTAL WIDTH
55798 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
55799 & + RVLJIK*RVLIJK * XRESIJ
55800 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55801C...KINEMATICS CHECK
55802 IF (XLAM(LKNT).EQ.0D0) THEN
55803 LKNT=LKNT-1
55804 ENDIF
55805 ENDIF
55806C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
55807C...Symmetry I<->J<->K.
55808 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
55809 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
55810 LKNT = LKNT+1
55811 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
55812 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55813 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
55814 XLAM(LKNT) = 0D0
55815C...Set coupling, and decay product masses on/off
55816 RVLAMC = 6. * GW2 * 5D-1
55817 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
55818 & +1)
55819 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
55820 & +1)
55821 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
55822 & +1)
55823 DCMASS = .FALSE.
55824 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
55825 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
55826C...Collect symmetry factors
55827 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
55828 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
55829 & RVLAMC = 5D-1 * RVLAMC
55830C...Resonance KF codes (1=I,2=J,3=K)
55831 KFR(1) = IDLAM(LKNT,1)-1
55832 KFR(2) = 0
55833 KFR(3) = 0
55834C...Calculate width.
55835 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55836 & IDLAM(LKNT,3),XRESI)
55837C...Resonance KF codes (1=I,2=J,3=K)
55838 KFR(1) = 0
55839 KFR(2) = IDLAM(LKNT,2)-1
55840 KFR(3) = 0
55841C...Calculate width.
55842 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55843 & IDLAM(LKNT,3),XRESJ)
55844C...Resonance KF codes (1=I,2=J,3=K)
55845 KFR(1) = 0
55846 KFR(2) = 0
55847 KFR(3) = IDLAM(LKNT,3)-1
55848C...Calculate width.
55849 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55850 & IDLAM(LKNT,3),XRESK)
55851C...Resonance KF codes (1=I,2=J,3=K)
55852 KFR(1) = IDLAM(LKNT,1)-1
55853 KFR(2) = IDLAM(LKNT,2)-1
55854 KFR(3) = 0
55855C...Calculate width.
55856 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55857 & IDLAM(LKNT,3),XRESIJ)
55858 IF (ABS(XRESIJ/(XRESI+XRESJ)-1.).GT.1D-4) THEN
55859 XRESIJ = XRESI+XRESJ-XRESIJ
55860 ELSE
55861 XRESIJ = 0D0
55862 ENDIF
55863C...Resonance KF codes (1=I,2=J,3=K)
55864 KFR(1) = 0
55865 KFR(2) = IDLAM(LKNT,2)-1
55866 KFR(3) = IDLAM(LKNT,3)-1
55867C...Calculate width.
55868 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55869 & IDLAM(LKNT,3),XRESJK)
55870 IF (ABS(XRESJK/(XRESJ+XRESK)-1.).GT.1D-4) THEN
55871 XRESJK = XRESJ+XRESK-XRESJK
55872 ELSE
55873 XRESJK = 0D0
55874 ENDIF
55875C...Resonance KF codes (1=I,2=J,3=K)
55876 KFR(1) = IDLAM(LKNT,1)-1
55877 KFR(2) = 0
55878 KFR(3) = IDLAM(LKNT,3)-1
55879C...Calculate width.
55880 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
55881 & IDLAM(LKNT,3),XRESIK)
55882 IF (ABS(XRESIK/(XRESI+XRESK)-1.).GT.1D-4) THEN
55883 XRESIK = XRESI+XRESK-XRESIK
55884 ELSE
55885 XRESIK = 0D0
55886 ENDIF
55887C...CALCULATE TOTAL WIDTH
55888 XLAM(LKNT) =
55889 & RVLIJK**2 * XRESI
55890 & + RVLJKI**2 * XRESJ
55891 & + RVLKIJ**2 * XRESK
55892 & + RVLIJK*RVLJKI * XRESIJ
55893 & + RVLIJK*RVLKIJ * XRESIK
55894 & + RVLJKI*RVLKIJ * XRESJK
55895 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
55896C...KINEMATICS CHECK
55897 IF (XLAM(LKNT).EQ.0D0) THEN
55898 LKNT=LKNT-1
55899 ENDIF
55900 ENDIF
55901 190 CONTINUE
55902 ENDIF
55903 ENDIF
55904 ENDIF
55905
55906 RETURN
55907 END
55908
55909C*********************************************************************
55910
55911C...PYRVGL
55912C...Calculates R-violating gluino decay widths.
55913C...See BV part of PYRVCH for comments about the way the BV decay width
55914C...is calculated. Same comments apply here.
55915C...P. Z. Skands
55916
55917 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
55918
55919C...Double precision and integer declarations.
55920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55921 IMPLICIT INTEGER(I-N)
55922C...Parameter statement to help give large particle numbers.
55923 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55924 &KEXCIT=4000000,KDIMEN=5000000)
55925C...Commonblocks.
55926 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55927 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55928 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
55929 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
55930 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
55931 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
55932C...Local variables.
55933 DOUBLE PRECISION XLAM(0:400)
55934 INTEGER IDLAM(400,3), PYCOMP
55935C...Information from main routine to PYRVGW
55936 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
55937 & ,DCMASS,KFR(3)
55938C...Auxiliary variables needed for BV (RV Gauge STOre)
55939 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
55940 & ,RVLJKI,RVLJIK
55941C...Running quark masses
55942 DOUBLE PRECISION RMQ(6)
55943C...Decay product masses on/off
55944 LOGICAL DCMASS
55945 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
55946 & /RVGSTO/
55947
55948C...IF LQD OR UDD TYPE R-VIOLATION ON.
55949 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
55950 KFSM=KFIN-KSUSY1
55951
55952C... AB(x,y,z):
55953C x=1-2 : Select A or B coupling (1:A ; 2:B)
55954C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
55955C 11-16:e,nu_e,mu,... not used here)
55956C z=1-2 : Mass eigenstate number
55957 DO 100 I = 1,6
55958C...A Couplings
55959 AB(1,I,1) = SFMIX(I,2)
55960 AB(1,I,2) = SFMIX(I,4)
55961C...B Couplings
55962 AB(2,I,1) = -SFMIX(I,1)
55963 AB(2,I,2) = -SFMIX(I,3)
55964 100 CONTINUE
55965 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
55966C...LQD DECAYS.
55967 IF (IMSS(52).GE.1) THEN
55968C...STEP IN I,J,K USING SINGLE COUNTER
55969 DO 120 ISC=0,26
55970C * GLUINO -> NUBAR_I + DBAR_J + D_K.
55971 LKNT = LKNT+1
55972 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
55973 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
55974 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
55975 XLAM(LKNT)=0D0
55976C...Set coupling, and decay product masses on/off
55977 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
55978 & * 5D-1 * GSTR2
55979 DCMASS = .FALSE.
55980 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
55981C...Resonance KF codes (1=I,2=J,3=K)
55982 KFR(1) = 0
55983 KFR(2) = -IDLAM(LKNT,2)
55984 KFR(3) = -IDLAM(LKNT,3)
55985C...Calculate width.
55986 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
55987 & ,XLAM(LKNT))
55988C...Normalize
55989 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
55990C...Charge conjugate mode.
55991 110 LKNT = LKNT+1
55992 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
55993 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
55994 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
55995 XLAM(LKNT) = XLAM(LKNT-1)
55996C...KINEMATICS CHECK
55997 IF (XLAM(LKNT).EQ.0D0) THEN
55998 LKNT=LKNT-2
55999 ENDIF
56000
56001C * GLUINO -> LEPTON+_I + UBAR_J + D_K
56002 LKNT = LKNT+1
56003 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
56004 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
56005 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
56006 XLAM(LKNT)=0D0
56007C...Set coupling, and decay product masses on/off
56008 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56009 & **2* 5D-1 * GSTR2
56010 DCMASS = .FALSE.
56011 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
56012 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
56013C...Resonance KF codes (1=I,2=J,3=K)
56014 KFR(1) = 0
56015 KFR(2) = -IDLAM(LKNT,2)
56016 KFR(3) = -IDLAM(LKNT,3)
56017C...Calculate width.
56018 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56019 & ,XLAM(LKNT))
56020 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56021C...Charge conjugate mode.
56022 LKNT=LKNT+1
56023 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
56024 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
56025 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
56026 XLAM(LKNT) = XLAM(LKNT-1)
56027C...KINEMATICS CHECK
56028 IF (XLAM(LKNT).EQ.0D0) THEN
56029 LKNT=LKNT-2
56030 ENDIF
56031
56032 120 CONTINUE
56033 ENDIF
56034
56035C...UDD DECAYS.
56036 IF (IMSS(53).GE.1) THEN
56037C...STEP IN I,J,K USING SINGLE COUNTER
56038 DO 130 ISC=0,26
56039C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
56040 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
56041 LKNT = LKNT+1
56042 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
56043 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
56044 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
56045 XLAM(LKNT)=0D0
56046C...Set coupling, and decay product masses on/off. A factor of 2 for
56047C...(N_C-1) has been used to cancel a factor 0.5.
56048 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
56049 & **2 * GSTR2
56050 DCMASS = .FALSE.
56051 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
56052 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
56053C...Resonance KF codes (1=I,2=J,3=K)
56054 KFR(1) = IDLAM(LKNT,1)
56055 KFR(2) = 0
56056 KFR(3) = 0
56057C...Calculate width.
56058 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56059 & ,XRESI)
56060C...Resonance KF codes (1=I,2=J,3=K)
56061 KFR(1) = 0
56062 KFR(2) = IDLAM(LKNT,2)
56063 KFR(3) = 0
56064C...Calculate width.
56065 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56066 & ,XRESJ)
56067C...Resonance KF codes (1=I,2=J,3=K)
56068 KFR(1) = 0
56069 KFR(2) = 0
56070 KFR(3) = IDLAM(LKNT,3)
56071C...Calculate width.
56072 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56073 & ,XRESK)
56074C...Resonance KF codes (1=I,2=J,3=K)
56075 KFR(1) = IDLAM(LKNT,1)
56076 KFR(2) = IDLAM(LKNT,2)
56077 KFR(3) = 0
56078C...Calculate width.
56079 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56080 & ,XRESIJ)
56081C...Calculate interference function. (Factor -1/2 to make up for factor
56082C...-2 in PYRVGW.
56083 IF (ABS((XRESI+XRESJ)/XRESIJ-1D0).GT.1D-4) THEN
56084 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
56085 ELSE
56086 XRESIJ = 0D0
56087 ENDIF
56088C...Resonance KF codes (1=I,2=J,3=K)
56089 KFR(1) = 0
56090 KFR(2) = IDLAM(LKNT,2)
56091 KFR(3) = IDLAM(LKNT,3)
56092C...Calculate width.
56093 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56094 & ,XRESJK)
56095 IF (ABS((XRESJ+XRESK)/XRESJK-1).GT.1D-4) THEN
56096 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
56097 ELSE
56098 XRESJK = 0D0
56099 ENDIF
56100C...Resonance KF codes (1=I,2=J,3=K)
56101 KFR(1) = IDLAM(LKNT,1)
56102 KFR(2) = 0
56103 KFR(3) = IDLAM(LKNT,3)
56104C...Calculate width.
56105 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
56106 & ,XRESIK)
56107 IF (ABS((XRESI+XRESK)/XRESIK-1).GT.1D-4) THEN
56108 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
56109 ELSE
56110 XRESIK = 0D0
56111 ENDIF
56112C...Calculate total width (factor 1/2 from 1/(N_C-1))
56113 XLAM(LKNT) = XRESI + XRESJ + XRESK
56114 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
56115C...Normalize
56116 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
56117C...Charge conjugate mode.
56118 LKNT = LKNT+1
56119 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
56120 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
56121 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
56122 XLAM(LKNT) = XLAM(LKNT-1)
56123C...KINEMATICS CHECK
56124 IF (XLAM(LKNT).EQ.0D0) THEN
56125 LKNT=LKNT-2
56126 ENDIF
56127 ENDIF
56128 130 CONTINUE
56129 ENDIF
56130 ENDIF
56131 RETURN
56132 END
56133
56134C*********************************************************************
56135
56136C...PYRVSB
56137C...Auxiliary function to PYRVSF for calculating R-Violating
56138C...sfermion widths. Though the decay products are most often treated
56139C...as massless in the calculation, the kinematical boundary of phase
56140C...space is tested using the true masses.
56141C...MODE = 1: All decay products massive
56142C...MODE = 2: Decay product 1 massless
56143C...MODE = 3: Decay product 2 massless
56144C...MODE = 4: All decay products massless
56145
56146 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
56147
56148 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56149 IMPLICIT INTEGER (I-N)
56150 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56151 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56152 SAVE /PYDAT1/,/PYDAT2/
56153 DOUBLE PRECISION SM(3)
56154 INTEGER PYCOMP, KC(3)
56155 KC(1)=PYCOMP(KFIN)
56156 KC(2)=PYCOMP(ID1)
56157 KC(3)=PYCOMP(ID2)
56158 SM(1)=PMAS(KC(1),1)**2
56159 SM(2)=PMAS(KC(2),1)**2
56160 SM(3)=PMAS(KC(3),1)**2
56161C...Kinematics check
56162 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
56163 PYRVSB=0D0
56164 RETURN
56165 ENDIF
56166C...CM momenta squared
56167 IF (MODE.EQ.1) THEN
56168 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
56169 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
56170 ELSE IF (MODE.EQ.2) THEN
56171 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
56172 ELSE IF (MODE.EQ.3) THEN
56173 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
56174 ELSE
56175 P2CM=SM(1)/4.
56176 ENDIF
56177C...Calculate Width
56178 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
56179 RETURN
56180 END
56181
56182C*********************************************************************
56183
56184C...PYRVGW
56185C...Generalized Matrix Element for R-Violating 3-body widths.
56186C...P. Z. Skands
56187 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
56188
56189 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56190 IMPLICIT INTEGER (I-N)
56191 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56192 &KEXCIT=4000000,KDIMEN=5000000)
56193 PARAMETER (EPS=1D-4)
56194 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56195 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56196 & ,DCMASS,KFR(3)
56197 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56198 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56199 DOUBLE PRECISION XLIM(3,3)
56200 INTEGER KC(0:3), PYCOMP
56201 LOGICAL DCMASS, DCHECK(6)
56202 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
56203
56204 XLAM = 0D0
56205
56206 KC(0) = PYCOMP(KFIN)
56207 KC(1) = PYCOMP(ID1)
56208 KC(2) = PYCOMP(ID2)
56209 KC(3) = PYCOMP(ID3)
56210 RMS(0) = PMAS(KC(0),1)
56211 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
56212 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
56213 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
56214C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
56215 XLIM(1,1)=(RMS(1)+RMS(2))**2
56216 XLIM(1,2)=(RMS(0)-RMS(3))**2
56217 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
56218 XLIM(2,1)=(RMS(2)+RMS(3))**2
56219 XLIM(2,2)=(RMS(0)-RMS(1))**2
56220 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
56221 XLIM(3,1)=(RMS(1)+RMS(3))**2
56222 XLIM(3,2)=(RMS(0)-RMS(2))**2
56223 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
56224C...Check Phase Space
56225 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
56226 RETURN
56227 ENDIF
56228
56229C...INITIALIZE RESONANCE INFORMATION
56230 DO 110 JRES = 1,3
56231 DO 100 IMASS = 1,2
56232 IRES = 2*(JRES-1)+IMASS
56233 INTRES(IRES,1) = 0
56234 DCHECK(IRES) =.FALSE.
56235C...NO RIGHT-HANDED NEUTRINOS
56236 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
56237 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
56238 & .KFR(JRES).EQ.0) GOTO 100
56239 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
56240 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
56241 INTRES(IRES,1) = IABS(KFR(JRES))
56242 INTRES(IRES,2) = IMASS
56243 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
56244 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
56245 100 CONTINUE
56246 110 CONTINUE
56247
56248C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
56249
56250C...RESONANCE CONTRIBUTIONS
56251C...(Only sum contributions where the resonance is off shell).
56252C...Store whether diagram on/off in DCHECK.
56253C...LOOP OVER MASS STATES
56254 DO 120 J=1,2
56255 IDR=J
56256 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56257 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
56258 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56259 DCHECK(IDR) =.TRUE.
56260 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
56261 ENDIF
56262
56263 IDR=J+2
56264 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56265 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56266 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56267 DCHECK(IDR) =.TRUE.
56268 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
56269 ENDIF
56270
56271 IDR=J+4
56272 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
56273 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
56274 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
56275 DCHECK(IDR) =.TRUE.
56276 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
56277 ENDIF
56278 120 CONTINUE
56279C... L-R INTERFERENCES
56280C... (Only add contributions where both contributing diagrams
56281C... are non-resonant).
56282 IDR=1
56283 IF (DCHECK(1).AND.DCHECK(2)) THEN
56284C...Bug corrected 11/12 2001. Skands.
56285 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
56286 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
56287 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
56288 ENDIF
56289
56290 IDR=3
56291 IF (DCHECK(3).AND.DCHECK(4)) THEN
56292 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
56293 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
56294 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
56295 ENDIF
56296
56297 IDR=5
56298 IF (DCHECK(5).AND.DCHECK(6)) THEN
56299 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
56300 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
56301 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
56302 ENDIF
56303C... TRUE INTERFERENCES
56304C... (Only add contributions where both contributing diagrams
56305C... are non-resonant).
56306 PREF=-2D0
56307 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
56308 DO 140 IKR1 = 1,2
56309 DO 130 IKR2 = 1,2
56310 IDR = IKR1+2
56311 IDR2 = IKR2
56312 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56313 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
56314 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56315 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56316 ENDIF
56317
56318 IDR = IKR1+4
56319 IDR2 = IKR2
56320 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56321 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
56322 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56323 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56324 ENDIF
56325
56326 IDR = IKR1+4
56327 IDR2 = IKR2+2
56328 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
56329 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
56330 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
56331 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
56332 ENDIF
56333 130 CONTINUE
56334 140 CONTINUE
56335
56336 RETURN
56337 END
56338
56339C*********************************************************************
56340
56341C...PYRVI1
56342C...Function to integrate resonance contributions
56343
56344 FUNCTION PYRVI1(ID1,ID2,ID3)
56345
56346 IMPLICIT NONE
56347 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
56348 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56349 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56350 LOGICAL MFLAG,DCMASS
56351 EXTERNAL PYRVG1,PYGAUS
56352 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56353 & ,DCMASS,KFR(3)
56354 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56355 SAVE/PYRVNV/,/PYRVPM/
56356C...Initialize mass and width information
56357 PYRVI1 = 0D0
56358 RM(0) = RMS(0)
56359 RM(1) = RMS(ID1)
56360 RM(2) = RMS(ID2)
56361 RM(3) = RMS(ID3)
56362 RESM(1)= RES(IDR,1)
56363 RESW(1)= RES(IDR,2)
56364C...A->B and B->A for antisparticles
56365 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56366 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56367C...Integration boundaries and mass flag
56368 LO = (RM(1)+RM(2))**2
56369 HI = (RM(0)-RM(3))**2
56370 MFLAG = DCMASS
56371 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
56372 RETURN
56373 END
56374
56375C*********************************************************************
56376
56377C...PYRVI2
56378C...Function to integrate L-R interference contributions
56379
56380 FUNCTION PYRVI2(ID1,ID2,ID3)
56381
56382 IMPLICIT NONE
56383 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
56384 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56385 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56386 LOGICAL MFLAG,DCMASS
56387 EXTERNAL PYRVG2,PYGAUS
56388 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56389 & ,DCMASS,KFR(3)
56390 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56391 SAVE/PYRVNV/,/PYRVPM/
56392C...Initialize mass and width information
56393 PYRVI2 = 0D0
56394 RM(0) = RMS(0)
56395 RM(1) = RMS(ID1)
56396 RM(2) = RMS(ID2)
56397 RM(3) = RMS(ID3)
56398 RESM(1)= RES(IDR,1)
56399 RESW(1)= RES(IDR,2)
56400 RESM(2)= RES(IDR+1,1)
56401 RESW(2)= RES(IDR+1,2)
56402C...A->B and B->A for antisparticles
56403 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56404 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56405 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56406 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
56407C...Boundaries and mass flag
56408 LO = (RM(1)+RM(2))**2
56409 HI = (RM(0)-RM(3))**2
56410 MFLAG = DCMASS
56411 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
56412 RETURN
56413 END
56414
56415C*********************************************************************
56416
56417C...PYRVI3
56418C...Function to integrate true interference contributions
56419
56420 FUNCTION PYRVI3(ID1,ID2,ID3)
56421
56422 IMPLICIT NONE
56423 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
56424 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
56425 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
56426 LOGICAL MFLAG,DCMASS
56427 EXTERNAL PYRVG3,PYGAUS
56428 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
56429 & ,DCMASS,KFR(3)
56430 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56431 SAVE/PYRVNV/,/PYRVPM/
56432C...Initialize mass and width information
56433 PYRVI3 = 0D0
56434 RM(0) = RMS(0)
56435 RM(1) = RMS(ID1)
56436 RM(2) = RMS(ID2)
56437 RM(3) = RMS(ID3)
56438 RESM(1)= RES(IDR,1)
56439 RESW(1)= RES(IDR,2)
56440 RESM(2)= RES(IDR2,1)
56441 RESW(2)= RES(IDR2,2)
56442C...A -> B and B -> A for antisparticles
56443 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56444 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
56445 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56446 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
56447C...Boundaries and mass flag
56448 LO = (RM(1)+RM(2))**2
56449 HI = (RM(0)-RM(3))**2
56450 MFLAG = DCMASS
56451 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
56452 RETURN
56453 END
56454
56455C*********************************************************************
56456
56457C...PYRVG1
56458C...Integrand for resonance contributions
56459
56460 FUNCTION PYRVG1(X)
56461
56462 IMPLICIT NONE
56463 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56464 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
56465 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
56466 LOGICAL MFLAG
56467 SAVE/PYRVPM/
56468 RVR = PYRVR(X,RESM(1),RESW(1))
56469 C1 = 2D0*SQRT(MAX(0D0,X))
56470 IF (.NOT.MFLAG) THEN
56471 E2 = X/C1
56472 E3 = (RM(0)**2-X)/C1
56473 DELTAY = 4D0*E2*E3
56474 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
56475 ELSE
56476 E2 = (X-RM(1)**2+RM(2)**2)/C1
56477 E3 = (RM(0)**2-X-RM(3)**2)/C1
56478 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56479 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56480 DELTAY = 4D0*SR1*SR2
56481 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
56482 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
56483 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
56484 ENDIF
56485 RETURN
56486 END
56487
56488C*********************************************************************
56489
56490C...PYRVG2
56491C...Integrand for L-R interference contributions
56492
56493 FUNCTION PYRVG2(X)
56494
56495 IMPLICIT NONE
56496 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56497 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
56498 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
56499 LOGICAL MFLAG
56500 SAVE/PYRVPM/
56501 C1 = 2D0*SQRT(MAX(0D0,X))
56502 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
56503 IF (.NOT.MFLAG) THEN
56504 E2 = X/C1
56505 E3 = (RM(0)**2-X)/C1
56506 DELTAY = 4D0*E2*E3
56507 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
56508 ELSE
56509 E2 = (X-RM(1)**2+RM(2)**2)/C1
56510 E3 = (RM(0)**2-X-RM(3)**2)/C1
56511 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56512 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56513 DELTAY = 4D0*SR1*SR2
56514 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
56515 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
56516 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
56517 ENDIF
56518 RETURN
56519 END
56520
56521C*********************************************************************
56522
56523C...PYRVG3
56524C...Function to do Y integration over true interference contributions
56525
56526 FUNCTION PYRVG3(X)
56527
56528 IMPLICIT NONE
56529 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56530C...Second Dalitz variable for PYRVG4
56531 COMMON/PYG2DX/X1
56532 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
56533 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
56534 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
56535 LOGICAL MFLAG
56536 EXTERNAL PYGAU2,PYRVG4
56537 SAVE/PYRVPM/,/PYG2DX/
56538 PYRVG3=0D0
56539 C1=2D0*SQRT(MAX(1D-9,X))
56540 X1=X
56541 IF (.NOT.MFLAG) THEN
56542 E2 = X/C1
56543 E3 = (RM(0)**2-X)/C1
56544 YMIN = 0D0
56545 YMAX = 4D0*E2*E3
56546 ELSE
56547 E2 = (X-RM(1)**2+RM(2)**2)/C1
56548 E3 = (RM(0)**2-X-RM(3)**2)/C1
56549 SQ1 = (E2+E3)**2
56550 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
56551 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
56552 YMIN = SQ1-(SR1+SR2)**2
56553 YMAX = SQ1-(SR1-SR2)**2
56554 ENDIF
56555 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
56556 RETURN
56557 END
56558
56559C*********************************************************************
56560
56561C...PYRVG4
56562C...Integrand for true intereference contributions
56563
56564 FUNCTION PYRVG4(Y)
56565
56566 IMPLICIT NONE
56567 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
56568 COMMON/PYG2DX/X
56569 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
56570 LOGICAL MFLAG
56571 SAVE /PYRVPM/,/PYG2DX/
56572 PYRVG4=0D0
56573 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
56574 IF (.NOT.MFLAG) THEN
56575 PYRVG4 = RVS*B(1)*B(2)*X*Y
56576 ELSE
56577 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
56578 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
56579 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
56580 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
56581 ENDIF
56582 RETURN
56583 END
56584
56585C*********************************************************************
56586
56587C...PYRVR
56588C...Breit-Wigner for resonance contributions
56589
56590 FUNCTION PYRVR(Mab2,RM,RW)
56591
56592 IMPLICIT NONE
56593 DOUBLE PRECISION Mab2,RM,RW,PYRVR
56594 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
56595 RETURN
56596 END
56597
56598C*********************************************************************
56599
56600C...PYRVS
56601C...Interference function
56602
56603 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
56604
56605 IMPLICIT NONE
56606 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
56607 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
56608 & +W1*W2*M1*M2)
56609 RETURN
56610 END
56611
56612C*********************************************************************
56613
56614C...PY1ENT
56615C...Stores one parton/particle in commonblock PYJETS.
56616
56617 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
56618
56619C...Double precision and integer declarations.
56620 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56621 IMPLICIT INTEGER(I-N)
56622 INTEGER PYK,PYCHGE,PYCOMP
56623C...Commonblocks.
56624 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56625 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56626 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56627 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56628
56629C...Standard checks.
56630 MSTU(28)=0
56631 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56632 IPA=MAX(1,IABS(IP))
56633 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
56634 &'(PY1ENT:) writing outside PYJETS memory')
56635 KC=PYCOMP(KF)
56636 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
56637
56638C...Find mass. Reset K, P and V vectors.
56639 PM=0D0
56640 IF(MSTU(10).EQ.1) PM=P(IPA,5)
56641 IF(MSTU(10).GE.2) PM=PYMASS(KF)
56642 DO 100 J=1,5
56643 K(IPA,J)=0
56644 P(IPA,J)=0D0
56645 V(IPA,J)=0D0
56646 100 CONTINUE
56647
56648C...Store parton/particle in K and P vectors.
56649 K(IPA,1)=1
56650 IF(IP.LT.0) K(IPA,1)=2
56651 K(IPA,2)=KF
56652 P(IPA,5)=PM
56653 P(IPA,4)=MAX(PE,PM)
56654 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
56655 P(IPA,1)=PA*SIN(THE)*COS(PHI)
56656 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
56657 P(IPA,3)=PA*COS(THE)
56658
56659C...Set N. Optionally fragment/decay.
56660 N=IPA
56661 IF(IP.EQ.0) CALL PYEXEC
56662
56663 RETURN
56664 END
56665
56666C*********************************************************************
56667
56668C...PY2ENT
56669C...Stores two partons/particles in their CM frame,
56670C...with the first along the +z axis.
56671
56672 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
56673
56674C...Double precision and integer declarations.
56675 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56676 IMPLICIT INTEGER(I-N)
56677 INTEGER PYK,PYCHGE,PYCOMP
56678C...Commonblocks.
56679 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56681 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56682 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56683
56684C...Standard checks.
56685 MSTU(28)=0
56686 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56687 IPA=MAX(1,IABS(IP))
56688 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
56689 &'(PY2ENT:) writing outside PYJETS memory')
56690 KC1=PYCOMP(KF1)
56691 KC2=PYCOMP(KF2)
56692 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
56693 &'(PY2ENT:) unknown flavour code')
56694
56695C...Find masses. Reset K, P and V vectors.
56696 PM1=0D0
56697 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56698 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56699 PM2=0D0
56700 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56701 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56702 DO 110 I=IPA,IPA+1
56703 DO 100 J=1,5
56704 K(I,J)=0
56705 P(I,J)=0D0
56706 V(I,J)=0D0
56707 100 CONTINUE
56708 110 CONTINUE
56709
56710C...Check flavours.
56711 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56712 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56713 IF(MSTU(19).EQ.1) THEN
56714 MSTU(19)=0
56715 ELSE
56716 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
56717 & '(PY2ENT:) unphysical flavour combination')
56718 ENDIF
56719 K(IPA,2)=KF1
56720 K(IPA+1,2)=KF2
56721
56722C...Store partons/particles in K vectors for normal case.
56723 IF(IP.GE.0) THEN
56724 K(IPA,1)=1
56725 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
56726 K(IPA+1,1)=1
56727
56728C...Store partons in K vectors for parton shower evolution.
56729 ELSE
56730 K(IPA,1)=3
56731 K(IPA+1,1)=3
56732 K(IPA,4)=MSTU(5)*(IPA+1)
56733 K(IPA,5)=K(IPA,4)
56734 K(IPA+1,4)=MSTU(5)*IPA
56735 K(IPA+1,5)=K(IPA+1,4)
56736 ENDIF
56737
56738C...Check kinematics and store partons/particles in P vectors.
56739 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
56740 &'(PY2ENT:) energy smaller than sum of masses')
56741 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
56742 &(2D0*PECM)
56743 P(IPA,3)=PA
56744 P(IPA,4)=SQRT(PM1**2+PA**2)
56745 P(IPA,5)=PM1
56746 P(IPA+1,3)=-PA
56747 P(IPA+1,4)=SQRT(PM2**2+PA**2)
56748 P(IPA+1,5)=PM2
56749
56750C...Set N. Optionally fragment/decay.
56751 N=IPA+1
56752 IF(IP.EQ.0) CALL PYEXEC
56753
56754 RETURN
56755 END
56756
56757C*********************************************************************
56758
56759C...PY3ENT
56760C...Stores three partons or particles in their CM frame,
56761C...with the first along the +z axis and the third in the (x,z)
56762C...plane with x > 0.
56763
56764 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
56765
56766C...Double precision and integer declarations.
56767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56768 IMPLICIT INTEGER(I-N)
56769 INTEGER PYK,PYCHGE,PYCOMP
56770C...Commonblocks.
56771 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56775
56776C...Standard checks.
56777 MSTU(28)=0
56778 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56779 IPA=MAX(1,IABS(IP))
56780 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
56781 &'(PY3ENT:) writing outside PYJETS memory')
56782 KC1=PYCOMP(KF1)
56783 KC2=PYCOMP(KF2)
56784 KC3=PYCOMP(KF3)
56785 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
56786 &'(PY3ENT:) unknown flavour code')
56787
56788C...Find masses. Reset K, P and V vectors.
56789 PM1=0D0
56790 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56791 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56792 PM2=0D0
56793 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56794 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56795 PM3=0D0
56796 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56797 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56798 DO 110 I=IPA,IPA+2
56799 DO 100 J=1,5
56800 K(I,J)=0
56801 P(I,J)=0D0
56802 V(I,J)=0D0
56803 100 CONTINUE
56804 110 CONTINUE
56805
56806C...Check flavours.
56807 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56808 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56809 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56810 IF(MSTU(19).EQ.1) THEN
56811 MSTU(19)=0
56812 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
56813 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
56814 & KQ1+KQ3.EQ.4)) THEN
56815 ELSE
56816 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
56817 ENDIF
56818 K(IPA,2)=KF1
56819 K(IPA+1,2)=KF2
56820 K(IPA+2,2)=KF3
56821
56822C...Store partons/particles in K vectors for normal case.
56823 IF(IP.GE.0) THEN
56824 K(IPA,1)=1
56825 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
56826 K(IPA+1,1)=1
56827 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
56828 K(IPA+2,1)=1
56829
56830C...Store partons in K vectors for parton shower evolution.
56831 ELSE
56832 K(IPA,1)=3
56833 K(IPA+1,1)=3
56834 K(IPA+2,1)=3
56835 KCS=4
56836 IF(KQ1.EQ.-1) KCS=5
56837 K(IPA,KCS)=MSTU(5)*(IPA+1)
56838 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
56839 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56840 K(IPA+1,9-KCS)=MSTU(5)*IPA
56841 K(IPA+2,KCS)=MSTU(5)*IPA
56842 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56843 ENDIF
56844
56845C...Check kinematics.
56846 MKERR=0
56847 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
56848 &0.5D0*X3*PECM.LE.PM3) MKERR=1
56849 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
56850 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
56851 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
56852 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
56853 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
56854 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
56855 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
56856 IF(MKERR.NE.0) CALL PYERRM(13,
56857 &'(PY3ENT:) unphysical kinematical variable setup')
56858
56859C...Store partons/particles in P vectors.
56860 P(IPA,3)=PA1
56861 P(IPA,4)=SQRT(PA1**2+PM1**2)
56862 P(IPA,5)=PM1
56863 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
56864 P(IPA+2,3)=PA3*CTHE3
56865 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
56866 P(IPA+2,5)=PM3
56867 P(IPA+1,1)=-P(IPA+2,1)
56868 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
56869 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
56870 P(IPA+1,5)=PM2
56871
56872C...Set N. Optionally fragment/decay.
56873 N=IPA+2
56874 IF(IP.EQ.0) CALL PYEXEC
56875
56876 RETURN
56877 END
56878
56879C*********************************************************************
56880
56881C...PY4ENT
56882C...Stores four partons or particles in their CM frame, with
56883C...the first along the +z axis, the last in the xz plane with x > 0
56884C...and the second having y < 0 and y > 0 with equal probability.
56885
56886 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
56887
56888C...Double precision and integer declarations.
56889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56890 IMPLICIT INTEGER(I-N)
56891 INTEGER PYK,PYCHGE,PYCOMP
56892C...Commonblocks.
56893 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
56894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56895 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56896 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
56897
56898C...Standard checks.
56899 MSTU(28)=0
56900 IF(MSTU(12).NE.12345) CALL PYLIST(0)
56901 IPA=MAX(1,IABS(IP))
56902 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
56903 &'(PY4ENT:) writing outside PYJETS momory')
56904 KC1=PYCOMP(KF1)
56905 KC2=PYCOMP(KF2)
56906 KC3=PYCOMP(KF3)
56907 KC4=PYCOMP(KF4)
56908 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
56909 &'(PY4ENT:) unknown flavour code')
56910
56911C...Find masses. Reset K, P and V vectors.
56912 PM1=0D0
56913 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
56914 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
56915 PM2=0D0
56916 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
56917 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
56918 PM3=0D0
56919 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
56920 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
56921 PM4=0D0
56922 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
56923 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
56924 DO 110 I=IPA,IPA+3
56925 DO 100 J=1,5
56926 K(I,J)=0
56927 P(I,J)=0D0
56928 V(I,J)=0D0
56929 100 CONTINUE
56930 110 CONTINUE
56931
56932C...Check flavours.
56933 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
56934 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
56935 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
56936 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
56937 IF(MSTU(19).EQ.1) THEN
56938 MSTU(19)=0
56939 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
56940 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
56941 & KQ1+KQ4.EQ.4)) THEN
56942 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
56943 & THEN
56944 ELSE
56945 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
56946 ENDIF
56947 K(IPA,2)=KF1
56948 K(IPA+1,2)=KF2
56949 K(IPA+2,2)=KF3
56950 K(IPA+3,2)=KF4
56951
56952C...Store partons/particles in K vectors for normal case.
56953 IF(IP.GE.0) THEN
56954 K(IPA,1)=1
56955 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
56956 K(IPA+1,1)=1
56957 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
56958 & K(IPA+1,1)=2
56959 K(IPA+2,1)=1
56960 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
56961 K(IPA+3,1)=1
56962
56963C...Store partons for parton shower evolution from q-g-g-qbar or
56964C...g-g-g-g event.
56965 ELSEIF(KQ1+KQ2.NE.0) THEN
56966 K(IPA,1)=3
56967 K(IPA+1,1)=3
56968 K(IPA+2,1)=3
56969 K(IPA+3,1)=3
56970 KCS=4
56971 IF(KQ1.EQ.-1) KCS=5
56972 K(IPA,KCS)=MSTU(5)*(IPA+1)
56973 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
56974 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
56975 K(IPA+1,9-KCS)=MSTU(5)*IPA
56976 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
56977 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
56978 K(IPA+3,KCS)=MSTU(5)*IPA
56979 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
56980
56981C...Store partons for parton shower evolution from q-qbar-q-qbar event.
56982 ELSE
56983 K(IPA,1)=3
56984 K(IPA+1,1)=3
56985 K(IPA+2,1)=3
56986 K(IPA+3,1)=3
56987 K(IPA,4)=MSTU(5)*(IPA+1)
56988 K(IPA,5)=K(IPA,4)
56989 K(IPA+1,4)=MSTU(5)*IPA
56990 K(IPA+1,5)=K(IPA+1,4)
56991 K(IPA+2,4)=MSTU(5)*(IPA+3)
56992 K(IPA+2,5)=K(IPA+2,4)
56993 K(IPA+3,4)=MSTU(5)*(IPA+2)
56994 K(IPA+3,5)=K(IPA+3,4)
56995 ENDIF
56996
56997C...Check kinematics.
56998 MKERR=0
56999 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
57000 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
57001 &MKERR=1
57002 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
57003 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
57004 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
57005 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
57006 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
57007 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
57008 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
57009 STHE4=SQRT(1D0-CTHE4**2)
57010 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
57011 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
57012 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
57013 STHE2=SQRT(1D0-CTHE2**2)
57014 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
57015 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
57016 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
57017 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
57018 IF(MKERR.EQ.1) CALL PYERRM(13,
57019 &'(PY4ENT:) unphysical kinematical variable setup')
57020
57021C...Store partons/particles in P vectors.
57022 P(IPA,3)=PA1
57023 P(IPA,4)=SQRT(PA1**2+PM1**2)
57024 P(IPA,5)=PM1
57025 P(IPA+3,1)=PA4*STHE4
57026 P(IPA+3,3)=PA4*CTHE4
57027 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
57028 P(IPA+3,5)=PM4
57029 P(IPA+1,1)=PA2*STHE2*CPHI2
57030 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
57031 P(IPA+1,3)=PA2*CTHE2
57032 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
57033 P(IPA+1,5)=PM2
57034 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
57035 P(IPA+2,2)=-P(IPA+1,2)
57036 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
57037 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
57038 P(IPA+2,5)=PM3
57039
57040C...Set N. Optionally fragment/decay.
57041 N=IPA+3
57042 IF(IP.EQ.0) CALL PYEXEC
57043
57044 RETURN
57045 END
57046
57047C*********************************************************************
57048
57049C...PY2FRM
57050C...An interface from a two-fermion generator to include
57051C...parton showers and hadronization.
57052
57053 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
57054
57055C...Double precision and integer declarations.
57056 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57057 IMPLICIT INTEGER(I-N)
57058 INTEGER PYK,PYCHGE,PYCOMP
57059C...Commonblocks.
57060 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57061 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57062 SAVE /PYJETS/,/PYDAT1/
57063C...Local arrays.
57064 DIMENSION IJOIN(2),INTAU(2)
57065
57066C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57067 IF(ICOM.EQ.0) THEN
57068 MSTU(28)=0
57069 CALL PYHEPC(2)
57070 ENDIF
57071
57072C...Loop through entries and pick up all final fermions/antifermions.
57073 I1=0
57074 I2=0
57075 DO 100 I=1,N
57076 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57077 KFA=IABS(K(I,2))
57078 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57079 IF(K(I,2).GT.0) THEN
57080 IF(I1.EQ.0) THEN
57081 I1=I
57082 ELSE
57083 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
57084 ENDIF
57085 ELSE
57086 IF(I2.EQ.0) THEN
57087 I2=I
57088 ELSE
57089 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
57090 ENDIF
57091 ENDIF
57092 ENDIF
57093 100 CONTINUE
57094
57095C...Check that event is arranged according to conventions.
57096 IF(I1.EQ.0.OR.I2.EQ.0) THEN
57097 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
57098 ENDIF
57099 IF(I2.LT.I1) THEN
57100 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
57101 ENDIF
57102
57103C...Check whether fermion pair is quarks or leptons.
57104 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57105 IQL12=1
57106 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57107 IQL12=2
57108 ELSE
57109 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
57110 ENDIF
57111
57112C...Decide whether to allow or not photon radiation in showers.
57113 MSTJ(41)=2
57114 IF(IRAD.EQ.0) MSTJ(41)=1
57115
57116C...Do colour joining and parton showers.
57117 IP1=I1
57118 IP2=I2
57119 IF(IQL12.EQ.1) THEN
57120 IJOIN(1)=IP1
57121 IJOIN(2)=IP2
57122 CALL PYJOIN(2,IJOIN)
57123 ENDIF
57124 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57125 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57126 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57127 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57128 ENDIF
57129
57130C...Do fragmentation and decays. Possibly except tau decay.
57131 IF(ITAU.EQ.0) THEN
57132 NTAU=0
57133 DO 110 I=1,N
57134 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57135 NTAU=NTAU+1
57136 INTAU(NTAU)=I
57137 K(I,1)=11
57138 ENDIF
57139 110 CONTINUE
57140 ENDIF
57141 CALL PYEXEC
57142 IF(ITAU.EQ.0) THEN
57143 DO 120 I=1,NTAU
57144 K(INTAU(I),1)=1
57145 120 CONTINUE
57146 ENDIF
57147
57148C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57149 IF(ICOM.EQ.0) THEN
57150 MSTU(28)=0
57151 CALL PYHEPC(1)
57152 ENDIF
57153
57154 END
57155
57156C*********************************************************************
57157
57158C...PY4FRM
57159C...An interface from a four-fermion generator to include
57160C...parton showers and hadronization.
57161
57162 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
57163
57164C...Double precision and integer declarations.
57165 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57166 IMPLICIT INTEGER(I-N)
57167 INTEGER PYK,PYCHGE,PYCOMP
57168C...Commonblocks.
57169 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57170 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57171 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57172 COMMON/PYINT1/MINT(400),VINT(400)
57173 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
57174C...Local arrays.
57175 DIMENSION IJOIN(2),INTAU(4)
57176
57177C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57178 IF(ICOM.EQ.0) THEN
57179 MSTU(28)=0
57180 CALL PYHEPC(2)
57181 ENDIF
57182
57183C...Loop through entries and pick up all final fermions/antifermions.
57184 I1=0
57185 I2=0
57186 I3=0
57187 I4=0
57188 DO 100 I=1,N
57189 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57190 KFA=IABS(K(I,2))
57191 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57192 IF(K(I,2).GT.0) THEN
57193 IF(I1.EQ.0) THEN
57194 I1=I
57195 ELSEIF(I3.EQ.0) THEN
57196 I3=I
57197 ELSE
57198 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
57199 ENDIF
57200 ELSE
57201 IF(I2.EQ.0) THEN
57202 I2=I
57203 ELSEIF(I4.EQ.0) THEN
57204 I4=I
57205 ELSE
57206 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
57207 ENDIF
57208 ENDIF
57209 ENDIF
57210 100 CONTINUE
57211
57212C...Check that event is arranged according to conventions.
57213 IF(I3.EQ.0.OR.I4.EQ.0) THEN
57214 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
57215 ENDIF
57216 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57217 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
57218 ENDIF
57219
57220C...Check which fermion pairs are quarks and which leptons.
57221 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57222 IQL12=1
57223 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57224 IQL12=2
57225 ELSE
57226 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
57227 ENDIF
57228 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57229 IQL34=1
57230 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57231 IQL34=2
57232 ELSE
57233 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
57234 ENDIF
57235
57236C...Decide whether to allow or not photon radiation in showers.
57237 MSTJ(41)=2
57238 IF(IRAD.EQ.0) MSTJ(41)=1
57239
57240C...Decide on dipole pairing.
57241 IP1=I1
57242 IP2=I2
57243 IP3=I3
57244 IP4=I4
57245 IF(IQL12.EQ.IQL34) THEN
57246 R1SQ=A1SQ
57247 R2SQ=A2SQ
57248 DELTA=ATOTSQ-A1SQ-A2SQ
57249 IF(ISTRAT.EQ.1) THEN
57250 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
57251 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
57252 ELSEIF(ISTRAT.EQ.2) THEN
57253 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
57254 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
57255 ENDIF
57256 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
57257 IP2=I4
57258 IP4=I2
57259 ENDIF
57260 ENDIF
57261
57262C...If colour reconnection then bookkeep W+W- or Z0Z0
57263C...and copy q qbar q qbar consecutively.
57264 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57265 K(N+1,1)=11
57266 K(N+1,3)=IP1
57267 K(N+1,4)=N+3
57268 K(N+1,5)=N+4
57269 K(N+2,1)=11
57270 K(N+2,3)=IP3
57271 K(N+2,4)=N+5
57272 K(N+2,5)=N+6
57273 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
57274 K(N+1,2)=23
57275 K(N+2,2)=23
57276 MINT(1)=22
57277 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
57278 K(N+1,2)=24
57279 K(N+2,2)=-24
57280 MINT(1)=25
57281 ELSE
57282 K(N+1,2)=-24
57283 K(N+2,2)=24
57284 MINT(1)=25
57285 ENDIF
57286 DO 110 J=1,5
57287 K(N+3,J)=K(IP1,J)
57288 K(N+4,J)=K(IP2,J)
57289 K(N+5,J)=K(IP3,J)
57290 K(N+6,J)=K(IP4,J)
57291 P(N+1,J)=P(IP1,J)+P(IP2,J)
57292 P(N+2,J)=P(IP3,J)+P(IP4,J)
57293 P(N+3,J)=P(IP1,J)
57294 P(N+4,J)=P(IP2,J)
57295 P(N+5,J)=P(IP3,J)
57296 P(N+6,J)=P(IP4,J)
57297 V(N+1,J)=V(IP1,J)
57298 V(N+2,J)=V(IP3,J)
57299 V(N+3,J)=V(IP1,J)
57300 V(N+4,J)=V(IP2,J)
57301 V(N+5,J)=V(IP3,J)
57302 V(N+6,J)=V(IP4,J)
57303 110 CONTINUE
57304 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57305 & P(N+1,3)**2))
57306 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57307 & P(N+2,3)**2))
57308 K(N+3,3)=N+1
57309 K(N+4,3)=N+1
57310 K(N+5,3)=N+2
57311 K(N+6,3)=N+2
57312C...Remove original q qbar q qbar and update counters.
57313 K(IP1,1)=K(IP1,1)+10
57314 K(IP2,1)=K(IP2,1)+10
57315 K(IP3,1)=K(IP3,1)+10
57316 K(IP4,1)=K(IP4,1)+10
57317 IW1=N+1
57318 IW2=N+2
57319 NSD1=N+2
57320 IP1=N+3
57321 IP2=N+4
57322 IP3=N+5
57323 IP4=N+6
57324 N=N+6
57325 ENDIF
57326
57327C...Do colour joinings and parton showers.
57328 IF(IQL12.EQ.1) THEN
57329 IJOIN(1)=IP1
57330 IJOIN(2)=IP2
57331 CALL PYJOIN(2,IJOIN)
57332 ENDIF
57333 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57334 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57335 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57336 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57337 ENDIF
57338 NAFT1=N
57339 IF(IQL34.EQ.1) THEN
57340 IJOIN(1)=IP3
57341 IJOIN(2)=IP4
57342 CALL PYJOIN(2,IJOIN)
57343 ENDIF
57344 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57345 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57346 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57347 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57348 ENDIF
57349
57350C...Optionally do colour reconnection.
57351 MINT(32)=0
57352 MSTI(32)=0
57353 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
57354 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
57355 MSTI(32)=MINT(32)
57356 ENDIF
57357
57358C...Do fragmentation and decays. Possibly except tau decay.
57359 IF(ITAU.EQ.0) THEN
57360 NTAU=0
57361 DO 120 I=1,N
57362 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57363 NTAU=NTAU+1
57364 INTAU(NTAU)=I
57365 K(I,1)=11
57366 ENDIF
57367 120 CONTINUE
57368 ENDIF
57369 CALL PYEXEC
57370 IF(ITAU.EQ.0) THEN
57371 DO 130 I=1,NTAU
57372 K(INTAU(I),1)=1
57373 130 CONTINUE
57374 ENDIF
57375
57376C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57377 IF(ICOM.EQ.0) THEN
57378 MSTU(28)=0
57379 CALL PYHEPC(1)
57380 ENDIF
57381
57382 END
57383
57384C*********************************************************************
57385
57386C...PY6FRM
57387C...An interface from a six-fermion generator to include
57388C...parton showers and hadronization.
57389
57390 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
57391
57392C...Double precision and integer declarations.
57393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57394 IMPLICIT INTEGER(I-N)
57395 INTEGER PYK,PYCHGE,PYCOMP
57396C...Commonblocks.
57397 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57399 SAVE /PYJETS/,/PYDAT1/
57400C...Local arrays.
57401 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
57402
57403C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57404 IF(ICOM.EQ.0) THEN
57405 MSTU(28)=0
57406 CALL PYHEPC(2)
57407 ENDIF
57408
57409C...Loop through entries and pick up all final fermions/antifermions.
57410 I1=0
57411 I2=0
57412 I3=0
57413 I4=0
57414 I5=0
57415 I6=0
57416 DO 100 I=1,N
57417 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57418 KFA=IABS(K(I,2))
57419 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
57420 IF(K(I,2).GT.0) THEN
57421 IF(I1.EQ.0) THEN
57422 I1=I
57423 ELSEIF(I3.EQ.0) THEN
57424 I3=I
57425 ELSEIF(I5.EQ.0) THEN
57426 I5=I
57427 ELSE
57428 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
57429 ENDIF
57430 ELSE
57431 IF(I2.EQ.0) THEN
57432 I2=I
57433 ELSEIF(I4.EQ.0) THEN
57434 I4=I
57435 ELSEIF(I6.EQ.0) THEN
57436 I6=I
57437 ELSE
57438 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
57439 ENDIF
57440 ENDIF
57441 ENDIF
57442 100 CONTINUE
57443
57444C...Check that event is arranged according to conventions.
57445 IF(I5.EQ.0.OR.I6.EQ.0) THEN
57446 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
57447 ENDIF
57448 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
57449 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
57450 ENDIF
57451
57452C...Check which fermion pairs are quarks and which leptons.
57453 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
57454 IQL12=1
57455 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
57456 IQL12=2
57457 ELSE
57458 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
57459 ENDIF
57460 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57461 IQL34=1
57462 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
57463 IQL34=2
57464 ELSE
57465 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
57466 ENDIF
57467 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
57468 IQL56=1
57469 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
57470 IQL56=2
57471 ELSE
57472 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
57473 ENDIF
57474
57475C...Decide whether to allow or not photon radiation in showers.
57476 MSTJ(41)=2
57477 IF(IRAD.EQ.0) MSTJ(41)=1
57478
57479C...Allow dipole pairings only among leptons and quarks separately.
57480 P12D=P12
57481 P13D=0D0
57482 IF(IQL34.EQ.IQL56) P13D=P13
57483 P21D=0D0
57484 IF(IQL12.EQ.IQL34) P21D=P21
57485 P23D=0D0
57486 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
57487 P31D=0D0
57488 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
57489 P32D=0D0
57490 IF(IQL12.EQ.IQL56) P32D=P32
57491
57492C...Decide whether t+tbar.
57493 ITOP=0
57494 IF(PYR(0).LT.PTOP) THEN
57495 ITOP=1
57496
57497C...If t+tbar: reconstruct t's.
57498 IT=N+1
57499 ITB=N+2
57500 DO 110 J=1,5
57501 K(IT,J)=0
57502 K(ITB,J)=0
57503 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
57504 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
57505 V(IT,J)=0D0
57506 V(ITB,J)=0D0
57507 110 CONTINUE
57508 K(IT,1)=1
57509 K(ITB,1)=1
57510 K(IT,2)=6
57511 K(ITB,2)=-6
57512 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
57513 & P(IT,3)**2))
57514 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
57515 & P(ITB,3)**2))
57516 N=N+2
57517
57518C...If t+tbar: colour join t's and let them shower.
57519 IJOIN(1)=IT
57520 IJOIN(2)=ITB
57521 CALL PYJOIN(2,IJOIN)
57522 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
57523 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
57524 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
57525
57526C...If t+tbar: pick up the t's after shower.
57527 ITNEW=IT
57528 ITBNEW=ITB
57529 DO 120 I=ITB+1,N
57530 IF(K(I,2).EQ.6) ITNEW=I
57531 IF(K(I,2).EQ.-6) ITBNEW=I
57532 120 CONTINUE
57533
57534C...If t+tbar: loop over two top systems.
57535 DO 200 IT1=1,2
57536 IF(IT1.EQ.1) THEN
57537 ITO=IT
57538 ITN=ITNEW
57539 IBO=I1
57540 IW1=I3
57541 IW2=I4
57542 ELSE
57543 ITO=ITB
57544 ITN=ITBNEW
57545 IBO=I2
57546 IW1=I5
57547 IW2=I6
57548 ENDIF
57549 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
57550 & '(PY6FRM:) not b in t decay')
57551
57552C...If t+tbar: find boost from original to new top frame.
57553 DO 130 J=1,3
57554 BETAO(J)=P(ITO,J)/P(ITO,4)
57555 BETAN(J)=P(ITN,J)/P(ITN,4)
57556 130 CONTINUE
57557
57558C...If t+tbar: boost copy of b by t shower and connect it in colour.
57559 N=N+1
57560 IB=N
57561 K(IB,1)=3
57562 K(IB,2)=K(IBO,2)
57563 K(IB,3)=ITN
57564 DO 140 J=1,5
57565 P(IB,J)=P(IBO,J)
57566 V(IB,J)=0D0
57567 140 CONTINUE
57568 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57569 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57570 K(IB,4)=MSTU(5)*ITN
57571 K(IB,5)=MSTU(5)*ITN
57572 K(ITN,4)=K(ITN,4)+IB
57573 K(ITN,5)=K(ITN,5)+IB
57574 K(ITN,1)=K(ITN,1)+10
57575 K(IBO,1)=K(IBO,1)+10
57576
57577C...If t+tbar: construct W recoiling against b.
57578 N=N+1
57579 IW=N
57580 DO 150 J=1,5
57581 K(IW,J)=0
57582 V(IW,J)=0D0
57583 150 CONTINUE
57584 K(IW,1)=1
57585 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
57586 IF(IABS(KCHW).EQ.3) THEN
57587 K(IW,2)=ISIGN(24,KCHW)
57588 ELSE
57589 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
57590 ENDIF
57591 K(IW,3)=IW1
57592
57593C...If t+tbar: construct W momentum, including boost by t shower.
57594 DO 160 J=1,4
57595 P(IW,J)=P(IW1,J)+P(IW2,J)
57596 160 CONTINUE
57597 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
57598 & P(IW,3)**2))
57599 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57600 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57601
57602C...If t+tbar: boost b and W to top rest frame.
57603 DO 170 J=1,3
57604 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
57605 170 CONTINUE
57606 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57607 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57608
57609C...If t+tbar: let b shower and pick up modified W.
57610 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
57611 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
57612 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
57613 DO 180 I=IW,N
57614 IF(IABS(K(I,2)).EQ.24) IWM=I
57615 180 CONTINUE
57616
57617C...If t+tbar: take copy of W decay products.
57618 DO 190 J=1,5
57619 K(N+1,J)=K(IW1,J)
57620 P(N+1,J)=P(IW1,J)
57621 V(N+1,J)=V(IW1,J)
57622 K(N+2,J)=K(IW2,J)
57623 P(N+2,J)=P(IW2,J)
57624 V(N+2,J)=V(IW2,J)
57625 190 CONTINUE
57626 K(IW1,1)=K(IW1,1)+10
57627 K(IW2,1)=K(IW2,1)+10
57628 K(IWM,1)=K(IWM,1)+10
57629 K(IWM,4)=N+1
57630 K(IWM,5)=N+2
57631 K(N+1,3)=IWM
57632 K(N+2,3)=IWM
57633 IF(IT1.EQ.1) THEN
57634 I3=N+1
57635 I4=N+2
57636 ELSE
57637 I5=N+1
57638 I6=N+2
57639 ENDIF
57640 N=N+2
57641
57642C...If t+tbar: boost W decay products, first by effects of t shower,
57643C...then by those of b shower. b and its shower simple boost back.
57644 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
57645 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
57646 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57647 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
57648 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
57649 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
57650 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
57651 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
57652 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
57653 200 CONTINUE
57654 ENDIF
57655
57656C...Decide on dipole pairing.
57657 IP1=I1
57658 IP3=I3
57659 IP5=I5
57660 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
57661 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
57662 IP2=I2
57663 IP4=I4
57664 IP6=I6
57665 ELSEIF(PRN.LT.P12D+P13D) THEN
57666 IP2=I2
57667 IP4=I6
57668 IP6=I4
57669 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
57670 IP2=I4
57671 IP4=I2
57672 IP6=I6
57673 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
57674 IP2=I4
57675 IP4=I6
57676 IP6=I2
57677 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
57678 IP2=I6
57679 IP4=I2
57680 IP6=I4
57681 ELSE
57682 IP2=I6
57683 IP4=I4
57684 IP6=I2
57685 ENDIF
57686
57687C...Do colour joinings and parton showers
57688C...(except ones already made for t+tbar).
57689 IF(ITOP.EQ.0) THEN
57690 IF(IQL12.EQ.1) THEN
57691 IJOIN(1)=IP1
57692 IJOIN(2)=IP2
57693 CALL PYJOIN(2,IJOIN)
57694 ENDIF
57695 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
57696 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
57697 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
57698 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
57699 ENDIF
57700 ENDIF
57701 IF(IQL34.EQ.1) THEN
57702 IJOIN(1)=IP3
57703 IJOIN(2)=IP4
57704 CALL PYJOIN(2,IJOIN)
57705 ENDIF
57706 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
57707 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
57708 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
57709 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
57710 ENDIF
57711 IF(IQL56.EQ.1) THEN
57712 IJOIN(1)=IP5
57713 IJOIN(2)=IP6
57714 CALL PYJOIN(2,IJOIN)
57715 ENDIF
57716 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
57717 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
57718 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
57719 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
57720 ENDIF
57721
57722C...Do fragmentation and decays. Possibly except tau decay.
57723 IF(ITAU.EQ.0) THEN
57724 NTAU=0
57725 DO 210 I=1,N
57726 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
57727 NTAU=NTAU+1
57728 INTAU(NTAU)=I
57729 K(I,1)=11
57730 ENDIF
57731 210 CONTINUE
57732 ENDIF
57733 CALL PYEXEC
57734 IF(ITAU.EQ.0) THEN
57735 DO 220 I=1,NTAU
57736 K(INTAU(I),1)=1
57737 220 CONTINUE
57738 ENDIF
57739
57740C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57741 IF(ICOM.EQ.0) THEN
57742 MSTU(28)=0
57743 CALL PYHEPC(1)
57744 ENDIF
57745
57746 END
57747
57748C*********************************************************************
57749
57750C...PY4JET
57751C...An interface from a four-parton generator to include
57752C...parton showers and hadronization.
57753
57754 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
57755
57756C...Double precision and integer declarations.
57757 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57758 IMPLICIT INTEGER(I-N)
57759 INTEGER PYK,PYCHGE,PYCOMP
57760C...Commonblocks.
57761 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57762 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57763 SAVE /PYJETS/,/PYDAT1/
57764C...Local arrays.
57765 DIMENSION IJOIN(2),PTOT(4),BETA(3)
57766
57767C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
57768 IF(ICOM.EQ.0) THEN
57769 MSTU(28)=0
57770 CALL PYHEPC(2)
57771 ENDIF
57772
57773C...Loop through entries and pick up all final partons.
57774 I1=0
57775 I2=0
57776 I3=0
57777 I4=0
57778 DO 100 I=1,N
57779 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
57780 KFA=IABS(K(I,2))
57781 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
57782 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
57783 IF(I1.EQ.0) THEN
57784 I1=I
57785 ELSEIF(I3.EQ.0) THEN
57786 I3=I
57787 ELSE
57788 CALL PYERRM(16,'(PY4JET:) more than two quarks')
57789 ENDIF
57790 ELSEIF(K(I,2).LT.0) THEN
57791 IF(I2.EQ.0) THEN
57792 I2=I
57793 ELSEIF(I4.EQ.0) THEN
57794 I4=I
57795 ELSE
57796 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
57797 ENDIF
57798 ELSE
57799 IF(I3.EQ.0) THEN
57800 I3=I
57801 ELSEIF(I4.EQ.0) THEN
57802 I4=I
57803 ELSE
57804 CALL PYERRM(16,'(PY4JET:) more than two gluons')
57805 ENDIF
57806 ENDIF
57807 ENDIF
57808 100 CONTINUE
57809
57810C...Check that event is arranged according to conventions.
57811 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
57812 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
57813 ENDIF
57814 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
57815 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
57816 ENDIF
57817
57818C...Check whether second pair are quarks or gluons.
57819 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
57820 IQG34=1
57821 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
57822 IQG34=2
57823 ELSE
57824 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
57825 ENDIF
57826
57827C...Boost partons to their cm frame.
57828 DO 110 J=1,4
57829 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
57830 110 CONTINUE
57831 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
57832 DO 120 J=1,3
57833 BETA(J)=PTOT(J)/PTOT(4)
57834 120 CONTINUE
57835 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57836 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57837 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57838 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
57839 NSAV=N
57840
57841C...Decide and set up shower history for q qbar q' qbar' events.
57842 IF(IQG34.EQ.1) THEN
57843 W1=PY4JTW(0,I1,I3,I4)
57844 W2=PY4JTW(0,I2,I3,I4)
57845 IF(W1.GT.PYR(0)*(W1+W2)) THEN
57846 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57847 ELSE
57848 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57849 ENDIF
57850
57851C...Decide and set up shower history for q qbar g g events.
57852 ELSE
57853 W1=PY4JTW(I1,I3,I2,I4)
57854 W2=PY4JTW(I1,I4,I2,I3)
57855 W3=PY4JTW(0,I3,I1,I4)
57856 W4=PY4JTW(0,I4,I1,I3)
57857 W5=PY4JTW(0,I3,I2,I4)
57858 W6=PY4JTW(0,I4,I2,I3)
57859 W7=PY4JTW(0,I1,I3,I4)
57860 W8=PY4JTW(0,I2,I3,I4)
57861 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
57862 IF(W1.GT.WR) THEN
57863 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
57864 ELSEIF(W1+W2.GT.WR) THEN
57865 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
57866 ELSEIF(W1+W2+W3.GT.WR) THEN
57867 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
57868 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
57869 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
57870 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
57871 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
57872 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
57873 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
57874 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
57875 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
57876 ELSE
57877 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
57878 ENDIF
57879 ENDIF
57880
57881C...Boost back original partons and mark them as deleted.
57882 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
57883 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
57884 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
57885 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
57886 K(I1,1)=K(I1,1)+10
57887 K(I2,1)=K(I2,1)+10
57888 K(I3,1)=K(I3,1)+10
57889 K(I4,1)=K(I4,1)+10
57890
57891C...Rotate shower initiating partons to be along z axis.
57892 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
57893 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
57894 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
57895 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
57896
57897C...Set up copy of shower initiating partons as on mass shell.
57898 DO 140 I=N+1,N+2
57899 DO 130 J=1,5
57900 K(I,J)=0
57901 P(I,J)=0D0
57902 V(I,J)=V(I1,J)
57903 130 CONTINUE
57904 K(I,1)=1
57905 K(I,2)=K(I-6,2)
57906 140 CONTINUE
57907 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
57908 K(N+1,3)=I1
57909 P(N+1,5)=P(I1,5)
57910 K(N+2,3)=I2
57911 P(N+2,5)=P(I2,5)
57912 ELSE
57913 K(N+1,3)=I2
57914 P(N+1,5)=P(I2,5)
57915 K(N+2,3)=I1
57916 P(N+2,5)=P(I1,5)
57917 ENDIF
57918 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
57919 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
57920 P(N+1,3)=PABS
57921 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
57922 P(N+2,3)=-PABS
57923 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
57924 N=N+2
57925
57926C...Decide whether to allow or not photon radiation in showers.
57927C...Connect up colours.
57928 MSTJ(41)=2
57929 IF(IRAD.EQ.0) MSTJ(41)=1
57930 IJOIN(1)=N-1
57931 IJOIN(2)=N
57932 CALL PYJOIN(2,IJOIN)
57933
57934C...Decide on maximum virtuality and do parton shower.
57935 IF(PMAX.LT.PARJ(82)) THEN
57936 PQMAX=QMAX
57937 ELSE
57938 PQMAX=PMAX
57939 ENDIF
57940 CALL PYSHOW(NSAV+1,-100,PQMAX)
57941
57942C...Rotate and boost back system.
57943 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
57944
57945C...Do fragmentation and decays.
57946 CALL PYEXEC
57947
57948C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
57949 IF(ICOM.EQ.0) THEN
57950 MSTU(28)=0
57951 CALL PYHEPC(1)
57952 ENDIF
57953
57954 RETURN
57955 END
57956
57957C*********************************************************************
57958
57959C...PY4JTW
57960C...Auxiliary to PY4JET, to evaluate weight of configuration.
57961
57962 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
57963
57964C...Double precision and integer declarations.
57965 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57966 IMPLICIT INTEGER(I-N)
57967 INTEGER PYK,PYCHGE,PYCOMP
57968C...Commonblocks.
57969 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
57970 SAVE /PYJETS/
57971
57972C...First case: when both original partons radiate.
57973C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
57974 IF(IA1.NE.0) THEN
57975 DO 100 J=1,4
57976 P(N+1,J)=P(IA1,J)+P(IA2,J)
57977 P(N+2,J)=P(IA3,J)+P(IA4,J)
57978 100 CONTINUE
57979 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57980 & P(N+1,3)**2))
57981 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57982 & P(N+2,3)**2))
57983 Z1=P(IA1,4)/P(N+1,4)
57984 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
57985 Z2=P(IA3,4)/P(N+2,4)
57986 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
57987
57988C...Second case: when one original parton radiates to three.
57989C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
57990 ELSE
57991 DO 110 J=1,4
57992 P(N+2,J)=P(IA3,J)+P(IA4,J)
57993 P(N+1,J)=P(N+2,J)+P(IA2,J)
57994 110 CONTINUE
57995 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
57996 & P(N+1,3)**2))
57997 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
57998 & P(N+2,3)**2))
57999 IF(K(IA2,2).EQ.21) THEN
58000 Z1=P(N+2,4)/P(N+1,4)
58001 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58002 & P(IA3,5)**2)
58003 ELSE
58004 Z1=P(IA2,4)/P(N+1,4)
58005 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
58006 & P(IA2,5)**2)
58007 ENDIF
58008 Z2=P(IA3,4)/P(N+2,4)
58009 IF(K(IA2,2).EQ.21) THEN
58010 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
58011 & P(IA3,5)**2)
58012 ELSEIF(K(IA3,2).EQ.21) THEN
58013 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
58014 ELSE
58015 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
58016 ENDIF
58017 ENDIF
58018
58019C...Total weight.
58020 PY4JTW=WT1*WT2
58021
58022 RETURN
58023 END
58024
58025C*********************************************************************
58026
58027C...PY4JTS
58028C...Auxiliary to PY4JET, to set up chosen configuration.
58029
58030 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
58031
58032C...Double precision and integer declarations.
58033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58034 IMPLICIT INTEGER(I-N)
58035 INTEGER PYK,PYCHGE,PYCOMP
58036C...Commonblocks.
58037 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58038 SAVE /PYJETS/
58039
58040C...Reset info.
58041 DO 110 I=N+1,N+6
58042 DO 100 J=1,5
58043 K(I,J)=0
58044 V(I,J)=V(IA2,J)
58045 100 CONTINUE
58046 K(I,1)=16
58047 110 CONTINUE
58048
58049C...First case: when both original partons radiate.
58050C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
58051 IF(IA1.NE.0) THEN
58052
58053C...Set up flavour and history pointers for new partons.
58054 K(N+1,2)=K(IA1,2)
58055 K(N+2,2)=K(IA3,2)
58056 K(N+3,2)=K(IA1,2)
58057 K(N+4,2)=K(IA2,2)
58058 K(N+5,2)=K(IA3,2)
58059 K(N+6,2)=K(IA4,2)
58060 K(N+1,3)=IA1
58061 K(N+1,4)=N+3
58062 K(N+1,5)=N+4
58063 K(N+2,3)=IA3
58064 K(N+2,4)=N+5
58065 K(N+2,5)=N+6
58066 K(N+3,3)=N+1
58067 K(N+4,3)=N+1
58068 K(N+5,3)=N+2
58069 K(N+6,3)=N+2
58070
58071C...Set up momenta for new partons.
58072 DO 120 J=1,5
58073 P(N+1,J)=P(IA1,J)+P(IA2,J)
58074 P(N+2,J)=P(IA3,J)+P(IA4,J)
58075 P(N+3,J)=P(IA1,J)
58076 P(N+4,J)=P(IA2,J)
58077 P(N+5,J)=P(IA3,J)
58078 P(N+6,J)=P(IA4,J)
58079 120 CONTINUE
58080 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58081 & P(N+1,3)**2))
58082 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
58083 & P(N+2,3)**2))
58084 QMAX=MIN(P(N+1,5),P(N+2,5))
58085
58086C...Second case: q radiates twice.
58087C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
58088C...IA5=N+2 does not radiate.
58089 ELSEIF(K(IA2,2).EQ.21) THEN
58090
58091C...Set up flavour and history pointers for new partons.
58092 K(N+1,2)=K(IA3,2)
58093 K(N+2,2)=K(IA5,2)
58094 K(N+3,2)=K(IA3,2)
58095 K(N+4,2)=K(IA2,2)
58096 K(N+5,2)=K(IA3,2)
58097 K(N+6,2)=K(IA4,2)
58098 K(N+1,3)=IA3
58099 K(N+1,4)=N+3
58100 K(N+1,5)=N+4
58101 K(N+2,3)=IA5
58102 K(N+3,3)=N+1
58103 K(N+3,4)=N+5
58104 K(N+3,5)=N+6
58105 K(N+4,3)=N+1
58106 K(N+5,3)=N+3
58107 K(N+6,3)=N+3
58108
58109C...Set up momenta for new partons.
58110 DO 130 J=1,5
58111 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58112 P(N+2,J)=P(IA5,J)
58113 P(N+3,J)=P(IA3,J)+P(IA4,J)
58114 P(N+4,J)=P(IA2,J)
58115 P(N+5,J)=P(IA3,J)
58116 P(N+6,J)=P(IA4,J)
58117 130 CONTINUE
58118 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58119 & P(N+1,3)**2))
58120 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
58121 & P(N+3,3)**2))
58122 QMAX=P(N+3,5)
58123
58124C...Third case: q radiates g, g branches.
58125C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
58126C...IA5=N+2 does not radiate.
58127 ELSE
58128
58129C...Set up flavour and history pointers for new partons.
58130 K(N+1,2)=K(IA2,2)
58131 K(N+2,2)=K(IA5,2)
58132 K(N+3,2)=K(IA2,2)
58133 K(N+4,2)=21
58134 K(N+5,2)=K(IA3,2)
58135 K(N+6,2)=K(IA4,2)
58136 K(N+1,3)=IA2
58137 K(N+1,4)=N+3
58138 K(N+1,5)=N+4
58139 K(N+2,3)=IA5
58140 K(N+3,3)=N+1
58141 K(N+4,3)=N+1
58142 K(N+4,4)=N+5
58143 K(N+4,5)=N+6
58144 K(N+5,3)=N+4
58145 K(N+6,3)=N+4
58146
58147C...Set up momenta for new partons.
58148 DO 140 J=1,5
58149 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
58150 P(N+2,J)=P(IA5,J)
58151 P(N+3,J)=P(IA2,J)
58152 P(N+4,J)=P(IA3,J)+P(IA4,J)
58153 P(N+5,J)=P(IA3,J)
58154 P(N+6,J)=P(IA4,J)
58155 140 CONTINUE
58156 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
58157 & P(N+1,3)**2))
58158 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
58159 & P(N+4,3)**2))
58160 QMAX=P(N+4,5)
58161
58162 ENDIF
58163 N=N+6
58164
58165 RETURN
58166 END
58167
58168C*********************************************************************
58169
58170C...PYJOIN
58171C...Connects a sequence of partons with colour flow indices,
58172C...as required for subsequent shower evolution (or other operations).
58173
58174 SUBROUTINE PYJOIN(NJOIN,IJOIN)
58175
58176C...Double precision and integer declarations.
58177 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58178 IMPLICIT INTEGER(I-N)
58179 INTEGER PYK,PYCHGE,PYCOMP
58180C...Commonblocks.
58181 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58183 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58184 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58185C...Local array.
58186 DIMENSION IJOIN(*)
58187
58188C...Check that partons are of right types to be connected.
58189 IF(NJOIN.LT.2) GOTO 120
58190 KQSUM=0
58191 DO 100 IJN=1,NJOIN
58192 I=IJOIN(IJN)
58193 IF(I.LE.0.OR.I.GT.N) GOTO 120
58194 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
58195 KC=PYCOMP(K(I,2))
58196 IF(KC.EQ.0) GOTO 120
58197 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
58198 IF(KQ.EQ.0) GOTO 120
58199 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
58200 IF(KQ.NE.2) KQSUM=KQSUM+KQ
58201 IF(IJN.EQ.1) KQS=KQ
58202 100 CONTINUE
58203 IF(KQSUM.NE.0) GOTO 120
58204
58205C...Connect the partons sequentially (closing for gluon loop).
58206 KCS=(9-KQS)/2
58207 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
58208 DO 110 IJN=1,NJOIN
58209 I=IJOIN(IJN)
58210 K(I,1)=3
58211 IF(IJN.NE.1) IP=IJOIN(IJN-1)
58212 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
58213 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
58214 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
58215 K(I,KCS)=MSTU(5)*IN
58216 K(I,9-KCS)=MSTU(5)*IP
58217 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
58218 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
58219 110 CONTINUE
58220
58221C...Error exit: no action taken.
58222 RETURN
58223 120 CALL PYERRM(12,
58224 &'(PYJOIN:) given entries can not be joined by one string')
58225
58226 RETURN
58227 END
58228
58229C*********************************************************************
58230
58231C...PYGIVE
58232C...Sets values of commonblock variables.
58233
58234 SUBROUTINE PYGIVE(CHIN)
58235
58236C...Double precision and integer declarations.
58237 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58238 IMPLICIT INTEGER(I-N)
58239 INTEGER PYK,PYCHGE,PYCOMP
58240C...Commonblocks.
58241 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58243 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58244 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58245 COMMON/PYDAT4/CHAF(500,2)
58246 CHARACTER CHAF*16
58247 COMMON/PYDATR/MRPY(6),RRPY(100)
58248 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
58249 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
58250 COMMON/PYINT1/MINT(400),VINT(400)
58251 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
58252 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
58253 COMMON/PYINT4/MWID(500),WIDS(500,5)
58254 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
58255 COMMON/PYINT6/PROC(0:500)
58256 CHARACTER PROC*28
58257 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
58258 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
58259 &XPDIR(-6:6)
58260 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58261 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58262 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
58263 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
58264 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,
58265 &/PYINT5/,/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/
58266C...Local arrays and character variables.
58267 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
58268 &CHNEW2*28,CHNAM*6,CHVAR(54)*6,CHALP(2)*26,CHIND*8,CHINI*10,
58269 &CHINR*16,CHDIG*10
58270 DIMENSION MSVAR(54,8)
58271
58272C...For each variable to be translated give: name,
58273C...integer/real/character, no. of indices, lower&upper index bounds.
58274 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
58275 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
58276 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
58277 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
58278 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
58279 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
58280 &'ITCM','RTCM'/
58281 DATA ((MSVAR(I,J),J=1,8),I=1,54)/ 1,7*0, 1,2,1,4000,1,5,2*0,
58282 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
58283 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58284 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
58285 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
58286 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
58287 &1,1,1,6,4*0, 2,1,1,100,4*0,
58288 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
58289 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
58290 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
58291 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
58292 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
58293 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
58294 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
58295 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
58296 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
58297 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
58298 &1,1,0,99,4*0, 2,1,0,99,4*0/
58299 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58300 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
58301
58302C...Length of character variable. Subdivide it into instructions.
58303 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
58304 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
58305 CHBIT=CHIN//' '
58306 LBIT=101
58307 100 LBIT=LBIT-1
58308 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
58309 LTOT=0
58310 DO 110 LCOM=1,LBIT
58311 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
58312 LTOT=LTOT+1
58313 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
58314 110 CONTINUE
58315 LLOW=0
58316 120 LHIG=LLOW+1
58317 130 LHIG=LHIG+1
58318 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
58319 LBIT=LHIG-LLOW-1
58320 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
58321
58322C...Send off decay-mode on/off commands to PYONOF.
58323 IONOF=0
58324 DO 135 LDIG=1,10
58325 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
58326 135 CONTINUE
58327 IF(IONOF.EQ.1) THEN
58328 CALL PYONOF(CHIN)
58329 RETURN
58330 ENDIF
58331
58332C...Peel off any text following exclamation mark.
58333 LHIG2=LBIT
58334 DO 140 LLOW2=LHIG2,1,-1
58335 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
58336 140 CONTINUE
58337 IF(LBIT.EQ.0) RETURN
58338
58339C...Identify commonblock variable.
58340 LNAM=1
58341 150 LNAM=LNAM+1
58342 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
58343 &LNAM.LE.6) GOTO 150
58344 CHNAM=CHBIT(1:LNAM-1)//' '
58345 DO 170 LCOM=1,LNAM-1
58346 DO 160 LALP=1,26
58347 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
58348 & CHALP(2)(LALP:LALP)
58349 160 CONTINUE
58350 170 CONTINUE
58351 IVAR=0
58352 DO 180 IV=1,54
58353 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
58354 180 CONTINUE
58355 IF(IVAR.EQ.0) THEN
58356 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
58357 LLOW=LHIG
58358 IF(LLOW.LT.LTOT) GOTO 120
58359 RETURN
58360 ENDIF
58361
58362C...Identify any indices.
58363 I1=0
58364 I2=0
58365 I3=0
58366 NINDX=0
58367 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
58368 LIND=LNAM
58369 190 LIND=LIND+1
58370 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
58371 CHIND=' '
58372 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
58373 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
58374 & IVAR.EQ.37)) THEN
58375 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
58376 READ(CHIND,'(I8)') KF
58377 I1=PYCOMP(KF)
58378 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
58379 & 'c') THEN
58380 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
58381 & CHNAM)
58382 LLOW=LHIG
58383 IF(LLOW.LT.LTOT) GOTO 120
58384 RETURN
58385 ELSE
58386 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58387 READ(CHIND,'(I8)') I1
58388 ENDIF
58389 LNAM=LIND
58390 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58391 NINDX=1
58392 ENDIF
58393 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58394 LIND=LNAM
58395 200 LIND=LIND+1
58396 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
58397 CHIND=' '
58398 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58399 READ(CHIND,'(I8)') I2
58400 LNAM=LIND
58401 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
58402 NINDX=2
58403 ENDIF
58404 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
58405 LIND=LNAM
58406 210 LIND=LIND+1
58407 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
58408 CHIND=' '
58409 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
58410 READ(CHIND,'(I8)') I3
58411 LNAM=LIND+1
58412 NINDX=3
58413 ENDIF
58414
58415C...Check that indices allowed.
58416 IERR=0
58417 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
58418 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
58419 &IERR=2
58420 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
58421 &IERR=3
58422 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
58423 &IERR=4
58424 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
58425 IF(IERR.GE.1) THEN
58426 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
58427 & CHBIT(1:LNAM-1))
58428 LLOW=LHIG
58429 IF(LLOW.LT.LTOT) GOTO 120
58430 RETURN
58431 ENDIF
58432
58433C...Save old value of variable.
58434 IF(IVAR.EQ.1) THEN
58435 IOLD=N
58436 ELSEIF(IVAR.EQ.2) THEN
58437 IOLD=K(I1,I2)
58438 ELSEIF(IVAR.EQ.3) THEN
58439 ROLD=P(I1,I2)
58440 ELSEIF(IVAR.EQ.4) THEN
58441 ROLD=V(I1,I2)
58442 ELSEIF(IVAR.EQ.5) THEN
58443 IOLD=MSTU(I1)
58444 ELSEIF(IVAR.EQ.6) THEN
58445 ROLD=PARU(I1)
58446 ELSEIF(IVAR.EQ.7) THEN
58447 IOLD=MSTJ(I1)
58448 ELSEIF(IVAR.EQ.8) THEN
58449 ROLD=PARJ(I1)
58450 ELSEIF(IVAR.EQ.9) THEN
58451 IOLD=KCHG(I1,I2)
58452 ELSEIF(IVAR.EQ.10) THEN
58453 ROLD=PMAS(I1,I2)
58454 ELSEIF(IVAR.EQ.11) THEN
58455 ROLD=PARF(I1)
58456 ELSEIF(IVAR.EQ.12) THEN
58457 ROLD=VCKM(I1,I2)
58458 ELSEIF(IVAR.EQ.13) THEN
58459 IOLD=MDCY(I1,I2)
58460 ELSEIF(IVAR.EQ.14) THEN
58461 IOLD=MDME(I1,I2)
58462 ELSEIF(IVAR.EQ.15) THEN
58463 ROLD=BRAT(I1)
58464 ELSEIF(IVAR.EQ.16) THEN
58465 IOLD=KFDP(I1,I2)
58466 ELSEIF(IVAR.EQ.17) THEN
58467 CHOLD=CHAF(I1,I2)(1:8)
58468 ELSEIF(IVAR.EQ.18) THEN
58469 IOLD=MRPY(I1)
58470 ELSEIF(IVAR.EQ.19) THEN
58471 ROLD=RRPY(I1)
58472 ELSEIF(IVAR.EQ.20) THEN
58473 IOLD=MSEL
58474 ELSEIF(IVAR.EQ.21) THEN
58475 IOLD=MSUB(I1)
58476 ELSEIF(IVAR.EQ.22) THEN
58477 IOLD=KFIN(I1,I2)
58478 ELSEIF(IVAR.EQ.23) THEN
58479 ROLD=CKIN(I1)
58480 ELSEIF(IVAR.EQ.24) THEN
58481 IOLD=MSTP(I1)
58482 ELSEIF(IVAR.EQ.25) THEN
58483 ROLD=PARP(I1)
58484 ELSEIF(IVAR.EQ.26) THEN
58485 IOLD=MSTI(I1)
58486 ELSEIF(IVAR.EQ.27) THEN
58487 ROLD=PARI(I1)
58488 ELSEIF(IVAR.EQ.28) THEN
58489 IOLD=MINT(I1)
58490 ELSEIF(IVAR.EQ.29) THEN
58491 ROLD=VINT(I1)
58492 ELSEIF(IVAR.EQ.30) THEN
58493 IOLD=ISET(I1)
58494 ELSEIF(IVAR.EQ.31) THEN
58495 IOLD=KFPR(I1,I2)
58496 ELSEIF(IVAR.EQ.32) THEN
58497 ROLD=COEF(I1,I2)
58498 ELSEIF(IVAR.EQ.33) THEN
58499 IOLD=ICOL(I1,I2,I3)
58500 ELSEIF(IVAR.EQ.34) THEN
58501 ROLD=XSFX(I1,I2)
58502 ELSEIF(IVAR.EQ.35) THEN
58503 IOLD=ISIG(I1,I2)
58504 ELSEIF(IVAR.EQ.36) THEN
58505 ROLD=SIGH(I1)
58506 ELSEIF(IVAR.EQ.37) THEN
58507 IOLD=MWID(I1)
58508 ELSEIF(IVAR.EQ.38) THEN
58509 ROLD=WIDS(I1,I2)
58510 ELSEIF(IVAR.EQ.39) THEN
58511 IOLD=NGEN(I1,I2)
58512 ELSEIF(IVAR.EQ.40) THEN
58513 ROLD=XSEC(I1,I2)
58514 ELSEIF(IVAR.EQ.41) THEN
58515 CHOLD2=PROC(I1)
58516 ELSEIF(IVAR.EQ.42) THEN
58517 ROLD=SIGT(I1,I2,I3)
58518 ELSEIF(IVAR.EQ.43) THEN
58519 ROLD=XPVMD(I1)
58520 ELSEIF(IVAR.EQ.44) THEN
58521 ROLD=XPANL(I1)
58522 ELSEIF(IVAR.EQ.45) THEN
58523 ROLD=XPANH(I1)
58524 ELSEIF(IVAR.EQ.46) THEN
58525 ROLD=XPBEH(I1)
58526 ELSEIF(IVAR.EQ.47) THEN
58527 ROLD=XPDIR(I1)
58528 ELSEIF(IVAR.EQ.48) THEN
58529 IOLD=IMSS(I1)
58530 ELSEIF(IVAR.EQ.49) THEN
58531 ROLD=RMSS(I1)
58532 ELSEIF(IVAR.EQ.50) THEN
58533 ROLD=RVLAM(I1,I2,I3)
58534 ELSEIF(IVAR.EQ.51) THEN
58535 ROLD=RVLAMP(I1,I2,I3)
58536 ELSEIF(IVAR.EQ.52) THEN
58537 ROLD=RVLAMB(I1,I2,I3)
58538 ELSEIF(IVAR.EQ.53) THEN
58539 IOLD=ITCM(I1)
58540 ELSEIF(IVAR.EQ.54) THEN
58541 ROLD=RTCM(I1)
58542 ENDIF
58543
58544C...Print current value of variable. Loop back.
58545 IF(LNAM.GE.LBIT) THEN
58546 CHBIT(LNAM:14)=' '
58547 CHBIT(15:60)=' has the value '
58548 IF(MSVAR(IVAR,1).EQ.1) THEN
58549 WRITE(CHBIT(51:60),'(I10)') IOLD
58550 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58551 WRITE(CHBIT(47:60),'(F14.5)') ROLD
58552 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58553 CHBIT(53:60)=CHOLD
58554 ELSE
58555 CHBIT(33:60)=CHOLD
58556 ENDIF
58557 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58558 LLOW=LHIG
58559 IF(LLOW.LT.LTOT) GOTO 120
58560 RETURN
58561 ENDIF
58562
58563C...Read in new variable value.
58564 IF(MSVAR(IVAR,1).EQ.1) THEN
58565 CHINI=' '
58566 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
58567 READ(CHINI,'(I10)') INEW
58568 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58569 CHINR=' '
58570 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
58571 READ(CHINR,*) RNEW
58572 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58573 CHNEW=CHBIT(LNAM+1:LBIT)//' '
58574 ELSE
58575 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
58576 ENDIF
58577
58578C...Store new variable value.
58579 IF(IVAR.EQ.1) THEN
58580 N=INEW
58581 ELSEIF(IVAR.EQ.2) THEN
58582 K(I1,I2)=INEW
58583 ELSEIF(IVAR.EQ.3) THEN
58584 P(I1,I2)=RNEW
58585 ELSEIF(IVAR.EQ.4) THEN
58586 V(I1,I2)=RNEW
58587 ELSEIF(IVAR.EQ.5) THEN
58588 MSTU(I1)=INEW
58589 ELSEIF(IVAR.EQ.6) THEN
58590 PARU(I1)=RNEW
58591 ELSEIF(IVAR.EQ.7) THEN
58592 MSTJ(I1)=INEW
58593 ELSEIF(IVAR.EQ.8) THEN
58594 PARJ(I1)=RNEW
58595 ELSEIF(IVAR.EQ.9) THEN
58596 KCHG(I1,I2)=INEW
58597 ELSEIF(IVAR.EQ.10) THEN
58598 PMAS(I1,I2)=RNEW
58599 ELSEIF(IVAR.EQ.11) THEN
58600 PARF(I1)=RNEW
58601 ELSEIF(IVAR.EQ.12) THEN
58602 VCKM(I1,I2)=RNEW
58603 ELSEIF(IVAR.EQ.13) THEN
58604 MDCY(I1,I2)=INEW
58605 ELSEIF(IVAR.EQ.14) THEN
58606 MDME(I1,I2)=INEW
58607 ELSEIF(IVAR.EQ.15) THEN
58608 BRAT(I1)=RNEW
58609 ELSEIF(IVAR.EQ.16) THEN
58610 KFDP(I1,I2)=INEW
58611 ELSEIF(IVAR.EQ.17) THEN
58612 CHAF(I1,I2)=CHNEW
58613 ELSEIF(IVAR.EQ.18) THEN
58614 MRPY(I1)=INEW
58615 ELSEIF(IVAR.EQ.19) THEN
58616 RRPY(I1)=RNEW
58617 ELSEIF(IVAR.EQ.20) THEN
58618 MSEL=INEW
58619 ELSEIF(IVAR.EQ.21) THEN
58620 MSUB(I1)=INEW
58621 ELSEIF(IVAR.EQ.22) THEN
58622 KFIN(I1,I2)=INEW
58623 ELSEIF(IVAR.EQ.23) THEN
58624 CKIN(I1)=RNEW
58625 ELSEIF(IVAR.EQ.24) THEN
58626 MSTP(I1)=INEW
58627 ELSEIF(IVAR.EQ.25) THEN
58628 PARP(I1)=RNEW
58629 ELSEIF(IVAR.EQ.26) THEN
58630 MSTI(I1)=INEW
58631 ELSEIF(IVAR.EQ.27) THEN
58632 PARI(I1)=RNEW
58633 ELSEIF(IVAR.EQ.28) THEN
58634 MINT(I1)=INEW
58635 ELSEIF(IVAR.EQ.29) THEN
58636 VINT(I1)=RNEW
58637 ELSEIF(IVAR.EQ.30) THEN
58638 ISET(I1)=INEW
58639 ELSEIF(IVAR.EQ.31) THEN
58640 KFPR(I1,I2)=INEW
58641 ELSEIF(IVAR.EQ.32) THEN
58642 COEF(I1,I2)=RNEW
58643 ELSEIF(IVAR.EQ.33) THEN
58644 ICOL(I1,I2,I3)=INEW
58645 ELSEIF(IVAR.EQ.34) THEN
58646 XSFX(I1,I2)=RNEW
58647 ELSEIF(IVAR.EQ.35) THEN
58648 ISIG(I1,I2)=INEW
58649 ELSEIF(IVAR.EQ.36) THEN
58650 SIGH(I1)=RNEW
58651 ELSEIF(IVAR.EQ.37) THEN
58652 MWID(I1)=INEW
58653 ELSEIF(IVAR.EQ.38) THEN
58654 WIDS(I1,I2)=RNEW
58655 ELSEIF(IVAR.EQ.39) THEN
58656 NGEN(I1,I2)=INEW
58657 ELSEIF(IVAR.EQ.40) THEN
58658 XSEC(I1,I2)=RNEW
58659 ELSEIF(IVAR.EQ.41) THEN
58660 PROC(I1)=CHNEW2
58661 ELSEIF(IVAR.EQ.42) THEN
58662 SIGT(I1,I2,I3)=RNEW
58663 ELSEIF(IVAR.EQ.43) THEN
58664 XPVMD(I1)=RNEW
58665 ELSEIF(IVAR.EQ.44) THEN
58666 XPANL(I1)=RNEW
58667 ELSEIF(IVAR.EQ.45) THEN
58668 XPANH(I1)=RNEW
58669 ELSEIF(IVAR.EQ.46) THEN
58670 XPBEH(I1)=RNEW
58671 ELSEIF(IVAR.EQ.47) THEN
58672 XPDIR(I1)=RNEW
58673 ELSEIF(IVAR.EQ.48) THEN
58674 IMSS(I1)=INEW
58675 ELSEIF(IVAR.EQ.49) THEN
58676 RMSS(I1)=RNEW
58677 ELSEIF(IVAR.EQ.50) THEN
58678 RVLAM(I1,I2,I3)=RNEW
58679 ELSEIF(IVAR.EQ.51) THEN
58680 RVLAMP(I1,I2,I3)=RNEW
58681 ELSEIF(IVAR.EQ.52) THEN
58682 RVLAMB(I1,I2,I3)=RNEW
58683 ELSEIF(IVAR.EQ.53) THEN
58684 ITCM(I1)=INEW
58685 ELSEIF(IVAR.EQ.54) THEN
58686 RTCM(I1)=RNEW
58687 ENDIF
58688
58689C...Write old and new value. Loop back.
58690 CHBIT(LNAM:14)=' '
58691 CHBIT(15:60)=' changed from to '
58692 IF(MSVAR(IVAR,1).EQ.1) THEN
58693 WRITE(CHBIT(33:42),'(I10)') IOLD
58694 WRITE(CHBIT(51:60),'(I10)') INEW
58695 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58696 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
58697 WRITE(CHBIT(29:42),'(F14.5)') ROLD
58698 WRITE(CHBIT(47:60),'(F14.5)') RNEW
58699 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58700 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
58701 CHBIT(35:42)=CHOLD
58702 CHBIT(53:60)=CHNEW
58703 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
58704 ELSE
58705 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
58706 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
58707 ENDIF
58708 LLOW=LHIG
58709 IF(LLOW.LT.LTOT) GOTO 120
58710
58711C...Format statement for output on unit MSTU(11) (by default 6).
58712 5000 FORMAT(5X,A60)
58713 5100 FORMAT(5X,A88)
58714
58715 RETURN
58716 END
58717
58718C*********************************************************************
58719
58720C...PYONOF
58721C...Switches on and off decay channel by search for match.
58722
58723 SUBROUTINE PYONOF(CHIN)
58724
58725C...Double precision and integer declarations.
58726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58727 IMPLICIT INTEGER(I-N)
58728 INTEGER PYK,PYCHGE,PYCOMP
58729C...Commonblocks.
58730 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58731 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
58732 SAVE /PYDAT1/,/PYDAT3/
58733C...Local arrays and character variables.
58734 INTEGER KFCMP(10),KFTMP(10)
58735 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
58736 &CHALP(2)*26
58737 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
58738 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
58739
58740C...Determine length of character variable.
58741 CHTMP=CHIN//' '
58742 LBEG=0
58743 100 LBEG=LBEG+1
58744 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
58745 LEND=LBEG-1
58746 105 LEND=LEND+1
58747 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
58748 110 LEND=LEND-1
58749 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
58750 LEN=1+LEND-LBEG
58751 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
58752
58753C...Find colon separator and particle code.
58754 LCOLON=0
58755 120 LCOLON=LCOLON+1
58756 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
58757 CHCODE=' '
58758 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
58759 READ(CHCODE,'(I8)',ERR=300) KF
58760 KC=PYCOMP(KF)
58761
58762C...Done if unknown code or no decay channels.
58763 IF(KC.EQ.0) THEN
58764 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
58765 RETURN
58766 ENDIF
58767 IDCBEG=MDCY(KC,2)
58768 IDCLEN=MDCY(KC,3)
58769 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
58770 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
58771 RETURN
58772 ENDIF
58773
58774C...Find command name up to blank or equal sign.
58775 LSEP=LCOLON
58776 130 LSEP=LSEP+1
58777 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
58778 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
58779 CHMODE=' '
58780 LMODE=LSEP-LCOLON-1
58781 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
58782
58783C...Convert to uppercase.
58784 DO 150 LCOM=1,LMODE
58785 DO 140 LALP=1,26
58786 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
58787 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
58788 140 CONTINUE
58789 150 CONTINUE
58790
58791C...Identify command. Failed if not identified.
58792 MODE=0
58793 IF(CHMODE.EQ.'ALLOFF') MODE=1
58794 IF(CHMODE.EQ.'ALLON') MODE=2
58795 IF(CHMODE.EQ.'OFFIFANY') MODE=3
58796 IF(CHMODE.EQ.'ONIFANY') MODE=4
58797 IF(CHMODE.EQ.'OFFIFALL') MODE=5
58798 IF(CHMODE.EQ.'ONIFALL') MODE=6
58799 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
58800 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
58801 IF(MODE.EQ.0) THEN
58802 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
58803 RETURN
58804 ENDIF
58805
58806C...Simple cases when all on or all off.
58807 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
58808 WRITE(MSTU(11),1000) KF,CHMODE
58809 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
58810 IF(MDME(IDC,1).LT.0) GOTO 160
58811 MDME(IDC,1)=MODE-1
58812 160 CONTINUE
58813 RETURN
58814 ENDIF
58815
58816C...Identify matching list.
58817 NCMP=0
58818 LBEG=LSEP
58819 170 LBEG=LBEG+1
58820 IF(LBEG.GT.LEN) GOTO 190
58821 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
58822 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
58823 LEND=LBEG-1
58824 180 LEND=LEND+1
58825 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
58826 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
58827 IF(LEND.LT.LEN) LEND=LEND-1
58828 CHCODE=' '
58829 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
58830 READ(CHCODE,'(I8)',ERR=300) KFREAD
58831 NCMP=NCMP+1
58832 KFCMP(NCMP)=IABS(KFREAD)
58833 LBEG=LEND
58834 IF(NCMP.LT.10) GOTO 170
58835 190 CONTINUE
58836 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
58837
58838C...Only one matching required.
58839 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
58840 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
58841 IF(MDME(IDC,1).LT.0) GOTO 220
58842 DO 210 IKF=1,5
58843 KFNOW=IABS(KFDP(IDC,IKF))
58844 IF(KFNOW.EQ.0) GOTO 210
58845 DO 200 ICMP=1,NCMP
58846 IF(KFCMP(ICMP).EQ.KFNOW) THEN
58847 MDME(IDC,1)=MODE-3
58848 GOTO 220
58849 ENDIF
58850 200 CONTINUE
58851 210 CONTINUE
58852 220 CONTINUE
58853 RETURN
58854 ENDIF
58855
58856C...Multiple matchings required.
58857 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
58858 IF(MDME(IDC,1).LT.0) GOTO 260
58859 NTMP=NCMP
58860 DO 230 ITMP=1,NTMP
58861 KFTMP(ITMP)=KFCMP(ITMP)
58862 230 CONTINUE
58863 NFIN=0
58864 DO 250 IKF=1,5
58865 KFNOW=IABS(KFDP(IDC,IKF))
58866 IF(KFNOW.EQ.0) GOTO 250
58867 NFIN=NFIN+1
58868 DO 240 ITMP=1,NTMP
58869 IF(KFTMP(ITMP).EQ.KFNOW) THEN
58870 KFTMP(ITMP)=KFTMP(NTMP)
58871 NTMP=NTMP-1
58872 GOTO 250
58873 ENDIF
58874 240 CONTINUE
58875 250 CONTINUE
58876 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
58877 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
58878 & MDME(IDC,1)=MODE-7
58879 260 CONTINUE
58880 RETURN
58881
58882C...Error exit for impossible read of particle code.
58883 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
58884 &//CHCODE)
58885
58886C...Formats for output.
58887 1000 FORMAT(' Decays for',I8,' set ',A10)
58888 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
58889
58890 RETURN
58891 END
58892C*********************************************************************
58893
58894C...PYTUNE
58895C...Presets for a few specific underlying-event and min-bias tunes
58896C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
58897C...others require particular versions of pythia (e.g. the SCI and GAL
58898C...models). See below for details.
58899 SUBROUTINE PYTUNE(ITUNE)
58900C
58901C ITUNE NAME (detailed descriptions below)
58902C 0 Default : No settings changed => linked Pythia version's defaults.
58903C ====== Old UE, Q2-ordered showers ==========================================
58904C 100 A : Rick Field's CDF Tune A
58905C 101 AW : Rick Field's CDF Tune AW
58906C 102 BW : Rick Field's CDF Tune BW
58907C 103 DW : Rick Field's CDF Tune DW
58908C 104 DWT : Rick Field's CDF Tune DW with slower UE energy scaling
58909C 105 QW : Rick Field's CDF Tune QW (NB: needs CTEQ6.1M pdfs externally)
58910C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune (ATLAS DC2 / Rome)
58911C 107 ACR : Tune A modified with annealing CR
58912C 108 D6 : Rick Field's CDF Tune D6 (NB: needs CTEQ6L pdfs externally)
58913C 109 D6T : Rick Field's CDF Tune D6T (NB: needs CTEQ6L pdfs externally)
58914C ====== Intermediate Models =================================================
58915C 200 IM 1 : Intermediate model: new UE, Q2-ordered showers, annealing CR
58916C 201 APT : Tune A modified to use pT-ordered final-state showers
58917C ====== New UE, interleaved pT-ordered showers, annealing CR ================
58918C 300 S0 : Sandhoff-Skands Tune 0
58919C 301 S1 : Sandhoff-Skands Tune 1
58920C 302 S2 : Sandhoff-Skands Tune 2
58921C 303 S0A : S0 with "Tune A" UE energy scaling
58922C 304 NOCR : New UE "best try" without colour reconnections
58923C 305 Old : New UE, original (primitive) colour reconnections
58924C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune (needs CTEQ6L externally)
58925C ======= The Uppsala models =================================================
58926C ( NB! must be run with special modified Pythia 6.215 version )
58927C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
58928C 400 GAL 0 : Generalized area-law model. Old parameters
58929C 401 SCI 0 : Soft-Colour-Interaction model. Old parameters
58930C 402 GAL 1 : Generalized area-law model. Tevatron MB retuned (Skands)
58931C 403 SCI 1 : Soft-Colour-Interaction model. Tevatron MB retuned (Skands)
58932C
58933C More details;
58934C
58935C Quick Dictionary:
58936C BE : Bose-Einstein
58937C BR : Beam Remnants
58938C CR : Colour Reconnections
58939C HAD: Hadronization
58940C ISR/FSR: Initial-State Radiation / Final-State Radiation
58941C FSI: Final-State Interactions (=CR+BE)
58942C MB : Minimum-bias
58943C MI : Multiple Interactions
58944C UE : Underlying Event
58945C
58946C A (100) and AW (101). Old UE model, Q2-ordered showers.
58947C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58948C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58949C...Key feature: extensively compared to CDF data (R.D. Field).
58950C...* Large starting scale for ISR (PARP(67)=4)
58951C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
58952C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58953C
58954C BW (102). Old UE model, Q2-ordered showers.
58955C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58956C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58957C...Key feature: extensively compared to CDF data (R.D. Field).
58958C...NB: Can also be run with Pythia 6.2 or 6.312+
58959C...* Small starting scale for ISR (PARP(67)=1)
58960C...* BW has more radiation due to smaller mu_R choice in alpha_s.
58961C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58962C
58963C DW (103) and DWT (104). Old UE model, Q2-ordered showers.
58964C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58965C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58966C...Key feature: extensively compared to CDF data (R.D. Field).
58967C...NB: Can also be run with Pythia 6.2 or 6.312+
58968C...* Intermediate starting scale for ISR (PARP(67)=2.5)
58969C...* DWT has a different reference energy, the same as the "S" models
58970C... below, leading to more UE activity at the LHC, but less at RHIC.
58971C...* See: http://www.phys.ufl.edu/~rfield/cdf/
58972C
58973C QW (105). Old UE model, Q2-ordered showers.
58974C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58975C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58976C...Key feature: uses CTEQ61 (external pdf library must be linked)
58977C
58978C ATLAS-DC2 (106). Old UE model, Q2-ordered showers.
58979C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
58980C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
58981C...Key feature: tune used by the ATLAS collaboration.
58982C
58983C ACR (107). Old UE model, Q2-ordered showers, annealing CR.
58984C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
58985C...Key feature: Tune A modified to use annealing CR.
58986C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
58987C
58988C D6 (108) and D6T (109). Old UE model, Q2-ordered showers, CTEQ6L PDF.
58989C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
58990C
58991C...IM1 (200). Intermediate model, Q2-ordered showers.
58992C...Key feature: new UE model with Q2-ordered showers and no interleaving.
58993C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
58994C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
58995C
58996C...APT (201). Old UE model, pT-ordered final-state showers
58997C...Key feature: Rick Field's Tune A, but with new final-state showers
58998C
58999C S0 (300) and S0A (303). New UE model, pT-ordered showers.
59000C...Key feature: large amount of multiple interactions
59001C...* Somewhat faster than the other colour annealing scenarios.
59002C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
59003C... from Tune A, leading to less UE at the LHC, but more at RHIC.
59004C...* Small amount of radiation.
59005C...* Large amount of low-pT MI
59006C...* Low degree of proton lumpiness (broad matter dist.)
59007C...* CR Type S (driven by free triplets), of medium strength.
59008C...* See: Pythia6402 update notes or later.
59009C
59010C S1 (301). New UE model, pT-ordered showers.
59011C...Key feature: large amount of radiation.
59012C...* Large amount of low-pT perturbative ISR
59013C...* Large amount of FSR off ISR partons
59014C...* Small amount of low-pT multiple interactions
59015C...* Moderate degree of proton lumpiness
59016C...* Least aggressive CR type (S+S Type I), but with large strength
59017C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59018C
59019C S2 (302). New UE model, pT-ordered showers.
59020C...Key feature: very lumpy proton + gg string cluster formation allowed
59021C...* Small amount of radiation
59022C...* Moderate amount of low-pT MI
59023C...* High degree of proton lumpiness (more spiky matter distribution)
59024C...* Most aggressive CR type (S+S Type II), but with small strength
59025C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
59026C
59027C NOCR (304). New UE model, pT-ordered showers.
59028C...Key feature: no colour reconnections (NB: "Best fit" only).
59029C...* NB: <pT>(Nch) problematic in this tune.
59030C...* Small amount of radiation
59031C...* Small amount of low-pT MI
59032C...* Low degree of proton lumpiness
59033C...* Large BR composite x enhancement factor
59034C...* Most clever colour flow without CR ("Lambda ordering")
59035C
59036C ATLAS-CSC (306). New UE mode, pT-ordered showers, CTEQ6L.
59037C...Key feature: 11-parameter ATLAS tune of the new framework.
59038C...* Old (pre-annealing) colour reconnections a la 305.
59039C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
59040C
59041C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
59042C...with an unmodified Pythia distribution.
59043C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
59044C
59045C ::: + Future improvements?
59046C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
59047C (problem: K-factor affects everything so only works as
59048C intended for min-bias, not for UE ... probably need a
59049C better long-term solution to handle UE as well. Anyway,
59050C Mark uses MSTP(33) and PARP(31)-PARP(33).)
59051
59052C...Global statements
59053 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59054 INTEGER PYK,PYCHGE,PYCOMP
59055
59056C...Commonblocks.
59057 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59058 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59059
59060C...SCI and GAL Commonblocks
59061 COMMON /SCIPAR/MSWI(2),PARSCI(2)
59062
59063C...Internal parameters
59064 PARAMETER(MXTUNS=500)
59065 CHARACTER*8 CHVERS, CHDOC
59066 PARAMETER (CHVERS='1.012 ',CHDOC='Sep 2007')
59067 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
59068 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
59069 & CHPARJ(41:100), CH40
59070 CHARACTER*60 CH60
59071 CHARACTER*70 CH70
59072 DATA (CHNAMS(I),I=0,1)/'Default',' '/
59073 DATA (CHNAMS(I),I=100,110)/
59074 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
59075 & 'ATLAS Tune','Tune ACR','Tune D6','Tune D6T',' '/
59076 DATA (CHNAMS(I),I=300,310)/
59077 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
59078 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',2*' '/
59079 DATA (CHNAMS(I),I=200,210)/
59080 & 'IM Tune 1','Tune APT',9*' '/
59081 DATA (CHNAMS(I),I=400,410)/
59082 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',7*' '/
59083 DATA (CHMSTJ(I),I=11,20)/
59084 & 'HAD choice of fragmentation function(s)',4*' ',
59085 & 'HAD treatment of small-mass systems',4*' '/
59086 DATA (CHMSTJ(I),I=41,50)/
59087 & 'FSR type (Q2 or pT) for old framework',9*' '/
59088 DATA (CHMSTP(I),I=51,100)/
59089 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
59090 6 'ISR master switch',6*' ',
59091 6 'ISR phase space choice & ME corrections',' ',
59092 7 'ISR IR regularization scheme',' ',
59093 7 'ISR scheme for FSR off ISR',8*' ',
59094 8 'UE model',
59095 8 'UE hadron transverse mass distribution',5*' ',
59096 8 'BR composite scheme','BR colour scheme',
59097 9 'BR primordial kT compensation',
59098 9 'BR primordial kT distribution',
59099 9 'BR energy partitioning scheme',2*' ',
59100 9 'FSI colour (re-)connection model',5*' '/
59101 DATA (CHPARP(I),I=61,100)/
59102 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
59103 6 2*' ','ISR Q2max factor',3*' ',
59104 7 'FSR Q2max factor for non-s-channel procs',5*' ',
59105 7 'FSI colour reconnection turnoff scale',
59106 7 'FSI colour reconnection strength',
59107 7 'BR composite x enhancement','BR breakup suppression',
59108 8 2*'UE IR cutoff at reference ecm',
59109 8 2*'UE mass distribution parameter',
59110 8 'UE gg colour correlated fraction','UE total gg fraction',
59111 8 2*' ',
59112 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
59113 9 'BR primordial kT width <|kT|>',' ',
59114 9 'BR primordial kT UV cutoff',7*' '/
59115 DATA (CHPARJ(I),I=41,90)/
59116 4 ' ','HAD string parameter b',8*' ',
59117 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
59118 6 10*' ',10*' ',
59119 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
59120 SAVE /PYDAT1/,/PYPARS/
59121 SAVE /SCIPAR/
59122
59123C...1) Shorthand notation
59124 M13=MSTU(13)
59125 M11=MSTU(11)
59126 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
59127 CHNAME=CHNAMS(ITUNE)
59128 IF (ITUNE.EQ.0) GOTO 9999
59129 ELSE
59130 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
59131 GOTO 9999
59132 ENDIF
59133
59134C...2) Hello World
59135 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
59136
59137C...3) Tune parameters
59138
59139C=============================================================================
59140C...Tunes S0, S1, S2, S0A, NOCR, and RAP (by P. Skands)
59141 IF (ITUNE.GE.300.AND.ITUNE.LE.305) THEN
59142 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59143 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59144 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59145 & ' with tune.')
59146 ENDIF
59147
59148C...PDFs
59149 MSTP(52)=1
59150 MSTP(51)=7
59151C...ISR
59152 PARP(64)=1D0
59153C...UE on, new model.
59154 MSTP(81)=21
59155C...Slow IR cutoff energy scaling by default
59156 PARP(89)=1800D0
59157 PARP(90)=0.16D0
59158C...Switch off trial joinings
59159 MSTP(96)=0
59160C...Primordial kT cutoff
59161 PARP(93)=5D0
59162
59163C...S0 (300), S0A (303)
59164 IF (ITUNE.EQ.300.OR.ITUNE.EQ.303) THEN
59165 IF (M13.GE.1) THEN
59166 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59167 WRITE(M11,5030) CH60
59168 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
59169 WRITE(M11,5030) CH60
59170 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59171 WRITE(M11,5030) CH60
59172 ENDIF
59173C...Smooth ISR, low FSR
59174 MSTP(70)=2
59175 MSTP(72)=0
59176C...pT0
59177 PARP(82)=1.85D0
59178C...Transverse density profile.
59179 MSTP(82)=5
59180 PARP(83)=1.6D0
59181C...Colour Reconnections
59182 MSTP(95)=6
59183 PARP(78)=0.20D0
59184 PARP(77)=0.0D0
59185C... Reference energy for pT0 and energy scaling pace.
59186 IF (ITUNE.EQ.303) PARP(90)=0.25D0
59187C...Lambda_FSR scale.
59188 PARJ(81)=0.23D0
59189C...FSR activity.
59190 PARP(71)=4D0
59191C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59192 MSTP(89)=1
59193 MSTP(88)=0
59194 PARP(79)=2D0
59195 PARP(80)=0.01D0
59196
59197C...S1 (301)
59198 ELSEIF(ITUNE.EQ.301) THEN
59199 IF (M13.GE.1) THEN
59200 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59201 WRITE(M11,5030) CH60
59202 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59203 WRITE(M11,5030) CH60
59204 ENDIF
59205C...Sharp ISR, high FSR
59206 MSTP(70)=0
59207 MSTP(72)=1
59208C...pT0
59209 PARP(82)=2.1D0
59210C...Colour Reconnections
59211 MSTP(95)=2
59212 PARP(78)=0.35D0
59213C...Transverse density profile.
59214 MSTP(82)=5
59215 PARP(83)=1.4D0
59216C...Lambda_FSR scale.
59217 PARJ(81)=0.23D0
59218C...FSR activity.
59219 PARP(71)=4D0
59220C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59221 MSTP(89)=1
59222 MSTP(88)=0
59223 PARP(79)=2D0
59224 PARP(80)=0.01D0
59225
59226C...S2 (302)
59227 ELSEIF(ITUNE.EQ.302) THEN
59228 IF (M13.GE.1) THEN
59229 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
59230 WRITE(M11,5030) CH60
59231 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59232 WRITE(M11,5030) CH60
59233 ENDIF
59234C...Smooth ISR, low FSR
59235 MSTP(70)=2
59236 MSTP(72)=0
59237C...pT0
59238 PARP(82)=1.9D0
59239C...Transverse density profile.
59240 MSTP(82)=5
59241 PARP(83)=1.2D0
59242C...Colour Reconnections
59243 MSTP(95)=4
59244 PARP(78)=0.15D0
59245C...Lambda_FSR scale.
59246 PARJ(81)=0.23D0
59247C...FSR activity.
59248 PARP(71)=4D0
59249C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59250 MSTP(89)=1
59251 MSTP(88)=0
59252 PARP(79)=2D0
59253 PARP(80)=0.01D0
59254
59255C...NOCR (304)
59256 ELSEIF(ITUNE.EQ.304) THEN
59257 IF (M13.GE.1) THEN
59258 CH60='"best try" without colour reconnections'
59259 WRITE(M11,5030) CH60
59260 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
59261 WRITE(M11,5030) CH60
59262 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59263 WRITE(M11,5030) CH60
59264 ENDIF
59265C...Smooth ISR, low FSR
59266 MSTP(70)=2
59267 MSTP(72)=0
59268C...pT0
59269 PARP(82)=2.05D0
59270C...Transverse density profile.
59271 MSTP(82)=5
59272 PARP(83)=1.8D0
59273C...Colour Reconnections
59274 MSTP(95)=0
59275C...Lambda_FSR scale.
59276 PARJ(81)=0.23D0
59277C...FSR activity.
59278 PARP(71)=4D0
59279C...Lambda order, Valence qq, large qq x enhc, BR-g-BR supp
59280 MSTP(89)=2
59281 MSTP(88)=0
59282 PARP(79)=3D0
59283 PARP(80)=0.01D0
59284
59285C..."Lo FSR" retune (305)
59286 ELSEIF(ITUNE.EQ.305) THEN
59287 IF (M13.GE.1) THEN
59288 CH60='"Lo FSR retune" with primitive colour reconnections'
59289 WRITE(M11,5030) CH60
59290 CH60='see T. Sjostrand & P. Skands, EPJC39(2005)129'
59291 WRITE(M11,5030) CH60
59292 ENDIF
59293C...Smooth ISR, low FSR
59294 MSTP(70)=2
59295 MSTP(72)=0
59296C...pT0
59297 PARP(82)=1.9D0
59298C...Transverse density profile.
59299 MSTP(82)=5
59300 PARP(83)=2.0D0
59301C...Colour Reconnections
59302 MSTP(95)=1
59303 PARP(78)=1.0D0
59304C...Lambda_FSR scale.
59305 PARJ(81)=0.23D0
59306C...FSR activity.
59307 PARP(71)=4D0
59308C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59309 MSTP(89)=1
59310 MSTP(88)=0
59311 PARP(79)=2D0
59312 PARP(80)=0.01D0
59313 ENDIF
59314C...Output
59315 IF (M13.GE.1) THEN
59316 WRITE(M11,5030) ' '
59317 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59318 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59319 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59320 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59321 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59322 WRITE(M11,5030) CH60
59323 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59324 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59325 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59326 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59327 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59328 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59329 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59330 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59331 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59332 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59333 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59334 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59335 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59336 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59337 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59338 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59339 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59340 ENDIF
59341
59342C=============================================================================
59343C...ATLAS-CSC 11-parameter tune (By A. Moraes)
59344 ELSEIF (ITUNE.EQ.306) THEN
59345 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
59346 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59347 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59348 & ' with tune.')
59349 ENDIF
59350
59351C...PDFs
59352 MSTP(52)=2
59353 MSTP(54)=2
59354 MSTP(56)=2
59355 MSTP(51)=10042
59356 MSTP(53)=10042
59357 MSTP(55)=10042
59358C...ISR
59359C PARP(64)=1D0
59360C...UE on, new model.
59361 MSTP(81)=21
59362C...Energy scaling
59363 PARP(89)=1800D0
59364 PARP(90)=0.22D0
59365C...Switch off trial joinings
59366 MSTP(96)=0
59367C...Primordial kT cutoff
59368
59369 IF (M13.GE.1) THEN
59370 CH60='see presentations by A. Moraes (ATLAS),'
59371 WRITE(M11,5030) CH60
59372 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59373 WRITE(M11,5030) CH60
59374 WRITE(M11,5030) ' '
59375 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59376 & 'externally linked and'
59377 WRITE(M11,5035) CH70
59378 CH70='MSTP(51) should be set manually according to '//
59379 & 'the library used'
59380 WRITE(M11,5035) CH70
59381 ENDIF
59382C...Smooth ISR, low FSR
59383 MSTP(70)=2
59384 MSTP(72)=0
59385C...pT0
59386 PARP(82)=1.9D0
59387C...Transverse density profile.
59388 MSTP(82)=4
59389 PARP(83)=0.3D0
59390 PARP(84)=0.5D0
59391C...ISR & FSR in interactions after the first (default)
59392 MSTP(84)=1
59393 MSTP(85)=1
59394C...No double-counting (default)
59395 MSTP(86)=2
59396C...Companion quark parent gluon (1-x) power
59397 MSTP(87)=4
59398C...Primordial kT compensation along chaings (default = 0 : uniform)
59399 MSTP(90)=1
59400C...Colour Reconnections
59401 MSTP(95)=1
59402 PARP(78)=0.2D0
59403C...Lambda_FSR scale.
59404 PARJ(81)=0.23D0
59405C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
59406 MSTP(89)=1
59407 MSTP(88)=0
59408C PARP(79)=2D0
59409 PARP(80)=0.01D0
59410C...Peterson charm frag, and c and b hadr parameters
59411 MSTJ(11)=3
59412 PARJ(54)=-0.07
59413 PARJ(55)=-0.006
59414C... Output
59415 IF (M13.GE.1) THEN
59416 WRITE(M11,5030) ' '
59417 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59418 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59419 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59420 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59421 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59422 WRITE(M11,5030) CH60
59423 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
59424 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
59425 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59426 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59427 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
59428 WRITE(M11,5030) CH60
59429 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59430 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59431 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59432 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59433 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59434 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59435 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59436 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59437 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59438 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
59439 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59440 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59441 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59442 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59443 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59444 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59445 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59446 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59447 ENDIF
59448
59449C=============================================================================
59450C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
59451C...(100-105,108-109) and ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
59452 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
59453 & ITUNE.EQ.109) THEN
59454 IF (M13.GE.1.AND.ITUNE.NE.106) THEN
59455 WRITE(M11,5010) ITUNE, CHNAME
59456 CH60='see R.D. Field (CDF), in hep-ph/0610012'
59457 WRITE(M11,5030) CH60
59458 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59459 WRITE(M11,5030) CH60
59460 ENDIF
59461C...Multiple interactions on, old framework
59462 MSTP(81)=1
59463C...Fast IR cutoff energy scaling by default
59464 PARP(89)=1800D0
59465 PARP(90)=0.25D0
59466C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
59467 MSTP(51)=7
59468 MSTP(52)=1
59469 IF (ITUNE.EQ.105) THEN
59470 MSTP(51)=10150
59471 MSTP(52)=2
59472 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59473 MSTP(52)=2
59474 MSTP(54)=2
59475 MSTP(56)=2
59476 MSTP(51)=10042
59477 MSTP(53)=10042
59478 MSTP(55)=10042
59479 ENDIF
59480C...Double Gaussian matter distribution.
59481 MSTP(82)=4
59482 PARP(83)=0.5D0
59483 PARP(84)=0.4D0
59484C...FSR activity.
59485 PARP(71)=4D0
59486C...Lambda_FSR scale.
59487 PARJ(81)=0.29D0
59488C...Fragmentation functions and c and b parameters
59489 MSTJ(11)=4
59490 PARJ(54)=-0.05
59491 PARJ(55)=-0.005
59492
59493C...Tune A and AW
59494 IF(ITUNE.EQ.100.OR.ITUNE.EQ.101) THEN
59495C...pT0.
59496 PARP(82)=2.0D0
59497c...String drawing almost completely minimizes string length.
59498 PARP(85)=0.9D0
59499 PARP(86)=0.95D0
59500C...ISR cutoff, muR scale factor, and phase space size
59501 PARP(62)=1D0
59502 PARP(64)=1D0
59503 PARP(67)=4D0
59504C...Intrinsic kT, size, and max
59505 MSTP(91)=1
59506 PARP(91)=1D0
59507 PARP(93)=5D0
59508C...AW : higher ISR IR cutoff, but also larger alpha_s and more intrinsic kT.
59509 IF (ITUNE.EQ.101) THEN
59510 PARP(62)=1.25D0
59511 PARP(64)=0.2D0
59512 PARP(91)=2.1D0
59513 PARP(92)=15.0D0
59514 ENDIF
59515
59516C...Tune BW (larger alpha_s, more intrinsic kT. Smaller ISR phase space.)
59517 ELSEIF (ITUNE.EQ.102) THEN
59518C...pT0.
59519 PARP(82)=1.9D0
59520c...String drawing completely minimizes string length.
59521 PARP(85)=1.0D0
59522 PARP(86)=1.0D0
59523C...ISR cutoff, muR scale factor, and phase space size
59524 PARP(62)=1.25D0
59525 PARP(64)=0.2D0
59526 PARP(67)=1D0
59527C...Intrinsic kT, size, and max
59528 MSTP(91)=1
59529 PARP(91)=2.1D0
59530 PARP(93)=15D0
59531
59532C...Tune DW
59533 ELSEIF (ITUNE.EQ.103) THEN
59534C...pT0.
59535 PARP(82)=1.9D0
59536c...String drawing completely minimizes string length.
59537 PARP(85)=1.0D0
59538 PARP(86)=1.0D0
59539C...ISR cutoff, muR scale factor, and phase space size
59540 PARP(62)=1.25D0
59541 PARP(64)=0.2D0
59542 PARP(67)=2.5D0
59543C...Intrinsic kT, size, and max
59544 MSTP(91)=1
59545 PARP(91)=2.1D0
59546 PARP(93)=15D0
59547
59548C...Tune DWT
59549 ELSEIF (ITUNE.EQ.104) THEN
59550C...pT0.
59551 PARP(82)=1.9409D0
59552C...Run II ref scale and slow scaling
59553 PARP(89)=1960D0
59554 PARP(90)=0.16D0
59555c...String drawing completely minimizes string length.
59556 PARP(85)=1.0D0
59557 PARP(86)=1.0D0
59558C...ISR cutoff, muR scale factor, and phase space size
59559 PARP(62)=1.25D0
59560 PARP(64)=0.2D0
59561 PARP(67)=2.5D0
59562C...Intrinsic kT, size, and max
59563 MSTP(91)=1
59564 PARP(91)=2.1D0
59565 PARP(93)=15D0
59566
59567C...Tune QW
59568 ELSEIF(ITUNE.EQ.105) THEN
59569 IF (M13.GE.1) THEN
59570 WRITE(M11,5030) ' '
59571 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
59572 & 'externally linked and'
59573 WRITE(M11,5035) CH70
59574 CH70='MSTP(51) should be set manually according to '//
59575 & 'the library used'
59576 WRITE(M11,5035) CH70
59577 ENDIF
59578C...pT0.
59579 PARP(82)=1.1D0
59580c...String drawing completely minimizes string length.
59581 PARP(85)=1.0D0
59582 PARP(86)=1.0D0
59583C...ISR cutoff, muR scale factor, and phase space size
59584 PARP(62)=1.25D0
59585 PARP(64)=0.2D0
59586 PARP(67)=2.5D0
59587C...Intrinsic kT, size, and max
59588 MSTP(91)=1
59589 PARP(91)=2.1D0
59590 PARP(93)=15D0
59591
59592C...Tune D6 and D6T
59593 ELSEIF(ITUNE.EQ.108.OR.ITUNE.EQ.109) THEN
59594 IF (M13.GE.1) THEN
59595 WRITE(M11,5030) ' '
59596 CH70='NB! This tune requires CTEQ6L pdfs to be '//
59597 & 'externally linked and'
59598 WRITE(M11,5035) CH70
59599 CH70='MSTP(51) should be set manually according to '//
59600 & 'the library used'
59601 WRITE(M11,5035) CH70
59602 ENDIF
59603C...The "Rick" proton, double gauss with 0.5/0.4
59604 MSTP(82)=4
59605 PARP(83)=0.5D0
59606 PARP(84)=0.4D0
59607c...String drawing completely minimizes string length.
59608 PARP(85)=1.0D0
59609 PARP(86)=1.0D0
59610 IF (ITUNE.EQ.108) THEN
59611C...D6: pT0, Run I ref scale, and fast energy scaling
59612 PARP(82)=1.8D0
59613 PARP(89)=1800D0
59614 PARP(90)=0.25D0
59615 ELSE
59616C...D6T: pT0, Run II ref scale, and slow energy scaling
59617 PARP(82)=1.8387D0
59618 PARP(89)=1960D0
59619 PARP(90)=0.16D0
59620 ENDIF
59621C...ISR cutoff, muR scale factor, and phase space size
59622 PARP(62)=1.25D0
59623 PARP(64)=0.2D0
59624 PARP(67)=2.5D0
59625C...Intrinsic kT, size, and max
59626 MSTP(91)=1
59627 PARP(91)=2.1D0
59628 PARP(93)=15D0
59629
59630C...Old ATLAS-DC2 5-parameter tune
59631 ELSEIF(ITUNE.EQ.106) THEN
59632 IF (M13.GE.1) THEN
59633 WRITE(M11,5010) ITUNE, CHNAME
59634 CH60='see A. Moraes et al., SN-ATLAS-2006-057'
59635 WRITE(M11,5030) CH60
59636 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59637 WRITE(M11,5030) CH60
59638 ENDIF
59639C... pT0.
59640 PARP(82)=1.8D0
59641C... Different ref and rescaling pacee
59642 PARP(89)=1000D0
59643 PARP(90)=0.16D0
59644C... Parameters of mass distribution
59645 PARP(83)=0.5D0
59646 PARP(84)=0.5D0
59647C... Old default string drawing
59648 PARP(85)=0.33D0
59649 PARP(86)=0.66D0
59650C... ISR, phase space equivalent to Tune B
59651 PARP(62)=1D0
59652 PARP(64)=1D0
59653 PARP(67)=1D0
59654C... FSR
59655 PARP(71)=4D0
59656 PARJ(81)=0.29D0
59657C... Intrinsic kT
59658 MSTP(91)=1
59659 PARP(91)=1D0
59660 PARP(93)=5D0
59661 ENDIF
59662
59663C... Output
59664 IF (M13.GE.1) THEN
59665 WRITE(M11,5030) ' '
59666 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59667 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59668 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59669 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59670 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59671 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59672 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59673 WRITE(M11,5030) CH60
59674 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59675 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59676 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59677 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59678 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59679 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59680 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59681 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59682 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59683 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59684 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59685 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59686 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59687 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59688 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59689 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59690 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59691 ENDIF
59692
59693C=============================================================================
59694C... ACR, tune A with new CR (107)
59695 ELSEIF(ITUNE.EQ.107) THEN
59696 IF (M13.GE.1) THEN
59697 WRITE(M11,5010) ITUNE, CHNAME
59698 CH60='Tune A modified with new colour reconnections'
59699 WRITE(M11,5030) CH60
59700 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
59701 WRITE(M11,5030) CH60
59702 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
59703 WRITE(M11,5030) CH60
59704 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59705 WRITE(M11,5030) CH60
59706 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59707 WRITE(M11,5030) CH60
59708 ENDIF
59709 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
59710 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59711 & ' with tune. Using defaults.')
59712 GOTO 9998
59713 ENDIF
59714 MSTP(81)=1
59715 PARP(89)=1800D0
59716 PARP(90)=0.25D0
59717 MSTP(82)=4
59718 PARP(83)=0.5D0
59719 PARP(84)=0.4D0
59720 MSTP(51)=7
59721 MSTP(52)=1
59722 PARP(71)=4D0
59723 PARJ(81)=0.29D0
59724 PARP(82)=2.0D0
59725 PARP(85)=0.0D0
59726 PARP(86)=0.66D0
59727 PARP(62)=1D0
59728 PARP(64)=1D0
59729 PARP(67)=4D0
59730 MSTP(91)=1
59731 PARP(91)=1D0
59732 PARP(93)=5D0
59733 MSTP(95)=6
59734 PARP(78)=0.25D0
59735C...Fragmentation functions and c and b parameters
59736 MSTJ(11)=4
59737 PARJ(54)=-0.05
59738 PARJ(55)=-0.005
59739C...Output
59740 IF (M13.GE.1) THEN
59741 WRITE(M11,5030) ' '
59742 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59743 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59744 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59745 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59746 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59747 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59748 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59749 WRITE(M11,5030) CH60
59750 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59751 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59752 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59753 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59754 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59755 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59756 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59757 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59758 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59759 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59760 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59761 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59762 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59763 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59764 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59765 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59766 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59767 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59768 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59769 ENDIF
59770
59771C=============================================================================
59772C... Intermediate model. Rap tune (retuned to post-6.406 IR factorization)
59773 ELSEIF(ITUNE.EQ.200) THEN
59774 IF (M13.GE.1) THEN
59775 WRITE(M11,5010) ITUNE, CHNAME
59776 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
59777 WRITE(M11,5030) CH60
59778 ENDIF
59779 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
59780 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59781 & ' with tune.')
59782 ENDIF
59783C...PDF
59784 MSTP(51)=7
59785 MSTP(52)=1
59786C...ISR
59787 PARP(62)=1D0
59788 PARP(64)=1D0
59789 PARP(67)=4D0
59790C...FSR
59791 PARP(71)=4D0
59792 PARJ(81)=0.29D0
59793C...UE
59794 MSTP(81)=11
59795 PARP(82)=2.25D0
59796 PARP(89)=1800D0
59797 PARP(90)=0.25D0
59798C... ExpOfPow(1.8) overlap profile
59799 MSTP(82)=5
59800 PARP(83)=1.8D0
59801C... Valence qq
59802 MSTP(88)=0
59803C... Rap Tune
59804 MSTP(89)=1
59805C... Default diquark, BR-g-BR supp
59806 PARP(79)=2D0
59807 PARP(80)=0.01D0
59808C... Final state reconnect.
59809 MSTP(95)=1
59810 PARP(78)=0.55D0
59811C...Fragmentation functions and c and b parameters
59812 MSTJ(11)=4
59813 PARJ(54)=-0.05
59814 PARJ(55)=-0.005
59815C... Output
59816 IF (M13.GE.1) THEN
59817 WRITE(M11,5030) ' '
59818 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59819 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59820 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59821 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59822 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59823 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59824 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59825 WRITE(M11,5030) CH60
59826 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59827 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59828 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59829 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59830 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59831 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59832 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59833 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59834 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
59835 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
59836 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
59837 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
59838 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59839 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
59840 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
59841 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59842 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59843 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59844 ENDIF
59845
59846C...APT. Tune A modified to use new pT-ordered FSR.
59847 ELSEIF(ITUNE.EQ.201) THEN
59848 IF (M13.GE.1) THEN
59849 WRITE(M11,5010) ITUNE, CHNAME
59850 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
59851 WRITE(M11,5030) CH60
59852 CH60='R.D. Field (CDF), in hep-ph/0610012 (Tune A)'
59853 WRITE(M11,5030) CH60
59854 CH60='T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59855 WRITE(M11,5030) CH60
59856 CH60='and T. Sjostrand & P. Skands, EPJC39(2005)129'
59857 WRITE(M11,5030) CH60
59858 ENDIF
59859 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
59860 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
59861 & ' with tune.')
59862 ENDIF
59863C...First set as if Pythia tune A
59864C...Multiple interactions on, old framework
59865 MSTP(81)=1
59866C...Fast IR cutoff energy scaling by default
59867 PARP(89)=1800D0
59868 PARP(90)=0.25D0
59869C...Default CTEQ5L (internal)
59870 MSTP(51)=7
59871 MSTP(52)=1
59872C...Double Gaussian matter distribution.
59873 MSTP(82)=4
59874 PARP(83)=0.5D0
59875 PARP(84)=0.4D0
59876C...FSR activity.
59877 PARP(71)=4D0
59878c...String drawing almost completely minimizes string length.
59879 PARP(85)=0.9D0
59880 PARP(86)=0.95D0
59881C...ISR cutoff, muR scale factor, and phase space size
59882 PARP(62)=1D0
59883 PARP(64)=1D0
59884 PARP(67)=4D0
59885C...Intrinsic kT, size, and max
59886 MSTP(91)=1
59887 PARP(91)=1D0
59888 PARP(93)=5D0
59889C...Use pT-ordered FSR
59890 MSTJ(41)=12
59891C...Lambda_FSR scale for pT-ordering
59892 PARJ(81)=0.23D0
59893C...Retune pT0
59894 PARP(82)=2.1D0
59895C...Fragmentation functions and c and b parameters
59896 MSTJ(11)=4
59897 PARJ(54)=-0.05
59898 PARJ(55)=-0.005
59899
59900C... Output
59901 IF (M13.GE.1) THEN
59902 WRITE(M11,5030) ' '
59903 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
59904 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
59905 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59906 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
59907 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
59908 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
59909 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
59910 WRITE(M11,5030) CH60
59911 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
59912 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
59913 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
59914 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59915 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59916 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
59917 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
59918 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59919 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59920 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59921 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
59922 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
59923 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
59924 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
59925 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
59926 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
59927 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
59928 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
59929 ENDIF
59930
59931C=============================================================================
59932C...Uppsala models: Generalized Area Law and Soft Colour Interactions
59933 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
59934 IF (M13.GE.1) THEN
59935 WRITE(M11,5010) ITUNE, CHNAME
59936 CH60='see J. Rathsman, PLB452(1999)364'
59937 WRITE(M11,5030) CH60
59938C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
59939C ? WRITE(M11,5030)
59940 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
59941 WRITE(M11,5030) CH60
59942 WRITE(M11,5030) ' '
59943 CH70='NB! The GAL model must be run with modified '//
59944 & 'Pythia v6.215:'
59945 WRITE(M11,5035) CH70
59946 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
59947 WRITE(M11,5035) CH70
59948 WRITE(M11,5030) ' '
59949 ENDIF
59950C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
59951 MSWI(2) = 3
59952 PARSCI(2) = 0.10
59953 MSWI(1) = 2
59954 PARSCI(1) = 0.44
59955 MSTJ(16) = 0
59956 PARJ(42) = 0.45
59957 PARJ(82) = 2.0
59958 PARP(62) = 2.0
59959 MSTP(81) = 1
59960 MSTP(82) = 1
59961 PARP(81) = 1.9
59962 MSTP(92) = 1
59963 IF(CHNAME.EQ.'GAL Tune 1') THEN
59964C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
59965 MSTP(82)=4
59966 PARP(83)=0.25D0
59967 PARP(84)=0.5D0
59968 PARP(82) = 1.75
59969 IF (M13.GE.1) THEN
59970 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59971 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
59972 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59973 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
59974 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
59975 ENDIF
59976 ELSE
59977 IF (M13.GE.1) THEN
59978 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
59979 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
59980 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
59981 ENDIF
59982 ENDIF
59983C...Output
59984 IF (M13.GE.1) THEN
59985 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
59986 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
59987 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
59988 CH40='FSI SCI/GAL selection'
59989 WRITE(M11,6040) 1, MSWI(1), CH40
59990 CH40='FSI SCI/GAL sea quark treatment'
59991 WRITE(M11,6040) 2, MSWI(2), CH40
59992 CH40='FSI SCI/GAL sea quark treatment parm'
59993 WRITE(M11,6050) 1, PARSCI(1), CH40
59994 CH40='FSI SCI/GAL string reco probability R_0'
59995 WRITE(M11,6050) 2, PARSCI(2), CH40
59996 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
59997 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
59998 ENDIF
59999 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
60000 IF (M13.GE.1) THEN
60001 WRITE(M11,5010) ITUNE, CHNAME
60002 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
60003 WRITE(M11,5030) CH60
60004 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
60005 WRITE(M11,5030) CH60
60006 WRITE(M11,5030) ' '
60007 CH70='NB! The SCI model must be run with modified '//
60008 & 'Pythia v6.215:'
60009 WRITE(M11,5035) CH70
60010 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
60011 WRITE(M11,5035) CH70
60012 WRITE(M11,5030) ' '
60013 ENDIF
60014C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
60015 MSTP(81)=1
60016 MSTP(82)=1
60017 PARP(81)=2.2
60018 MSTP(92)=1
60019 MSWI(2)=2
60020 PARSCI(2)=0.50
60021 MSWI(1)=2
60022 PARSCI(1)=0.44
60023 MSTJ(16)=0
60024 IF (CHNAME.EQ.'SCI Tune 1') THEN
60025C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
60026 MSTP(81) = 1
60027 MSTP(82) = 3
60028 PARP(82) = 2.4
60029 PARP(83) = 0.5D0
60030 PARP(62) = 1.5
60031 PARP(84)=0.25D0
60032 IF (M13.GE.1) THEN
60033 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60034 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
60035 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60036 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
60037 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
60038 ENDIF
60039 ELSE
60040 IF (M13.GE.1) THEN
60041 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
60042 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
60043 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
60044 ENDIF
60045 ENDIF
60046C...Output
60047 IF (M13.GE.1) THEN
60048 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
60049 CH40='FSI SCI/GAL selection'
60050 WRITE(M11,6040) 1, MSWI(1), CH40
60051 CH40='FSI SCI/GAL sea quark treatment'
60052 WRITE(M11,6040) 2, MSWI(2), CH40
60053 CH40='FSI SCI/GAL sea quark treatment parm'
60054 WRITE(M11,6050) 1, PARSCI(1), CH40
60055 CH40='FSI SCI/GAL string reco probability R_0'
60056 WRITE(M11,6050) 2, PARSCI(2), CH40
60057 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
60058 ENDIF
60059
60060 ELSE
60061 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
60062
60063 ENDIF
60064
60065 9998 IF (MSTU(13).GE.1) WRITE(M11,6000)
60066
60067 9999 RETURN
60068
60069 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
60070 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
60071 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
60072 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
60073 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
60074 5030 FORMAT(' *',3x,10x,A60,3x,'*')
60075 5035 FORMAT(' *',3x,A70,3x,'*')
60076 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
60077 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
60078 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
60079 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
60080 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
60081 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
60082 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
60083 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
60084 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
60085
60086 END
60087
60088C*********************************************************************
60089
60090C...PYEXEC
60091C...Administrates the fragmentation and decay chain.
60092
60093 SUBROUTINE PYEXEC
60094
60095C...Double precision and integer declarations.
60096 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60097 IMPLICIT INTEGER(I-N)
60098 INTEGER PYK,PYCHGE,PYCOMP
60099C...Commonblocks.
60100 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60101 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60102 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60103 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60104 COMMON/PYINT1/MINT(400),VINT(400)
60105 COMMON/PYINT4/MWID(500),WIDS(500,5)
60106 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
60107C...Local array.
60108 DIMENSION PS(2,6),IJOIN(100)
60109
60110C...Initialize and reset.
60111 MSTU(24)=0
60112 IF(MSTU(12).NE.12345) CALL PYLIST(0)
60113 MSTU(29)=0
60114 MSTU(31)=MSTU(31)+1
60115 MSTU(1)=0
60116 MSTU(2)=0
60117 MSTU(3)=0
60118 IF(MSTU(17).LE.0) MSTU(90)=0
60119 MCONS=1
60120
60121C...Sum up momentum, energy and charge for starting entries.
60122 NSAV=N
60123 DO 110 I=1,2
60124 DO 100 J=1,6
60125 PS(I,J)=0D0
60126 100 CONTINUE
60127 110 CONTINUE
60128 DO 130 I=1,N
60129 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
60130 DO 120 J=1,4
60131 PS(1,J)=PS(1,J)+P(I,J)
60132 120 CONTINUE
60133 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
60134 130 CONTINUE
60135 PARU(21)=PS(1,4)
60136
60137C...Start by all decays of coloured resonances involved in shower.
60138 NORIG=N
60139 DO 140 I=1,NORIG
60140 IF(K(I,1).EQ.3) THEN
60141 KC=PYCOMP(K(I,2))
60142 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
60143 ENDIF
60144 140 CONTINUE
60145
60146C...Prepare system for subsequent fragmentation/decay.
60147 CALL PYPREP(0)
60148 IF(MINT(51).NE.0) RETURN
60149
60150C...Loop through jet fragmentation and particle decays.
60151 MBE=0
60152 150 MBE=MBE+1
60153 IP=0
60154 160 IP=IP+1
60155 KC=0
60156 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
60157 IF(KC.EQ.0) THEN
60158
60159C...Deal with any remaining undecayed resonance
60160C...(normally the task of PYEVNT, so seldom used).
60161 ELSEIF(MWID(KC).NE.0) THEN
60162 IBEG=IP
60163 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
60164 IBEG=IP+1
60165 170 IBEG=IBEG-1
60166 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
60167 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
60168 IEND=IP-1
60169 180 IEND=IEND+1
60170 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
60171 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
60172 NJOIN=0
60173 DO 190 I=IBEG,IEND
60174 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
60175 NJOIN=NJOIN+1
60176 IJOIN(NJOIN)=I
60177 ENDIF
60178 190 CONTINUE
60179 ENDIF
60180 CALL PYRESD(IP)
60181 CALL PYPREP(IBEG)
60182 IF(MINT(51).NE.0) RETURN
60183
60184C...Particle decay if unstable and allowed. Save long-lived particle
60185C...decays until second pass after Bose-Einstein effects.
60186 ELSEIF(KCHG(KC,2).EQ.0) THEN
60187 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
60188 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
60189 & CALL PYDECY(IP)
60190
60191C...Decay products may develop a shower.
60192 IF(MSTJ(92).GT.0) THEN
60193 IP1=MSTJ(92)
60194 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
60195 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
60196 MINT(33)=0
60197 CALL PYSHOW(IP1,IP1+1,QMAX)
60198 CALL PYPREP(IP1)
60199 IF(MINT(51).NE.0) RETURN
60200 MSTJ(92)=0
60201 ELSEIF(MSTJ(92).LT.0) THEN
60202 IP1=-MSTJ(92)
60203 MINT(33)=0
60204 CALL PYSHOW(IP1,-3,P(IP,5))
60205 CALL PYPREP(IP1)
60206 IF(MINT(51).NE.0) RETURN
60207 MSTJ(92)=0
60208 ENDIF
60209
60210C...Jet fragmentation: string or independent fragmentation.
60211 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
60212 MFRAG=MSTJ(1)
60213 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
60214 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
60215 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
60216 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
60217 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
60218 ENDIF
60219 ENDIF
60220 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
60221 IF(MFRAG.EQ.2) CALL PYINDF(IP)
60222 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
60223 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
60224 ENDIF
60225
60226C...Loop back if enough space left in PYJETS and no error abort.
60227 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
60228 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
60229 GOTO 160
60230 ELSEIF(IP.LT.N) THEN
60231 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
60232 ENDIF
60233
60234C...Include simple Bose-Einstein effect parametrization if desired.
60235 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
60236 CALL PYBOEI(NSAV)
60237 GOTO 150
60238 ENDIF
60239
60240C...Check that momentum, energy and charge were conserved.
60241 DO 210 I=1,N
60242 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
60243 DO 200 J=1,4
60244 PS(2,J)=PS(2,J)+P(I,J)
60245 200 CONTINUE
60246 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
60247 210 CONTINUE
60248 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
60249 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
60250 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
60251 &'(PYEXEC:) four-momentum was not conserved')
60252 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
60253 &'(PYEXEC:) charge was not conserved')
60254
60255 RETURN
60256 END
60257
60258C*********************************************************************
60259
60260C...PYPREP
60261C...Rearranges partons along strings.
60262C...Special considerations for systems with junctions, with
60263C...possibility of junction-antijunction annihilation.
60264C...Allows small systems to collapse into one or two particles.
60265C...Checks flavours and colour singlet invariant masses.
60266
60267 SUBROUTINE PYPREP(IP)
60268
60269C...Double precision and integer declarations.
60270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60271 INTEGER PYK,PYCHGE,PYCOMP
60272C...Commonblocks.
60273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60275 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60276 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60277 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60278 COMMON/PYINT1/MINT(400),VINT(400)
60279C...The common block of colour tags.
60280 COMMON/PYCTAG/NCT,MCT(4000,2)
60281 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
60282 &/PYPARS/
60283 DATA NERRPR/0/
60284 SAVE NERRPR
60285C...Local arrays.
60286 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
60287 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
60288 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
60289 &IJCP(0:6),TJUOLD(5)
60290 CHARACTER CHTMP*6
60291
60292C...Function to give four-product.
60293 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)
60294
60295C...Rearrange parton shower product listing along strings: begin loop.
60296 MSTU(24)=0
60297 NOLD=N
60298 I1=N
60299 NJUNC=0
60300 NPIECE=0
60301 NJJSTR=0
60302 MSTU32=MSTU(32)+1
60303 DO 100 I=MAX(1,IP),N
60304C...First store junction positions.
60305 IF(K(I,1).EQ.42) THEN
60306 NJUNC=NJUNC+1
60307 IJUNC(NJUNC,0)=I
60308 IJUNC(NJUNC,4)=0
60309 ENDIF
60310 100 CONTINUE
60311
60312 DO 250 MQGST=1,3
60313 DO 240 I=MAX(1,IP),N
60314C...Special treatment for junctions
60315 IF (K(I,1).LE.0) GOTO 240
60316 IF(K(I,1).EQ.42) THEN
60317C...MQGST=2: Look for junction-junction strings (not detected in the
60318C...main search below).
60319 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
60320 IF (NJJSTR.EQ.0) THEN
60321 NJJSTR = (3*NJUNC-NPIECE)/2
60322 ENDIF
60323C...Check how many already identified strings end on this junction
60324 ILC=0
60325 DO 110 J=1,NPIECE
60326 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
60327 110 CONTINUE
60328C...If less than 3, remaining must be to another junction
60329 IF (ILC.LT.3) THEN
60330 IF (ILC.NE.2) THEN
60331C...Multiple j-j connections not handled yet.
60332 CALL PYERRM(2,
60333 & '(PYPREP:) Too many junction-junction strings.')
60334 MINT(51)=1
60335 RETURN
60336 ENDIF
60337C...The colour information in the junction is unreadable for the
60338C...colour space search further down in this routine, so we must
60339C...start on the colour mother of this junction and then "artificially"
60340C...prevent the colour mother from connecting here again.
60341 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
60342 KCS=4
60343 IF (MOD(ITJUNC,2).EQ.0) KCS=5
60344C...Switch colour if the junction-junction leg is presumably a
60345C...junction mother leg rather than a junction daughter leg.
60346 IF (ITJUNC.GE.3) KCS=9-KCS
60347 IF (MINT(33).EQ.0) THEN
60348C...Find the unconnected leg and reorder junction daughter pointers so
60349C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
60350C...piece.
60351 IA=MOD(K(I,4),MSTU(5))
60352 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
60353 ITMP=MOD(K(I,5),MSTU(5))
60354 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
60355 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
60356 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
60357 ELSE
60358 K(I,5)=K(I,5)+(IA-ITMP)
60359 ENDIF
60360 K(I,4)=K(I,4)+(ITMP-IA)
60361 IA=ITMP
60362 ENDIF
60363 IF (ITJUNC.LE.2) THEN
60364C...Beam baryon junction
60365 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
60366 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
60367C...Else 1 -> 2 decay junction
60368 ELSE
60369 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
60370 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
60371 ENDIF
60372 I1BEG = I1
60373 NSTP = 0
60374 GOTO 170
60375C...Alternatively use colour tag information.
60376 ELSE
60377C...Find a final state parton with appropriate dangling colour tag.
60378 JCT=0
60379 IA=0
60380 IJUMO=K(I,3)
60381 DO 140 J1=MAX(1,IP),N
60382 IF (K(J1,1).NE.3) GOTO 140
60383C...Check for matching final-state colour tag
60384 IMATCH=0
60385 DO 120 J2=MAX(1,IP),N
60386 IF (K(J2,1).NE.3) GOTO 120
60387 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
60388 120 CONTINUE
60389 IF (IMATCH.EQ.1) GOTO 140
60390C...Check whether this colour tag belongs to the present junction
60391C...by seeing whether any parton with this colour tag has the same
60392C...mother as the junction.
60393 JCT=MCT(J1,KCS-3)
60394 IMATCH=0
60395 DO 130 J2=MINT(84)+1,N
60396 IMO2=K(J2,3)
60397C...First scattering partons have IMO1 = 3 and 4.
60398 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
60399 & IMO2=IMO2-2
60400 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
60401 & IMATCH=1
60402 130 CONTINUE
60403 IF (IMATCH.EQ.0) GOTO 140
60404 IA=J1
60405 140 CONTINUE
60406C...Check for junction-junction strings without intermediate final state
60407C...glue (not detected above).
60408 IF (IA.EQ.0) THEN
60409 DO 160 MJU=1,NJUNC
60410 IJU2=IJUNC(MJU,0)
60411 IF (IJU2.EQ.I) GOTO 160
60412 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
60413C...Only opposite types of junctions can connect to each other.
60414 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
60415 IS=0
60416 DO 150 J=1,NPIECE
60417 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
60418 150 CONTINUE
60419 IF (IS.EQ.3) GOTO 160
60420 IB=I
60421 IA=IJU2
60422 160 CONTINUE
60423 ENDIF
60424C...Switch to other side of adjacent parton and step from there.
60425 KCS=9-KCS
60426 I1BEG = I1
60427 NSTP = 0
60428 GOTO 170
60429 ENDIF
60430 ELSE IF (ILC.NE.3) THEN
60431 ENDIF
60432 ENDIF
60433 ENDIF
60434
60435C...Look for coloured string endpoint, or (later) leftover gluon.
60436 IF(K(I,1).NE.3) GOTO 240
60437 KC=PYCOMP(K(I,2))
60438 IF(KC.EQ.0) GOTO 240
60439 KQ=KCHG(KC,2)
60440 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
60441
60442C...Pick up loose string end.
60443 KCS=4
60444 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
60445 IA=I
60446 IB=I
60447 I1BEG=I1
60448 NSTP=0
60449 170 NSTP=NSTP+1
60450 IF(NSTP.GT.4*N) THEN
60451 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
60452 MINT(51)=1
60453 RETURN
60454 ENDIF
60455
60456C...Copy undecayed parton. Finished if reached string endpoint.
60457 IF(K(IA,1).EQ.3) THEN
60458 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
60459 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60460 MINT(51)=1
60461 MSTU(24)=1
60462 RETURN
60463 ENDIF
60464 I1=I1+1
60465 K(I1,1)=2
60466 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
60467 K(I1,2)=K(IA,2)
60468 K(I1,3)=IA
60469 K(I1,4)=0
60470 K(I1,5)=0
60471 DO 180 J=1,5
60472 P(I1,J)=P(IA,J)
60473 V(I1,J)=V(IA,J)
60474 180 CONTINUE
60475 K(IA,1)=K(IA,1)+10
60476 IF(K(I1,1).EQ.1) GOTO 240
60477 ENDIF
60478
60479C...Also finished (for now) if reached junction; then copy to end.
60480 IF(K(IA,1).EQ.42) THEN
60481 NCOPY=I1-I1BEG
60482 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
60483 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
60484 MINT(51)=1
60485 MSTU(24)=1
60486 RETURN
60487 ENDIF
60488 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
60489 DO 200 ICOPY=1,NCOPY
60490 DO 190 J=1,5
60491 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
60492 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
60493 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
60494 190 CONTINUE
60495 200 CONTINUE
60496 ENDIF
60497C...For junction-junction strings, find end leg and reorder junction
60498C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
60499C...junction-junction string piece.
60500 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
60501 ITMP=MOD(K(IA,4),MSTU(5))
60502 IF (ITMP.NE.IB) THEN
60503 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
60504 K(IA,5)=K(IA,5)+(ITMP-IB)
60505 ELSE
60506 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
60507 ENDIF
60508 K(IA,4)=K(IA,4)+(IB-ITMP)
60509 ENDIF
60510 ENDIF
60511 NPIECE=NPIECE+1
60512C...IPIECE:
60513C...0: endpoint in original ER
60514C...1:
60515C...2:
60516C...3: Parton immediately next to junction
60517C...4: Junction
60518 IPIECE(NPIECE,0)=I
60519 IPIECE(NPIECE,1)=MSTU32+1
60520 IPIECE(NPIECE,2)=MSTU32+NCOPY
60521 IPIECE(NPIECE,3)=IB
60522 IPIECE(NPIECE,4)=IA
60523 MSTU32=MSTU32+NCOPY
60524 I1=I1BEG
60525 GOTO 240
60526 ENDIF
60527
60528C...GOTO next parton in colour space.
60529 IB=IA
60530 IF (MINT(33).EQ.0) THEN
60531 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
60532 & )).NE.0) THEN
60533 IA=MOD(K(IB,KCS),MSTU(5))
60534 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
60535 MREV=0
60536 ELSE
60537 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
60538 & MSTU(5)).EQ.0) KCS=9-KCS
60539 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
60540 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
60541 MREV=1
60542 ENDIF
60543 IF(IA.LE.0.OR.IA.GT.N) THEN
60544 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
60545 IF(NERRPR.LT.5) THEN
60546 NERRPR=NERRPR+1
60547 WRITE(MSTU(11),*) 'started at:', I
60548 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
60549 WRITE(MSTU(11),*) 'MQGST =',MQGST
60550 CALL PYLIST(4)
60551 ENDIF
60552 MINT(51)=1
60553 RETURN
60554 ENDIF
60555 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
60556 & ,MSTU(5)).EQ.IB) THEN
60557 IF(MREV.EQ.1) KCS=9-KCS
60558 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
60559 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
60560 ELSE
60561 IF(MREV.EQ.0) KCS=9-KCS
60562 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
60563 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
60564 ENDIF
60565 IF(IA.NE.I) GOTO 170
60566C...Use colour tag information
60567 ELSE
60568C...First create colour tags starting on IB if none already present.
60569 IF (MCT(IB,KCS-3).EQ.0) THEN
60570 CALL PYCTTR(IB,KCS,IB)
60571 IF(MINT(51).NE.0) RETURN
60572 ENDIF
60573 JCT=MCT(IB,KCS-3)
60574 IFOUND=0
60575C...Find final state tag partner
60576 DO 210 IT=MAX(1,IP),N
60577 IF (IT.EQ.IB) GOTO 210
60578 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
60579 & .0) THEN
60580 IFOUND=IFOUND+1
60581 IA=IT
60582 ENDIF
60583 210 CONTINUE
60584C...Just copy and goto next if exactly one partner found.
60585 IF (IFOUND.EQ.1) THEN
60586 GOTO 170
60587C...When no match found, match is presumably junction.
60588 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
60589C...Check whether this colour tag matches a junction
60590C...by seeing whether any parton with this colour tag has the same
60591C...mother as a junction.
60592C...NB: Only type 1 and 2 junctions handled presently.
60593 DO 230 IJU=1,NJUNC
60594 IJUMO=K(IJUNC(IJU,0),3)
60595 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
60596C...Colours only connect to junctions, anti-colours to antijunctions:
60597 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
60598 IMATCH=0
60599 DO 220 J1=MAX(1,IP),N
60600 IF (K(J1,1).LE.0) GOTO 220
60601C...First scattering partons have IMO1 = 3 and 4.
60602 IMO=K(J1,3)
60603 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
60604 & IMO=IMO-2
60605 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
60606 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
60607 & IMATCH=1
60608C...Attempt at handling type > 3 junctions also. Not tested.
60609 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
60610 & .IJUMO) IMATCH=1
60611 220 CONTINUE
60612 IF (IMATCH.EQ.0) GOTO 230
60613 IA=IJUNC(IJU,0)
60614 IFOUND=IFOUND+1
60615 230 CONTINUE
60616
60617 IF (IFOUND.EQ.1) THEN
60618 GOTO 170
60619 ELSEIF (IFOUND.EQ.0) THEN
60620 WRITE(CHTMP,*) JCT
60621 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
60622 & //CHTMP)
60623 IF(NERRPR.LT.5) THEN
60624 NERRPR=NERRPR+1
60625 CALL PYLIST(4)
60626 ENDIF
60627 MINT(51)=1
60628 RETURN
60629 ENDIF
60630 ELSEIF (IFOUND.GE.2) THEN
60631 WRITE(CHTMP,*) JCT
60632 CALL PYERRM(12
60633 & ,'(PYPREP:) too many occurences of colour line: '//
60634 & CHTMP)
60635 IF(NERRPR.LT.5) THEN
60636 NERRPR=NERRPR+1
60637 CALL PYLIST(4)
60638 ENDIF
60639 MINT(51)=1
60640 RETURN
60641 ENDIF
60642 ENDIF
60643 K(I1,1)=1
60644 240 CONTINUE
60645 250 CONTINUE
60646
60647C...Junction systems remain.
60648 IJU=0
60649 IJUS=0
60650 IJUCNT=0
60651 MREV=0
60652 IJJSTR=0
60653 260 IJUCNT=IJUCNT+1
60654 IF (IJUCNT.LE.NJUNC) THEN
60655C...If we are not processing a j-j string, treat this junction as new.
60656 IF (IJJSTR.EQ.0) THEN
60657 IJU=IJUNC(IJUCNT,0)
60658 MREV=0
60659C...If junction has already been read, ignore it.
60660 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
60661C...If we are on a j-j string, goto second j-j junction.
60662 ELSE
60663 IJUCNT=IJUCNT-1
60664 IJU=IJUS
60665 ENDIF
60666C...Mark selected junction read.
60667 DO 270 J=1,NJUNC
60668 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
60669 270 CONTINUE
60670C...Determine junction type
60671 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
60672C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
60673C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
60674C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
60675 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
60676 IHK=0
60677 280 IHK=IHK+1
60678C...Find which quarks belong to given junction.
60679 IHF=0
60680 DO 290 IPC=1,NPIECE
60681 IF (IPIECE(IPC,4).EQ.IJU) THEN
60682 IHF=IHF+1
60683 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
60684 ENDIF
60685 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
60686 290 CONTINUE
60687C...IHK = 3 is special. Either normal string piece, or j-j string.
60688 IF(IHK.EQ.3) THEN
60689 IF (MREV.NE.1) THEN
60690 DO 300 IPC=1,NPIECE
60691C...If there is a j-j string starting on the present junction which has
60692C...zero length, insert next junction immediately.
60693 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
60694 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
60695 IJJSTR = 1
60696 GOTO 340
60697 ENDIF
60698 300 CONTINUE
60699 MREV = 1
60700C...If MREV is 1 and IHK is 3 we are finished with this system.
60701 ELSE
60702 MREV=0
60703 GOTO 260
60704 ENDIF
60705 ENDIF
60706
60707C...If we've gotten this far, then either IHK < 3, or
60708C...an interjunction string exists, or just a third normal string.
60709 IJUNC(IJUCNT,IHK)=0
60710 IJJSTR = 0
60711C..Order pieces belonging to this junction. Also look for j-j.
60712 DO 310 IPC=1,NPIECE
60713 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
60714 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
60715 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
60716 IJUNC(IJUCNT,IHK)=IPC
60717 IJJSTR = 1
60718 MREV = 0
60719 ENDIF
60720 310 CONTINUE
60721C...Copy back chains in proper order. MREV=0/1 : descending/ascending
60722 IPC=IJUNC(IJUCNT,IHK)
60723C...Temporary solution to cover for bug.
60724 IF(IPC.LE.0) THEN
60725 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
60726 MINT(51)=1
60727 RETURN
60728 ENDIF
60729 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
60730 I1=I1+1
60731 DO 320 J=1,5
60732 K(I1,J)=K(MSTU(4)-ICP,J)
60733 P(I1,J)=P(MSTU(4)-ICP,J)
60734 V(I1,J)=V(MSTU(4)-ICP,J)
60735 320 CONTINUE
60736 330 CONTINUE
60737 K(I1,1)=2
60738C...Mark last quark.
60739 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
60740C...Do not insert junctions at wrong places.
60741 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
60742C...Insert junction.
60743 340 IJUS = IJU
60744 IF (IHK.EQ.3) THEN
60745C...Shift to end junction if a j-j string has been processed.
60746 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
60747 MREV= 1
60748 ENDIF
60749 I1=I1+1
60750 DO 350 J=1,5
60751 K(I1,J)=0
60752 P(I1,J)=0.
60753 V(I1,J)=0.
60754 350 CONTINUE
60755 K(I1,1)=41
60756 K(IJUS,1)=K(IJUS,1)+10
60757 K(I1,2)=K(IJUS,2)
60758 K(I1,3)=IJUS
60759 360 IF (IHK.LT.3) GOTO 280
60760 ELSE
60761 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
60762 MINT(51)=1
60763 RETURN
60764 ENDIF
60765 IF (IJUCNT.NE.NJUNC) GOTO 260
60766 ENDIF
60767 N=I1
60768
60769C...Rearrange three strings from junction, e.g. in case one has been
60770C...shortened by shower, so the last is the largest-energy one.
60771 IF(NJUNC.GE.1) THEN
60772C...Find systems with exactly one junction.
60773 MJUN1=0
60774 NBEG=NOLD+1
60775 DO 470 I=NOLD+1,N
60776 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
60777 ELSEIF(K(I,1).EQ.41) THEN
60778 MJUN1=MJUN1+1
60779 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
60780 MJUN1=0
60781 NBEG=I+1
60782 ELSE
60783 NEND=I
60784C...Sum up energy-momentum in each junction string.
60785 DO 370 J=1,5
60786 PJU(1,J)=0D0
60787 PJU(2,J)=0D0
60788 PJU(3,J)=0D0
60789 370 CONTINUE
60790 NJU=0
60791 DO 390 I1=NBEG,NEND
60792 IF(K(I1,2).NE.21) THEN
60793 NJU=NJU+1
60794 IJUR(NJU)=I1
60795 ENDIF
60796 DO 380 J=1,5
60797 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
60798 380 CONTINUE
60799 390 CONTINUE
60800C...Find which of them has highest energy (minus mass) in rest frame.
60801 DO 400 J=1,5
60802 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
60803 400 CONTINUE
60804 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
60805 & PJU(4,3)**2))
60806 DO 410 I2=1,3
60807 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
60808 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
60809 410 CONTINUE
60810 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
60811C...Decide how to rearrange so that new last has highest energy.
60812 IF(PJU(1,6).LT.PJU(2,6)) THEN
60813 IRNG(1,1)=IJUR(1)
60814 IRNG(1,2)=IJUR(2)-1
60815 IRNG(2,1)=IJUR(4)
60816 IRNG(2,2)=IJUR(3)+1
60817 IRNG(4,1)=IJUR(3)-1
60818 IRNG(4,2)=IJUR(2)
60819 ELSE
60820 IRNG(1,1)=IJUR(4)
60821 IRNG(1,2)=IJUR(3)+1
60822 IRNG(2,1)=IJUR(2)
60823 IRNG(2,2)=IJUR(3)-1
60824 IRNG(4,1)=IJUR(2)-1
60825 IRNG(4,2)=IJUR(1)
60826 ENDIF
60827 IRNG(3,1)=IJUR(3)
60828 IRNG(3,2)=IJUR(3)
60829C...Copy in correct order below bottom of current event record.
60830 I2=N
60831 DO 440 II=1,4
60832 DO 430 I1=IRNG(II,1),IRNG(II,2),
60833 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
60834 I2=I2+1
60835 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
60836 CALL PYERRM(11,
60837 & '(PYPREP:) no more memory left in PYJETS')
60838 MINT(51)=1
60839 MSTU(24)=1
60840 RETURN
60841 ENDIF
60842 DO 420 J=1,5
60843 K(I2,J)=K(I1,J)
60844 P(I2,J)=P(I1,J)
60845 V(I2,J)=V(I1,J)
60846 420 CONTINUE
60847 IF(K(I2,1).EQ.1) K(I2,1)=2
60848 430 CONTINUE
60849 440 CONTINUE
60850 K(I2,1)=1
60851C...Copy back up, overwriting but now in correct order.
60852 DO 460 I1=NBEG,NEND
60853 I2=I1-NBEG+N+1
60854 DO 450 J=1,5
60855 K(I1,J)=K(I2,J)
60856 P(I1,J)=P(I2,J)
60857 V(I1,J)=V(I2,J)
60858 450 CONTINUE
60859 460 CONTINUE
60860 ENDIF
60861 MJUN1=0
60862 NBEG=I+1
60863 ENDIF
60864 470 CONTINUE
60865
60866C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
60867C...to two q-qbar systems.
60868C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
60869 IF (MSTJ(19).NE.1) THEN
60870 MJUN1 = 0
60871 JJGLUE = 0
60872 NBEG = NOLD+1
60873C...Force collapse when MSTJ(19)=2.
60874 IF (MSTJ(19).EQ.2) THEN
60875 DELMJJ = 1D9
60876 DELMQQ = 0D0
60877 ENDIF
60878C...Find systems with exactly two junctions.
60879 DO 700 I=NOLD+1,N
60880C...Count junctions
60881 IF (K(I,1).EQ.41) THEN
60882 MJUN1 = MJUN1+1
60883C...Check for interjunction gluons
60884 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
60885 JJGLUE = 1
60886 ENDIF
60887 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
60888C...If end of system reached with either zero or one junction, restart
60889C...with next system.
60890 MJUN1 = 0
60891 JJGLUE = 0
60892 NBEG = I+1
60893 ELSEIF(K(I,1).EQ.1) THEN
60894C...If end of system reached with exactly two junctions, compute string
60895C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
60896C...length measure for the (q-qbar)(q-qbar) topology.
60897 NEND=I
60898C...Loop down through chain.
60899 ISID=0
60900 DO 480 I1=NBEG,NEND
60901C...Store string piece division locations in event record
60902 IF (K(I1,2).NE.21) THEN
60903 ISID = ISID+1
60904 IJCP(ISID) = I1
60905 ENDIF
60906 480 CONTINUE
60907C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
60908 ISW=0
60909 IF (PYR(0).LT.0.5D0) ISW=1
60910C...Randomly choose which qqbar string gets the jj gluons.
60911 IGS=1
60912 IF (PYR(0).GT.0.5D0) IGS=2
60913C...Only compute string lengths when no topology forced.
60914 IF (MSTJ(19).EQ.0) THEN
60915C...Repeat following for each junction
60916 DO 570 IJU=1,2
60917C...Initialize iterative procedure for finding JRF
60918 IJRFIT=0
60919 DO 490 IX=1,3
60920 TJUOLD(IX)=0D0
60921 490 CONTINUE
60922 TJUOLD(4)=1D0
60923C...Start iteration. Sum up momenta in string pieces
60924 500 DO 540 IJS=1,3
60925C...JD=-1 for first junction, +1 for second junction.
60926C...Find out where piece starts and ends and which direction to go.
60927 JD=2*IJU-3
60928 IF (IJS.LE.2) THEN
60929 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
60930 IB = IJCP((IJU-1)*7 - JD*IJS)
60931 ELSEIF (IJS.EQ.3) THEN
60932 JD =-JD
60933 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
60934 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
60935 ENDIF
60936C...Initialize junction pull 4-vector.
60937 DO 510 J=1,5
60938 PUL(IJS,J)=0D0
60939 510 CONTINUE
60940C...Initialize weight
60941 PWT = 0D0
60942 PWTOLD = 0D0
60943C...Sum up (weighted) momenta along each string piece
60944 DO 530 ISP=IA,IB,JD
60945C...If present parton not last in chain
60946 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
60947C...If last parton was a junction, store present weight
60948 IF (K(ISP-JD,2).EQ.88) THEN
60949 PWTOLD = PWT
60950C...If last parton was a quark, reset to stored weight.
60951 ELSEIF (K(ISP-JD,2).NE.21) THEN
60952 PWT = PWTOLD
60953 ENDIF
60954 ENDIF
60955C...Skip next parton if weight already large
60956 IF (PWT.GT.10D0) GOTO 530
60957C...Compute momentum in TJUOLD frame:
60958 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
60959 & )*P(ISP,3)
60960 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
60961 DO 520 J=1,3
60962 TMP=P(ISP,J)+TJUOLD(J)*BFC
60963 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
60964 520 CONTINUE
60965C...Boosted energy
60966 TMP=TJUOLD(4)*P(ISP,4)+TDP
60967 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
60968C...Update weight
60969 PWT=PWT+TMP/PARJ(48)
60970C...Put |p| rather than m in 5th slot
60971 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
60972 & +PUL(IJS,3)**2)
60973 530 CONTINUE
60974 540 CONTINUE
60975C...Compute boost
60976 IJRFIT=IJRFIT+1
60977 CALL PYJURF(PUL,T)
60978C...Combine new boost (T) with old boost (TJUOLD)
60979 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
60980 DO 550 IX=1,3
60981 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
60982 & ))
60983 550 CONTINUE
60984 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
60985 & **2)
60986C...If last boost small, accept JRF, else iterate.
60987C...Also prevent possibility of infinite loop.
60988 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
60989 & IJRFIT.LT.MSTJ(18))THEN
60990 GOTO 500
60991 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
60992 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
60993 ENDIF
60994C...Store final boost, with change of sign since TJJ motion vector.
60995 DO 560 IX=1,3
60996 TJJ(IJU,IX)=-TJUOLD(IX)
60997 560 CONTINUE
60998 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
60999 & +TJJ(IJU,3)**2)
61000 570 CONTINUE
61001C...String length measure for (q-qbar)(q-qbar) topology.
61002C...Note only momenta of nearest partons used (since rest of system
61003C...identical).
61004 IF (JJGLUE.EQ.0) THEN
61005 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
61006 & -1,IJCP(5-ISW)+1)
61007 ELSE
61008C...Put jj gluons on selected string (IGS selected randomly above).
61009 IF (IGS.EQ.1) THEN
61010 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61011 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
61012 ELSE
61013 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
61014 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
61015 & ,IJCP(5-ISW)+1)
61016 ENDIF
61017 ENDIF
61018C...String length measure for q-q-j-j-q-q topology.
61019 T1G1=0D0
61020 T2G2=0D0
61021 T1T2=0D0
61022 T1P1=0D0
61023 T1P2=0D0
61024 T2P3=0D0
61025 T2P4=0D0
61026 ISGN=-1
61027C...Note only momenta of nearest partons used (since rest of system
61028C...identical).
61029 DO 580 IX=1,4
61030 IF (IX.EQ.4) ISGN=1
61031 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
61032 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
61033 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
61034 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
61035 IF (JJGLUE.EQ.0) THEN
61036C...Junction motion vector dot product gives length when inter-junction
61037C...gluons absent.
61038 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
61039 ELSE
61040C...Junction motion vector dot products with gluon momenta give length
61041C...when inter-junction gluons present.
61042 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
61043 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
61044 ENDIF
61045 580 CONTINUE
61046 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
61047 IF (JJGLUE.EQ.0) THEN
61048 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
61049 ELSE
61050 DELMJJ=DELMJJ*4D0*T1G1*T2G2
61051 ENDIF
61052 ENDIF
61053C...If delmjj > delmqq collapse string system to q-qbar q-qbar
61054C...(Always the case for MSTJ(19)=2 due to initialization above)
61055 IF (DELMJJ.GT.DELMQQ) THEN
61056C...Put new system at end of event record
61057 NCOP=N
61058 DO 650 IST=1,2
61059 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
61060 NCOP=NCOP+1
61061 DO 590 IX=1,5
61062 P(NCOP,IX)=P(ICOP,IX)
61063 K(NCOP,IX)=K(ICOP,IX)
61064 590 CONTINUE
61065 600 CONTINUE
61066 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
61067C...Insert inter-junction gluon string piece (reversed)
61068 NJJGL=0
61069 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
61070 NJJGL=NJJGL+1
61071 NCOP=NCOP+1
61072 DO 610 IX=1,5
61073 P(NCOP,IX)=P(ICOP,IX)
61074 K(NCOP,IX)=K(ICOP,IX)
61075 610 CONTINUE
61076 620 CONTINUE
61077 ENDIF
61078 IFC=-2*IST+3
61079 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
61080 NCOP=NCOP+1
61081 DO 630 IX=1,5
61082 P(NCOP,IX)=P(ICOP,IX)
61083 K(NCOP,IX)=K(ICOP,IX)
61084 630 CONTINUE
61085 640 CONTINUE
61086 K(NCOP,1)=1
61087 650 CONTINUE
61088C...Copy system back in right order
61089 DO 670 ICOP=NBEG,NEND-2
61090 DO 660 IX=1,5
61091 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
61092 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
61093 660 CONTINUE
61094 670 CONTINUE
61095C...Shift down rest of event record
61096 DO 690 ICOP=NEND+1,N
61097 DO 680 IX=1,5
61098 P(ICOP-2,IX)=P(ICOP,IX)
61099 K(ICOP-2,IX)=K(ICOP,IX)
61100 680 CONTINUE
61101 690 CONTINUE
61102C...Update length of event record.
61103 N=N-2
61104 ENDIF
61105 MJUN1=0
61106 NBEG=I+1
61107 ENDIF
61108 700 CONTINUE
61109 ENDIF
61110 ENDIF
61111
61112C...Done if no checks on small-mass systems.
61113 IF(MSTJ(14).LT.0) RETURN
61114 IF(MSTJ(14).EQ.0) GOTO 1140
61115
61116C...Find lowest-mass colour singlet jet system.
61117 NS=N
61118 710 NSIN=N-NS
61119 PDMIN=1D0+PARJ(32)
61120 IC=0
61121 DO 770 I=MAX(1,IP),N
61122 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
61123 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
61124 NSIN=NSIN+1
61125 IC=I
61126 DO 720 J=1,4
61127 DPS(J)=P(I,J)
61128 720 CONTINUE
61129 MSTJ(93)=1
61130 DPS(5)=PYMASS(K(I,2))
61131 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
61132 DO 730 J=1,4
61133 DPS(J)=DPS(J)+P(I,J)
61134 730 CONTINUE
61135 MSTJ(93)=1
61136 DPS(5)=DPS(5)+PYMASS(K(I,2))
61137 ELSEIF(K(I,1).EQ.2) THEN
61138 DO 740 J=1,4
61139 DPS(J)=DPS(J)+P(I,J)
61140 740 CONTINUE
61141 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61142 DO 750 J=1,4
61143 DPS(J)=DPS(J)+P(I,J)
61144 750 CONTINUE
61145 MSTJ(93)=1
61146 DPS(5)=DPS(5)+PYMASS(K(I,2))
61147 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
61148 & DPS(5)
61149 IF(PD.LT.PDMIN) THEN
61150 PDMIN=PD
61151 DO 760 J=1,5
61152 DPC(J)=DPS(J)
61153 760 CONTINUE
61154 IC1=IC
61155 IC2=I
61156 ENDIF
61157 IC=0
61158 ELSE
61159 NSIN=NSIN+1
61160 ENDIF
61161 770 CONTINUE
61162
61163C...Done if lowest-mass system above threshold for string frag.
61164 IF(PDMIN.GE.PARJ(32)) GOTO 1140
61165
61166C...Fill small-mass system as cluster.
61167 NSAV=N
61168 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
61169 K(N+1,1)=11
61170 K(N+1,2)=91
61171 K(N+1,3)=IC1
61172 P(N+1,1)=DPC(1)
61173 P(N+1,2)=DPC(2)
61174 P(N+1,3)=DPC(3)
61175 P(N+1,4)=DPC(4)
61176 P(N+1,5)=PECM
61177
61178C...Set up history, assuming cluster -> 2 hadrons.
61179 NBODY=2
61180 K(N+1,4)=N+2
61181 K(N+1,5)=N+3
61182 K(N+2,1)=1
61183 K(N+3,1)=1
61184 IF(MSTU(16).NE.2) THEN
61185 K(N+2,3)=N+1
61186 K(N+3,3)=N+1
61187 ELSE
61188 K(N+2,3)=IC1
61189 K(N+3,3)=IC2
61190 ENDIF
61191 K(N+2,4)=0
61192 K(N+3,4)=0
61193 K(N+2,5)=0
61194 K(N+3,5)=0
61195 V(N+1,5)=0D0
61196 V(N+2,5)=0D0
61197 V(N+3,5)=0D0
61198
61199C...Find total flavour content - complicated by presence of junctions.
61200 NQ=0
61201 NDIQ=0
61202 DO 780 I=IC1,IC2
61203 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
61204 NQ=NQ+1
61205 KFQ(NQ)=K(I,2)
61206 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
61207 ENDIF
61208 780 CONTINUE
61209
61210C...If several diquarks, split up one to give even number of flavours.
61211 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
61212 I1=3
61213 IF(IABS(KFQ(3)).LT.1000) I1=1
61214 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
61215 KFQ(I1)=KFQ(I1)/1000
61216 NQ=4
61217 NDIQ=NDIQ-1
61218 ENDIF
61219
61220C...If four quark ends, join two to diquark.
61221 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
61222 I1=1
61223 I2=2
61224 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
61225 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
61226 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61227 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61228 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61229 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61230 KFQ(I2)=KFQ(4)
61231 NQ=3
61232 NDIQ=1
61233 ENDIF
61234
61235C...If two quark ends, plus quark or diquark, join quarks to diquark.
61236 IF(NQ.EQ.3) THEN
61237 I1=1
61238 I2=2
61239 IF(IABS(KFQ(I1)).GT.1000) I1=3
61240 IF(IABS(KFQ(I2)).GT.1000) I2=3
61241 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
61242 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
61243 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
61244 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
61245 KFQ(I2)=KFQ(3)
61246 NQ=2
61247 NDIQ=NDIQ+1
61248 ENDIF
61249
61250C...Form two particles from flavours of lowest-mass system, if feasible.
61251 NTRY = 0
61252 790 NTRY = NTRY + 1
61253
61254C...Open string with two specified endpoint flavours.
61255 IF(NQ.EQ.2) THEN
61256 KC1=PYCOMP(KFQ(1))
61257 KC2=PYCOMP(KFQ(2))
61258 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
61259 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61260 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61261 IF(KQ1+KQ2.NE.0) GOTO 1140
61262C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
61263 800 K1=KFQ(1)
61264 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
61265 MSTU(125)=0
61266 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
61267 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
61268 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
61269
61270C...Open string with four specified flavours.
61271 ELSEIF(NQ.EQ.4) THEN
61272 KC1=PYCOMP(KFQ(1))
61273 KC2=PYCOMP(KFQ(2))
61274 KC3=PYCOMP(KFQ(3))
61275 KC4=PYCOMP(KFQ(4))
61276 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
61277 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
61278 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
61279 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
61280 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
61281 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
61282C...Combine flavours pairwise to form two hadrons.
61283 810 I1=1
61284 I2=2
61285 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61286 & IABS(KFQ(2)).GT.1000)) I2=3
61287 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
61288 & IABS(KFQ(3)).GT.1000))) I2=4
61289 I3=3
61290 IF(I2.EQ.3) I3=2
61291 I4=10-I1-I2-I3
61292 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
61293 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
61294 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
61295
61296C...Closed string.
61297 ELSE
61298 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
61299C...No room for popcorn mesons in closed string -> 2 hadrons.
61300 MSTU(125)=0
61301 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
61302 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
61303 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
61304 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
61305 ENDIF
61306 P(N+2,5)=PYMASS(K(N+2,2))
61307 P(N+3,5)=PYMASS(K(N+3,2))
61308
61309C...If it does not work: try again (a number of times), give up (if no
61310C...place to shuffle momentum or too many flavours), or form one hadron.
61311 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
61312 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
61313 GOTO 790
61314 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
61315 GOTO 1140
61316 ELSE
61317 GOTO 890
61318 END IF
61319 END IF
61320
61321C...Perform two-particle decay of jet system.
61322C...First step: find reference axis in decaying system rest frame.
61323C...(Borrow slot N+2 for temporary direction.)
61324 DO 830 J=1,4
61325 P(N+2,J)=P(IC1,J)
61326 830 CONTINUE
61327 DO 850 I=IC1+1,IC2-1
61328 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61329 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61330 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
61331 DO 840 J=1,4
61332 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
61333 840 CONTINUE
61334 ENDIF
61335 850 CONTINUE
61336 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
61337 &-DPC(3)/DPC(4))
61338 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
61339 PHI1=PYANGL(P(N+2,1),P(N+2,2))
61340
61341C...Second step: generate isotropic/anisotropic decay.
61342 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
61343 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
61344 860 UE(3)=PYR(0)
61345 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
61346 PT2=(1D0-UE(3)**2)*PA**2
61347 IF(MSTJ(16).LE.0) THEN
61348 PREV=0.5D0
61349 ELSE
61350 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
61351 PR1=P(N+2,5)**2+PT2
61352 PR2=P(N+3,5)**2+PT2
61353 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
61354 PREVCF=PARJ(42)
61355 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
61356 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
61357 ENDIF
61358 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
61359 PHI=PARU(2)*PYR(0)
61360 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
61361 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
61362 DO 870 J=1,3
61363 P(N+2,J)=PA*UE(J)
61364 P(N+3,J)=-PA*UE(J)
61365 870 CONTINUE
61366 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
61367 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
61368
61369C...Third step: move back to event frame and set production vertex.
61370 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
61371 &DPC(3)/DPC(4))
61372 DO 880 J=1,4
61373 V(N+1,J)=V(IC1,J)
61374 V(N+2,J)=V(IC1,J)
61375 V(N+3,J)=V(IC2,J)
61376 880 CONTINUE
61377 N=N+3
61378 GOTO 1120
61379
61380C...Else form one particle, if possible.
61381 890 NBODY=1
61382 K(N+1,5)=N+2
61383 DO 900 J=1,4
61384 V(N+1,J)=V(IC1,J)
61385 V(N+2,J)=V(IC1,J)
61386 900 CONTINUE
61387
61388C...Select hadron flavour from available quark flavours.
61389 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
61390 GOTO 1140
61391 ELSEIF(NQ.EQ.2) THEN
61392 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
61393 ELSE
61394 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
61395 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
61396 ENDIF
61397 IF(K(N+2,2).EQ.0) GOTO 910
61398 P(N+2,5)=PYMASS(K(N+2,2))
61399
61400C...Use old algorithm for E/p conservation? (EN)
61401 IF (MSTJ(16).LE.0) GOTO 1080
61402
61403C...Find the string piece closest to the cluster by a loop
61404C...over the undecayed partons not in present cluster. (EN)
61405 DGLOMI=1D30
61406 IBEG=0
61407 I0=0
61408 NJUNC=0
61409 DO 940 I1=MAX(1,IP),N-1
61410 IF(K(I1,1).EQ.1) NJUNC=0
61411 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
61412 IF(K(I1,1).EQ.41) GOTO 940
61413 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
61414 I0=0
61415 ELSEIF(K(I1,1).EQ.2) THEN
61416 IF(I0.EQ.0) I0=I1
61417 I2=I1
61418 920 I2=I2+1
61419 IF(K(I2,1).EQ.41) GOTO 940
61420 IF(K(I2,1).GT.10) GOTO 920
61421 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
61422 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
61423 & NJUNC.EQ.0) GOTO 940
61424 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
61425 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
61426 & K(I2,1).NE.1)) GOTO 940
61427
61428C...Define velocity vectors e1, e2, ecl and differences e3, e4.
61429 DO 930 J=1,3
61430 E1(J)=P(I1,J)/P(I1,4)
61431 E2(J)=P(I2,J)/P(I2,4)
61432 ECL(J)=P(N+1,J)/P(N+1,4)
61433 E3(J)=E2(J)-E1(J)
61434 E4(J)=ECL(J)-E1(J)
61435 930 CONTINUE
61436
61437C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
61438 E3S=E3(1)**2+E3(2)**2+E3(3)**2
61439 E4S=E4(1)**2+E4(2)**2+E4(3)**2
61440 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
61441 IF(E34.LE.0D0) THEN
61442 DDMIN=E4S
61443 ELSEIF(E34.LT.E3S) THEN
61444 DDMIN=E4S-E34**2/E3S
61445 ELSE
61446 DDMIN=E4S-2D0*E34+E3S
61447 ENDIF
61448
61449C...Is this the smallest so far?
61450 IF(DDMIN.LT.DGLOMI) THEN
61451 DGLOMI=DDMIN
61452 IBEG=I0
61453 IPCS=I1
61454 ENDIF
61455 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
61456 I0=0
61457 ENDIF
61458 940 CONTINUE
61459
61460C... Check if there are any strings to connect to the new gluon. (EN)
61461 IF (IBEG.EQ.0) GOTO 1080
61462
61463C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
61464 IF (P(N+1,5).GE.P(N+2,5)) THEN
61465
61466C...Construct 'gluon' that is needed to put hadron on the mass shell.
61467 FRAC=P(N+2,5)/P(N+1,5)
61468 DO 950 J=1,5
61469 P(N+2,J)=FRAC*P(N+1,J)
61470 PG(J)=(1D0-FRAC)*P(N+1,J)
61471 950 CONTINUE
61472
61473C... Copy string with new gluon put in.
61474 N=N+2
61475 I=IBEG-1
61476 960 I=I+1
61477 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
61478 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
61479 N=N+1
61480 DO 970 J=1,5
61481 K(N,J)=K(I,J)
61482 P(N,J)=P(I,J)
61483 V(N,J)=V(I,J)
61484 970 CONTINUE
61485 K(I,1)=K(I,1)+10
61486 K(I,4)=N
61487 K(I,5)=N
61488 K(N,3)=I
61489 IF(I.EQ.IPCS) THEN
61490 N=N+1
61491 DO 980 J=1,5
61492 K(N,J)=K(N-1,J)
61493 P(N,J)=PG(J)
61494 V(N,J)=V(N-1,J)
61495 980 CONTINUE
61496 K(N,2)=21
61497 K(N,3)=NSAV+1
61498 ENDIF
61499 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
61500 GOTO 1120
61501
61502C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
61503C...from string piece endpoints.
61504 ELSE
61505
61506C...Begin by copying string that should give energy to cluster.
61507 N=N+2
61508 I=IBEG-1
61509 990 I=I+1
61510 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
61511 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
61512 N=N+1
61513 DO 1000 J=1,5
61514 K(N,J)=K(I,J)
61515 P(N,J)=P(I,J)
61516 V(N,J)=V(I,J)
61517 1000 CONTINUE
61518 K(I,1)=K(I,1)+10
61519 K(I,4)=N
61520 K(I,5)=N
61521 K(N,3)=I
61522 IF(I.EQ.IPCS) I1=N
61523 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
61524 I2=I1+1
61525
61526C...Set initial Phad.
61527 DO 1010 J=1,4
61528 P(NSAV+2,J)=P(NSAV+1,J)
61529 1010 CONTINUE
61530
61531C...Calculate Pg, a part of which will be added to Phad later. (EN)
61532 1020 IF(MSTJ(16).EQ.1) THEN
61533 ALPHA=1D0
61534 BETA=1D0
61535 ELSE
61536 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
61537 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
61538 ENDIF
61539 DO 1030 J=1,4
61540 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
61541 1030 CONTINUE
61542 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
61543
61544C..Solve 2nd order equation, use the best (smallest) solution. (EN)
61545 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
61546 & P(NSAV+2,3)**2
61547 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
61548 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
61549 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
61550
61551C...If all gluon energy eaten, zero it and take a step back.
61552 ITER=0
61553 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
61554 ITER=1
61555 DO 1040 J=1,4
61556 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
61557 P(I1,J)=0D0
61558 1040 CONTINUE
61559 P(I1,5)=0D0
61560 K(I1,1)=K(I1,1)+10
61561 I1=I1-1
61562 IF(K(I1,1).EQ.41) ITER=-1
61563 ENDIF
61564 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
61565 ITER=1
61566 DO 1050 J=1,4
61567 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
61568 P(I2,J)=0D0
61569 1050 CONTINUE
61570 P(I2,5)=0D0
61571 K(I2,1)=K(I2,1)+10
61572 I2=I2+1
61573 IF(K(I2,1).EQ.41) ITER=-1
61574 ENDIF
61575 IF(ITER.EQ.1) GOTO 1020
61576
61577C...If also all endpoint energy eaten, revert to old procedure.
61578 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
61579 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
61580 DO 1060 I=NSAV+3,N
61581 IM=K(I,3)
61582 K(IM,1)=K(IM,1)-10
61583 K(IM,4)=0
61584 K(IM,5)=0
61585 1060 CONTINUE
61586 N=NSAV
61587 GOTO 1080
61588 ENDIF
61589
61590C... Construct the collapsed hadron and modified string partons.
61591 DO 1070 J=1,4
61592 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
61593 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
61594 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
61595 1070 CONTINUE
61596 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
61597 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
61598
61599C...Finished with string collapse in new scheme.
61600 GOTO 1120
61601 ENDIF
61602
61603C... Use old algorithm; by choice or when in trouble.
61604 1080 CONTINUE
61605C...Find parton/particle which combines to largest extra mass.
61606 IR=0
61607 HA=0D0
61608 HSM=0D0
61609 DO 1100 MCOMB=1,3
61610 IF(IR.NE.0) GOTO 1100
61611 DO 1090 I=MAX(1,IP),N
61612 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
61613 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
61614 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
61615 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
61616 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
61617 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
61618 & GOTO 1090
61619 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
61620 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
61621 IF(HSR.GT.HSM) THEN
61622 IR=I
61623 HA=HCR
61624 HSM=HSR
61625 ENDIF
61626 1090 CONTINUE
61627 1100 CONTINUE
61628
61629C...Shuffle energy and momentum to put new particle on mass shell.
61630 IF(IR.NE.0) THEN
61631 HB=PECM**2+HA
61632 HC=P(N+2,5)**2+HA
61633 HD=P(IR,5)**2+HA
61634 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
61635 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
61636 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
61637 DO 1110 J=1,4
61638 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
61639 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
61640 1110 CONTINUE
61641 N=N+2
61642 ELSE
61643 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
61644 RETURN
61645 ENDIF
61646
61647C...Mark collapsed system and store daughter pointers. Iterate.
61648 1120 DO 1130 I=IC1,IC2
61649 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
61650 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
61651 K(I,1)=K(I,1)+10
61652 IF(MSTU(16).NE.2) THEN
61653 K(I,4)=NSAV+1
61654 K(I,5)=NSAV+1
61655 ELSE
61656 K(I,4)=NSAV+2
61657 K(I,5)=NSAV+1+NBODY
61658 ENDIF
61659 ENDIF
61660 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
61661 1130 CONTINUE
61662 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
61663
61664C...Check flavours and invariant masses in parton systems.
61665 1140 NP=0
61666 KFN=0
61667 KQS=0
61668 NJU=0
61669 DO 1150 J=1,5
61670 DPS(J)=0D0
61671 1150 CONTINUE
61672 DO 1180 I=MAX(1,IP),N
61673 IF(K(I,1).EQ.41) NJU=NJU+1
61674 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
61675 KC=PYCOMP(K(I,2))
61676 IF(KC.EQ.0) GOTO 1180
61677 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61678 IF(KQ.EQ.0) GOTO 1180
61679 NP=NP+1
61680 IF(KQ.NE.2) THEN
61681 KFN=KFN+1
61682 KQS=KQS+KQ
61683 MSTJ(93)=1
61684 DPS(5)=DPS(5)+PYMASS(K(I,2))
61685 ENDIF
61686 DO 1160 J=1,4
61687 DPS(J)=DPS(J)+P(I,J)
61688 1160 CONTINUE
61689 IF(K(I,1).EQ.1) THEN
61690 NFERR=0
61691 IF(NJU.EQ.0.AND.NP.NE.1) THEN
61692 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
61693 ELSEIF(NJU.EQ.1) THEN
61694 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
61695 ELSEIF(NJU.EQ.2) THEN
61696 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
61697 ELSEIF(NJU.GE.3) THEN
61698 NFERR=1
61699 ENDIF
61700 IF(NFERR.EQ.1) THEN
61701 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
61702 MINT(51)=1
61703 RETURN
61704 ENDIF
61705 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
61706 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
61707 & '(PYPREP:) too small mass in jet system')
61708 NP=0
61709 KFN=0
61710 KQS=0
61711 NJU=0
61712 DO 1170 J=1,5
61713 DPS(J)=0D0
61714 1170 CONTINUE
61715 ENDIF
61716 1180 CONTINUE
61717
61718 RETURN
61719 END
61720
61721C*********************************************************************
61722
61723C...PYSTRF
61724C...Handles the fragmentation of an arbitrary colour singlet
61725C...jet system according to the Lund string fragmentation model.
61726
61727 SUBROUTINE PYSTRF(IP)
61728
61729C...Double precision and integer declarations.
61730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61731 IMPLICIT INTEGER(I-N)
61732 INTEGER PYK,PYCHGE,PYCOMP
61733C...Commonblocks.
61734 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
61735 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61736 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
61737 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
61738C...Local arrays. All MOPS variables ends with MO
61739 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
61740 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
61741 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
61742 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
61743 &PBST(3,5),TJUOLD(5)
61744
61745C...Function: four-product of two vectors.
61746 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)
61747 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
61748 &DP(I,3)*DP(J,3)
61749
61750C...Reset counters.
61751 MSTJ(91)=0
61752 NSAV=N
61753 MSTU90=MSTU(90)
61754 NP=0
61755 KQSUM=0
61756 DO 100 J=1,5
61757 DPS(J)=0D0
61758 100 CONTINUE
61759 MJU(1)=0
61760 MJU(2)=0
61761 NTRYFN=0
61762 IJUORI(1)=0
61763 IJUORI(2)=0
61764
61765C...Identify parton system.
61766 I=IP-1
61767 110 I=I+1
61768 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
61769 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
61770 IF(MSTU(21).GE.1) RETURN
61771 ENDIF
61772 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
61773 KC=PYCOMP(K(I,2))
61774 IF(KC.EQ.0) GOTO 110
61775 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
61776 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
61777 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
61778 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
61779 IF(MSTU(21).GE.1) RETURN
61780 ENDIF
61781
61782C...Take copy of partons to be considered. Check flavour sum.
61783 NP=NP+1
61784 DO 120 J=1,5
61785 K(N+NP,J)=K(I,J)
61786 P(N+NP,J)=P(I,J)
61787 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
61788 120 CONTINUE
61789 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
61790 K(N+NP,3)=I
61791 IF(KQ.NE.2) KQSUM=KQSUM+KQ
61792 IF(K(I,1).EQ.41) THEN
61793 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
61794 MJU(1)=N+NP
61795 IJUORI(1)=I
61796 ELSE
61797 MJU(2)=N+NP
61798 IJUORI(2)=I
61799 ENDIF
61800 ENDIF
61801 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
61802 IF(MOD(KQSUM,3).NE.0) THEN
61803 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
61804 IF(MSTU(21).GE.1) RETURN
61805 ENDIF
61806 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
61807
61808C...Boost copied system to CM frame (for better numerical precision).
61809 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
61810 MBST=0
61811 MSTU(33)=1
61812 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
61813 & -DPS(3)/DPS(4))
61814 ELSE
61815 MBST=1
61816 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
61817 DO 130 I=N+1,N+NP
61818 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
61819 IF(P(I,3).GT.0D0) THEN
61820 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
61821 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
61822 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61823 ELSE
61824 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
61825 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
61826 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
61827 ENDIF
61828 130 CONTINUE
61829 ENDIF
61830
61831C...Search for very nearby partons that may be recombined.
61832 NTRYR=0
61833 NTRYWR=0
61834 PARU12=PARU(12)
61835 PARU13=PARU(13)
61836 MJU(3)=MJU(1)
61837 MJU(4)=MJU(2)
61838 NR=NP
61839 NRMIN=2
61840 IF(MJU(1).GT.0) NRMIN=NRMIN+2
61841 IF(MJU(2).GT.0) NRMIN=NRMIN+2
61842 140 IF(NR.GT.NRMIN) THEN
61843 PDRMIN=2D0*PARU12
61844 DO 150 I=N+1,N+NR
61845 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
61846 I1=I+1
61847 IF(I.EQ.N+NR) I1=N+1
61848 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
61849 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
61850 & GOTO 150
61851 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
61852 & GOTO 150
61853 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
61854 & P(I1,2)**2+P(I1,3)**2))
61855 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
61856 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
61857 IF(PDR.LT.PDRMIN) THEN
61858 IR=I
61859 PDRMIN=PDR
61860 ENDIF
61861 150 CONTINUE
61862
61863C...Recombine very nearby partons to avoid machine precision problems.
61864 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
61865 DO 160 J=1,4
61866 P(N+1,J)=P(N+1,J)+P(N+NR,J)
61867 160 CONTINUE
61868 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
61869 & P(N+1,3)**2))
61870 NR=NR-1
61871 GOTO 140
61872 ELSEIF(PDRMIN.LT.PARU12) THEN
61873 DO 170 J=1,4
61874 P(IR,J)=P(IR,J)+P(IR+1,J)
61875 170 CONTINUE
61876 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
61877 & P(IR,3)**2))
61878 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
61879 DO 190 I=IR+1,N+NR-1
61880 K(I,1)=K(I+1,1)
61881 K(I,2)=K(I+1,2)
61882 DO 180 J=1,5
61883 P(I,J)=P(I+1,J)
61884 180 CONTINUE
61885 190 CONTINUE
61886 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
61887 NR=NR-1
61888 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
61889 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
61890 GOTO 140
61891 ENDIF
61892 ENDIF
61893 NTRYR=NTRYR+1
61894
61895C...Reset particle counter. Skip ahead if no junctions are present;
61896C...this is usually the case!
61897 NRS=MAX(5*NR+11,NP)
61898 NTRY=0
61899 200 NTRY=NTRY+1
61900 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
61901 PARU12=4D0*PARU12
61902 PARU13=2D0*PARU13
61903 GOTO 140
61904 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
61905 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
61906 IF(MSTU(21).GE.1) RETURN
61907 ENDIF
61908 I=N+NRS
61909 MSTU(90)=MSTU90
61910 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
61911 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
61912 & ' junction strings not handled by MSTJ(12)>3 options')
61913 DO 640 JT=1,2
61914 NJS(JT)=0
61915 IF(MJU(JT).EQ.0) GOTO 640
61916 JS=3-2*JT
61917
61918C++SKANDS
61919C...Find and sum up momentum on three sides of junction.
61920C...Begin with previous boost = zero.
61921 IJRFIT=0
61922 DO 210 IX=1,3
61923 TJUOLD(IX)=0D0
61924 210 CONTINUE
61925 TJUOLD(4)=1D0
61926 220 IU=0
61927C...Beginning and end of string system in event record.
61928 I1BEG=N+1+(JT-1)*(NR-1)
61929 I1END=N+NR+(JT-1)*(1-NR)
61930C...Look for junction string piece end points
61931 DO 230 I1=I1BEG,I1END,JS
61932 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
61933C...Store junction string piece end points.
61934C 1-junction systems 2-junction systems
61935C IU : 1 2 3 4 1 2 3 4 5 6
61936C 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
61937 IU=IU+1
61938 IJU(IU)=I1
61939 ENDIF
61940C...Sum over momenta, from junction outwards.
61941 230 CONTINUE
61942 DO 280 IU=1,3
61943 PWT=0D0
61944C...Initialize junction drag and string piece 4-vectors.
61945 DO 240 J=1,5
61946 PBST(IU,J)=0D0
61947 PJU(IU,J)=0D0
61948 240 CONTINUE
61949C...First two branches. Inwards out means opposite direction to JS.
61950C...(JS is 1 for JT=1, -1 for JT=2)
61951 IF (IU.LT.3) THEN
61952 I1A=IJU(IU+1)-JS
61953 I1B=IJU(IU)
61954 IDIR=-JS
61955C...Last branch (gq or gjgqgq). Direction now reversed.
61956 ELSE
61957 I1A=IJU(IU)+JS
61958 I1B=I1END
61959 IDIR=JS
61960 ENDIF
61961 DO 270 I1=I1A,I1B,IDIR
61962C...Sum up momentum directions with exponential suppression
61963C...for use in finding junction rest frame below.
61964 IF (K(I1,2).EQ.88) THEN
61965C...gjgqgq type system encountered. Use current PWT as start
61966C...for both strings.
61967 PWTOLD=PWT
61968 ELSE
61969 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
61970C...Sum up string piece (boosted) 4-momenta.
61971 DO 250 J=1,4
61972 PJU(IU,J)=PJU(IU,J)+P(I1,J)
61973 250 CONTINUE
61974C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
61975C...boost is zero, see above). Skip parton if suppression factor large.
61976 IF (PWT.GT.10D0) GOTO 270
61977C...Compute momentum in current frame:
61978 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
61979 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
61980 DO 260 J=1,3
61981 PTMP=P(I1,J)+TJUOLD(J)*BFC
61982 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
61983 260 CONTINUE
61984C...Boosted energy
61985 PTMP=TJUOLD(4)*P(I1,4)+TDP
61986 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
61987 PWT=PWT+PTMP/PARJ(48)
61988 ENDIF
61989 270 CONTINUE
61990C...Put |p| rather than m in 5th slot.
61991 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
61992 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
61993 280 CONTINUE
61994
61995C...Calculate boost from present frame to next JRF candidate.
61996 IJRFIT=IJRFIT+1
61997 CALL PYJURF(PBST,TJU)
61998
61999C...After some iterations do not take full step in new direction.
62000 IF(IJRFIT.GT.5) THEN
62001 REDUCE=0.8D0**(IJRFIT-5)
62002 TJU(1)=REDUCE*TJU(1)
62003 TJU(2)=REDUCE*TJU(2)
62004 TJU(3)=REDUCE*TJU(3)
62005 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62006 ENDIF
62007
62008C...Combine new boost (TJU) with old boost (TJUOLD)
62009 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
62010 DO 290 IX=1,3
62011 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
62012 290 CONTINUE
62013 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
62014
62015C...If last boost small, accept JRF, else iterate.
62016C...Also prevent possibility of infinite loop.
62017 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
62018 & IJRFIT.LT.MSTJ(18)) THEN
62019 GOTO 220
62020 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
62021 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
62022 ENDIF
62023
62024C...Now store total boost in TJU and change perception.
62025C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
62026C...TJU = junction motion vector in string CM, so the sign changes.
62027 DO 300 J=1,3
62028 TJU(J)=-TJUOLD(J)
62029 300 CONTINUE
62030 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
62031
62032C--SKANDS
62033
62034C...Calculate string piece energies in junction rest frame.
62035 DO 310 IU=1,3
62036 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
62037 & TJU(3)*PJU(IU,3)
62038 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
62039 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
62040 310 CONTINUE
62041
62042C...Start preparing for fragmentation of two strings from junction.
62043 ISTA=I
62044 NTRYER=0
62045 320 NTRYER=NTRYER+1
62046 I=ISTA
62047 DO 620 IU=1,2
62048 NS=IABS(IJU(IU+1)-IJU(IU))
62049
62050C...Junction strings: find longitudinal string directions.
62051 DO 350 IS=1,NS
62052 IS1=IJU(IU)+JS*(IS-1)
62053 IS2=IJU(IU)+JS*IS
62054 DO 330 J=1,5
62055 DP(1,J)=0.5D0*P(IS1,J)
62056 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
62057 DP(2,J)=0.5D0*P(IS2,J)
62058 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
62059 & (PJU(IU,5)/PBST(IU,5))
62060 330 CONTINUE
62061 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
62062 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
62063 DP(3,5)=DFOUR(1,1)
62064 DP(4,5)=DFOUR(2,2)
62065 DHKC=DFOUR(1,2)
62066 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
62067 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62068 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62069 DP(3,5)=0D0
62070 DP(4,5)=0D0
62071 DHKC=DFOUR(1,2)
62072 ENDIF
62073 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62074 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62075 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62076 IN1=N+NR+4*IS-3
62077 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62078 DO 340 J=1,4
62079 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62080 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62081 340 CONTINUE
62082 350 CONTINUE
62083
62084C...Junction strings: initialize flavour, momentum and starting pos.
62085 ISAV=I
62086 MSTU91=MSTU(90)
62087 360 NTRY=NTRY+1
62088 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62089 PARU12=4D0*PARU12
62090 PARU13=2D0*PARU13
62091 GOTO 140
62092 ELSEIF(NTRY.GT.100) THEN
62093 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62094 IF(MSTU(21).GE.1) RETURN
62095 ENDIF
62096 I=ISAV
62097 MSTU(90)=MSTU91
62098 IRANKJ=0
62099 IE(1)=K(N+1+(JT/2)*(NP-1),3)
62100 IF (MOD(JT+IU,2).NE.0) THEN
62101 IE(1)=K(IJU(IU),3)
62102 IF (NP-NR.NE.0) THEN
62103C...If gluons have disappeared. Original IJU must be used.
62104 IT=IP
62105 NE=1
62106 370 IT=IT+1
62107 IF (K(IT,2).NE.21) THEN
62108 NE=NE+1
62109 ENDIF
62110 IF (NE.EQ.IU+4*(JT-1)) THEN
62111 IE(1)=IT
62112 ELSEIF (IT.LE.IP+NP) THEN
62113 GOTO 370
62114 ELSE
62115 CALL PYERRM(14,'(PYSTRF:) '//
62116 & 'Original IJU could not be reconstructed!')
62117 ENDIF
62118 ENDIF
62119 ENDIF
62120 IN(4)=N+NR+1
62121 IN(5)=IN(4)+1
62122 IN(6)=N+NR+4*NS+1
62123 DO 390 JQ=1,2
62124 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
62125 P(IN1,1)=2-JQ
62126 P(IN1,2)=JQ-1
62127 P(IN1,3)=1D0
62128 380 CONTINUE
62129 390 CONTINUE
62130 KFL(1)=K(IJU(IU),2)
62131 PX(1)=0D0
62132 PY(1)=0D0
62133 GAM(1)=0D0
62134 DO 400 J=1,5
62135 PJU(IU+3,J)=0D0
62136 400 CONTINUE
62137
62138C...Junction strings: find initial transverse directions.
62139 DO 410 J=1,4
62140 DP(1,J)=P(IN(4),J)
62141 DP(2,J)=P(IN(4)+1,J)
62142 DP(3,J)=0D0
62143 DP(4,J)=0D0
62144 410 CONTINUE
62145 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62146 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62147 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62148 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62149 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62150 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62151 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62152 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62153 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62154 DHC12=DFOUR(1,2)
62155 DHCX1=DFOUR(3,1)/DHC12
62156 DHCX2=DFOUR(3,2)/DHC12
62157 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62158 DHCY1=DFOUR(4,1)/DHC12
62159 DHCY2=DFOUR(4,2)/DHC12
62160 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62161 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62162 DO 420 J=1,4
62163 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62164 P(IN(6),J)=DP(3,J)
62165 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62166 & DHCYX*DP(3,J))
62167 420 CONTINUE
62168
62169C...Junction strings: produce new particle, origin.
62170 430 I=I+1
62171 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62172 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62173 IF(MSTU(21).GE.1) RETURN
62174 ENDIF
62175 IRANKJ=IRANKJ+1
62176 K(I,1)=1
62177 K(I,3)=IE(1)
62178 K(I,4)=0
62179 K(I,5)=0
62180
62181C...Junction strings: generate flavour, hadron, pT, z and Gamma.
62182 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
62183 IF(K(I,2).EQ.0) GOTO 360
62184 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
62185 & IABS(KFL(3)).GT.10) THEN
62186 IF(PYR(0).GT.PARJ(19)) GOTO 440
62187 ENDIF
62188 P(I,5)=PYMASS(K(I,2))
62189 CALL PYPTDI(KFL(1),PX(3),PY(3))
62190 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
62191 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
62192 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
62193 & MSTU(90).LT.8) THEN
62194 MSTU(90)=MSTU(90)+1
62195 MSTU(90+MSTU(90))=I
62196 PARU(90+MSTU(90))=Z
62197 ENDIF
62198 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
62199 DO 450 J=1,3
62200 IN(J)=IN(3+J)
62201 450 CONTINUE
62202
62203C...Junction strings: stepping within 'low' string region.
62204 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62205 & P(IN(1),5)**2.GE.PR(1)) THEN
62206 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
62207 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
62208 DO 460 J=1,4
62209 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
62210 460 CONTINUE
62211 GOTO 560
62212C...Has used up energy of junction string, i.e. no more hadrons in it.
62213 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
62214 DO 470 J=1,5
62215 P(I,J)=0D0
62216 470 CONTINUE
62217 GOTO 600
62218C...Stepping from 'low' string region
62219 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62220 P(IN(2)+2,4)=P(IN(2)+2,3)
62221 P(IN(2)+2,1)=1D0
62222 IN(2)=IN(2)+4
62223 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62224 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62225 P(IN(1)+2,4)=P(IN(1)+2,3)
62226 P(IN(1)+2,1)=0D0
62227 IN(1)=IN(1)+4
62228 ENDIF
62229 ENDIF
62230
62231C...Junction strings: find new transverse directions.
62232 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
62233 & IN(1).GT.IN(2)) GOTO 360
62234 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
62235 DO 490 J=1,4
62236 DP(1,J)=P(IN(1),J)
62237 DP(2,J)=P(IN(2),J)
62238 DP(3,J)=0D0
62239 DP(4,J)=0D0
62240 490 CONTINUE
62241 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62242 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62243 DHC12=DFOUR(1,2)
62244 IF(DHC12.LE.1D-2) THEN
62245 P(IN(1)+2,4)=P(IN(1)+2,3)
62246 P(IN(1)+2,1)=0D0
62247 IN(1)=IN(1)+4
62248 GOTO 480
62249 ENDIF
62250 IN(3)=N+NR+4*NS+5
62251 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62252 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62253 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62254 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62255 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62256 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62257 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62258 DHCX1=DFOUR(3,1)/DHC12
62259 DHCX2=DFOUR(3,2)/DHC12
62260 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62261 DHCY1=DFOUR(4,1)/DHC12
62262 DHCY2=DFOUR(4,2)/DHC12
62263 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62264 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62265 DO 500 J=1,4
62266 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62267 P(IN(3),J)=DP(3,J)
62268 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62269 & DHCYX*DP(3,J))
62270 500 CONTINUE
62271C...Express pT with respect to new axes, if sensible.
62272 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
62273 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
62274 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62275 PX(3)=PXP
62276 PY(3)=PYP
62277 ENDIF
62278 ENDIF
62279
62280C...Junction strings: sum up known four-momentum, coefficients for m2.
62281 DO 530 J=1,4
62282 DHG(J)=0D0
62283 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
62284 & PY(3)*P(IN(3)+1,J)
62285 DO 510 IN1=IN(4),IN(1)-4,4
62286 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62287 510 CONTINUE
62288 DO 520 IN2=IN(5),IN(2)-4,4
62289 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62290 520 CONTINUE
62291 530 CONTINUE
62292 DHM(1)=FOUR(I,I)
62293 DHM(2)=2D0*FOUR(I,IN(1))
62294 DHM(3)=2D0*FOUR(I,IN(2))
62295 DHM(4)=2D0*FOUR(IN(1),IN(2))
62296
62297C...Junction strings: find coefficients for Gamma expression.
62298 DO 550 IN2=IN(1)+1,IN(2),4
62299 DO 540 IN1=IN(1),IN2-1,4
62300 DHC=2D0*FOUR(IN1,IN2)
62301 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
62302 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
62303 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
62304 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62305 540 CONTINUE
62306 550 CONTINUE
62307
62308C...Junction strings: solve (m2, Gamma) equation system for energies.
62309 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
62310 IF(ABS(DHS1).LT.1D-4) GOTO 360
62311 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
62312 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
62313 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
62314 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62315 & ABS(DHS1)-DHS2/DHS1)
62316 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
62317 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
62318 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
62319
62320C...Junction strings: step to new region if necessary.
62321 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
62322 P(IN(2)+2,4)=P(IN(2)+2,3)
62323 P(IN(2)+2,1)=1D0
62324 IN(2)=IN(2)+4
62325 IF(IN(2).GT.N+NR+4*NS) GOTO 360
62326 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62327 P(IN(1)+2,4)=P(IN(1)+2,3)
62328 P(IN(1)+2,1)=0D0
62329 IN(1)=IN(1)+4
62330 ENDIF
62331 GOTO 480
62332 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
62333 P(IN(1)+2,4)=P(IN(1)+2,3)
62334 P(IN(1)+2,1)=0D0
62335 IN(1)=IN(1)+4
62336 GOTO 480
62337 ENDIF
62338
62339C...Junction strings: particle four-momentum, remainder, loop back.
62340 560 DO 570 J=1,4
62341 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
62342 & P(IN(2)+2,4)*P(IN(2),J)
62343 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
62344 570 CONTINUE
62345 IF(P(I,4).LT.P(I,5)) GOTO 360
62346 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62347 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62348 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
62349 KFL(1)=-KFL(3)
62350 PX(1)=-PX(3)
62351 PY(1)=-PY(3)
62352 GAM(1)=GAM(3)
62353 IF(IN(3).NE.IN(6)) THEN
62354 DO 580 J=1,4
62355 P(IN(6),J)=P(IN(3),J)
62356 P(IN(6)+1,J)=P(IN(3)+1,J)
62357 580 CONTINUE
62358 ENDIF
62359 DO 590 JQ=1,2
62360 IN(3+JQ)=IN(JQ)
62361 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62362 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
62363 590 CONTINUE
62364 GOTO 430
62365 ENDIF
62366
62367C...Junction strings: save quantities left after each string.
62368 IF(IABS(KFL(1)).GT.10) GOTO 360
62369 600 I=I-1
62370 KFJH(IU)=KFL(1)
62371 DO 610 J=1,4
62372 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
62373 610 CONTINUE
62374
62375C...Junction strings: loopback if much unused energy in both strings.
62376 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
62377 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
62378 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
62379 620 CONTINUE
62380 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
62381 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
62382 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
62383 & .AND.NTRYER.LT.10) GOTO 320
62384
62385C...Junction strings: put together to new effective string endpoint.
62386 NJS(JT)=I-ISTA
62387 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
62388 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
62389 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
62390 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
62391 DO 630 J=1,4
62392 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
62393 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
62394 630 CONTINUE
62395 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
62396 & PJS(JT,3)**2))
62397 PJS(JT+2,5)=0D0
62398 640 CONTINUE
62399
62400C...Open versus closed strings. Choose breakup region for latter.
62401 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
62402 NS=MJU(2)-MJU(1)
62403 NB=MJU(1)-N
62404 ELSEIF(MJU(1).NE.0) THEN
62405 NS=N+NR-MJU(1)
62406 NB=MJU(1)-N
62407 ELSEIF(MJU(2).NE.0) THEN
62408 NS=MJU(2)-N
62409 NB=1
62410 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
62411 NS=NR-1
62412 NB=1
62413 ELSE
62414 NS=NR+1
62415 W2SUM=0D0
62416 DO 660 IS=1,NR
62417 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
62418 W2SUM=W2SUM+P(N+NR+IS,1)
62419 660 CONTINUE
62420 W2RAN=PYR(0)*W2SUM
62421 NB=0
62422 670 NB=NB+1
62423 W2SUM=W2SUM-P(N+NR+NB,1)
62424 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
62425 ENDIF
62426
62427C...Find longitudinal string directions (i.e. lightlike four-vectors).
62428 DO 700 IS=1,NS
62429 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
62430 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
62431 DO 680 J=1,5
62432 DP(1,J)=P(IS1,J)
62433 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
62434 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
62435 DP(2,J)=P(IS2,J)
62436 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
62437 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
62438 680 CONTINUE
62439 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
62440 & DP(1,2)**2-DP(1,3)**2))
62441 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
62442 & DP(2,2)**2-DP(2,3)**2))
62443 DP(3,5)=DFOUR(1,1)
62444 DP(4,5)=DFOUR(2,2)
62445 DHKC=DFOUR(1,2)
62446 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
62447 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
62448 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
62449 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
62450 IN1=N+NR+4*IS-3
62451 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
62452 DO 690 J=1,4
62453 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
62454 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
62455 690 CONTINUE
62456 700 CONTINUE
62457
62458C...Begin initialization: sum up energy, set starting position.
62459 ISAV=I
62460 MSTU91=MSTU(90)
62461 710 NTRY=NTRY+1
62462 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
62463 PARU12=4D0*PARU12
62464 PARU13=2D0*PARU13
62465 GOTO 140
62466 ELSEIF(NTRY.GT.100) THEN
62467 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
62468 IF(MSTU(21).GE.1) RETURN
62469 ENDIF
62470 I=ISAV
62471 MSTU(90)=MSTU91
62472 DO 730 J=1,4
62473 P(N+NRS,J)=0D0
62474 DO 720 IS=1,NR
62475 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
62476 720 CONTINUE
62477 730 CONTINUE
62478 DO 750 JT=1,2
62479 IRANK(JT)=0
62480 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
62481 IF(NS.GT.NR) IRANK(JT)=1
62482 IBARRK(JT)=0
62483 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
62484 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
62485 IN(3*JT+2)=IN(3*JT+1)+1
62486 IN(3*JT+3)=N+NR+4*NS+2*JT-1
62487 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
62488 P(IN1,1)=2-JT
62489 P(IN1,2)=JT-1
62490 P(IN1,3)=1D0
62491 740 CONTINUE
62492 750 CONTINUE
62493
62494C.. MOPS variables and switches
62495 NRVMO=0
62496 XBMO=1D0
62497 MSTU(121)=0
62498 MSTU(122)=0
62499
62500C...Initialize flavour and pT variables for open string.
62501 IF(NS.LT.NR) THEN
62502 PX(1)=0D0
62503 PY(1)=0D0
62504 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
62505 PX(2)=-PX(1)
62506 PY(2)=-PY(1)
62507 DO 760 JT=1,2
62508 KFL(JT)=K(IE(JT),2)
62509 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
62510 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
62511 MSTJ(93)=1
62512 PMQ(JT)=PYMASS(KFL(JT))
62513 GAM(JT)=0D0
62514 760 CONTINUE
62515
62516C...Closed string: random initial breakup flavour, pT and vertex.
62517 ELSE
62518 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
62519 IBMO=0
62520 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
62521C.. Closed string: first vertex diq attempt => enforced second
62522C.. vertex diq
62523 IF(IABS(KFL(1)).GT.10)THEN
62524 IBMO=1
62525 MSTU(121)=0
62526 GOTO 770
62527 ENDIF
62528 IF(IBMO.EQ.1) MSTU(121)=-1
62529 KFL(2)=-KFL(1)
62530 CALL PYPTDI(KFL(1),PX(1),PY(1))
62531 PX(2)=-PX(1)
62532 PY(2)=-PY(1)
62533 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
62534 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
62535 ZR=PR3/(Z*P(N+NR+1,5)**2)
62536 IF(ZR.GE.1D0) GOTO 780
62537 DO 790 JT=1,2
62538 MSTJ(93)=1
62539 PMQ(JT)=PYMASS(KFL(JT))
62540 GAM(JT)=PR3*(1D0-Z)/Z
62541 IN1=N+NR+3+4*(JT/2)*(NS-1)
62542 P(IN1,JT)=1D0-Z
62543 P(IN1,3-JT)=JT-1
62544 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
62545 P(IN1+1,JT)=ZR
62546 P(IN1+1,3-JT)=2-JT
62547 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
62548 790 CONTINUE
62549 ENDIF
62550C.. MOPS variables
62551 DO 800 JT=1,2
62552 XTMO(JT)=1D0
62553 PM2QMO(JT)=PMQ(JT)**2
62554 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
62555 800 CONTINUE
62556
62557C...Find initial transverse directions (i.e. spacelike four-vectors).
62558 DO 840 JT=1,2
62559 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
62560 IN1=IN(3*JT+1)
62561 IN3=IN(3*JT+3)
62562 DO 810 J=1,4
62563 DP(1,J)=P(IN1,J)
62564 DP(2,J)=P(IN1+1,J)
62565 DP(3,J)=0D0
62566 DP(4,J)=0D0
62567 810 CONTINUE
62568 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62569 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62570 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62571 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62572 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62573 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62574 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62575 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62576 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62577 DHC12=DFOUR(1,2)
62578 DHCX1=DFOUR(3,1)/DHC12
62579 DHCX2=DFOUR(3,2)/DHC12
62580 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62581 DHCY1=DFOUR(4,1)/DHC12
62582 DHCY2=DFOUR(4,2)/DHC12
62583 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62584 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62585 DO 820 J=1,4
62586 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62587 P(IN3,J)=DP(3,J)
62588 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62589 & DHCYX*DP(3,J))
62590 820 CONTINUE
62591 ELSE
62592 DO 830 J=1,4
62593 P(IN3+2,J)=P(IN3,J)
62594 P(IN3+3,J)=P(IN3+1,J)
62595 830 CONTINUE
62596 ENDIF
62597 840 CONTINUE
62598
62599C...Remove energy used up in junction string fragmentation.
62600 IF(MJU(1)+MJU(2).GT.0) THEN
62601 DO 860 JT=1,2
62602 IF(NJS(JT).EQ.0) GOTO 860
62603 DO 850 J=1,4
62604 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
62605 850 CONTINUE
62606 860 CONTINUE
62607 PARJST=PARJ(33)
62608 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62609 WMIN=PARJST+PMQ(1)+PMQ(2)
62610 WREM2=FOUR(N+NRS,N+NRS)
62611 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
62612 NTRYWR=NTRYWR+1
62613 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
62614 GOTO 140
62615 ENDIF
62616 ENDIF
62617
62618C...Produce new particle: side, origin.
62619 870 I=I+1
62620 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
62621 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
62622 IF(MSTU(21).GE.1) RETURN
62623 ENDIF
62624C.. New side priority for popcorn systems
62625 IF(MSTU(121).LE.0)THEN
62626 JT=1.5D0+PYR(0)
62627 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
62628 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
62629 ENDIF
62630 JR=3-JT
62631 JS=3-2*JT
62632 IRANK(JT)=IRANK(JT)+1
62633 K(I,1)=1
62634 K(I,4)=0
62635 K(I,5)=0
62636
62637C...Generate flavour, hadron and pT.
62638 880 K(I,3)=IE(JT)
62639 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
62640 IF(K(I,2).EQ.0) GOTO 710
62641 MU90MO=MSTU(90)
62642 IF(MSTU(121).EQ.-1) GOTO 910
62643 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
62644 &IABS(KFL(3)).GT.10) THEN
62645 IF(PYR(0).GT.PARJ(19)) GOTO 880
62646 ENDIF
62647 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62648 &K(I,3)=IJUORI(JT)
62649 P(I,5)=PYMASS(K(I,2))
62650 CALL PYPTDI(KFL(JT),PX(3),PY(3))
62651 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
62652
62653C...Final hadrons for small invariant mass.
62654 MSTJ(93)=1
62655 PMQ(3)=PYMASS(KFL(3))
62656 PARJST=PARJ(33)
62657 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
62658 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
62659 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
62660 &WMIN-0.5D0*PARJ(36)*PMQ(3)
62661 WREM2=FOUR(N+NRS,N+NRS)
62662 IF(WREM2.LT.0.10D0) GOTO 710
62663 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
62664 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
62665
62666C...Choose z, which gives Gamma. Shift z for heavy flavours.
62667 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
62668 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
62669 &MSTU(90).LT.8) THEN
62670 MSTU(90)=MSTU(90)+1
62671 MSTU(90+MSTU(90))=I
62672 PARU(90+MSTU(90))=Z
62673 ENDIF
62674 KFL1A=IABS(KFL(1))
62675 KFL2A=IABS(KFL(2))
62676 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62677 &MOD(KFL2A/1000,10)).GE.4) THEN
62678 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62679 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
62680 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
62681 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62682 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
62683 ENDIF
62684 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
62685
62686C.. MOPS baryon model modification
62687 XTMO3=(1D0-Z)*XTMO(JT)
62688 IF(IABS(KFL(3)).LE.10) NRVMO=0
62689 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
62690 GTSTMO=1D0
62691 PTSTMO=1D0
62692 RTSTMO=PYR(0)
62693 IF(IABS(KFL(JT)).LE.10)THEN
62694 XBMO=MIN(XTMO3,1D0-(2D-10))
62695 GBMO=GAM(3)
62696 PMMO=0D0
62697 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
62698 GTSTMO=1D0-PARF(192)**PGMO
62699 ELSE
62700 IF(IRANK(JT).EQ.1) THEN
62701 GBMO=GAM(JT)
62702 PMMO=0D0
62703 XBMO=1D0
62704 ENDIF
62705 IF(XBMO.LT.1D0-(1D-10))THEN
62706 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
62707 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
62708 PGMO=PGNMO
62709 ENDIF
62710 IF(MSTJ(12).GE.5)THEN
62711 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
62712 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
62713 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
62714 PMMO=PMNMO
62715 ENDIF
62716 ENDIF
62717
62718C.. MOPS Accepting popcorn system hadron.
62719 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
62720 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
62721 NRVMO=I-N-NR
62722 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
62723 CALL PYERRM(11,
62724 & '(PYSTRF:) no more memory left in PYJETS')
62725 IF(MSTU(21).GE.1) RETURN
62726 ENDIF
62727 IMO=I
62728 KFLMO=KFL(JT)
62729 PMQMO=PMQ(JT)
62730 PXMO=PX(JT)
62731 PYMO=PY(JT)
62732 GAMMO=GAM(JT)
62733 IRMO=IRANK(JT)
62734 XMO=XTMO(JT)
62735 DO 900 J=1,9
62736 IF(J.LE.5) THEN
62737 DO 890 LINE=1,I-N-NR
62738 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
62739 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
62740 890 CONTINUE
62741 ENDIF
62742 INMO(J)=IN(J)
62743 900 CONTINUE
62744 ENDIF
62745 ELSE
62746C..Reject popcorn system, flag=-1 if enforcing new one
62747 MSTU(121)=-1
62748 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
62749 ENDIF
62750 ENDIF
62751
62752
62753C..Lift restoring string outside MOPS block
62754 910 IF(MSTU(121).LT.0) THEN
62755 IF(MSTU(121).EQ.-2) MSTU(121)=0
62756 MSTU(90)=MU90MO
62757 NRVMO=0
62758 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
62759 I=IMO
62760 KFL(JT)=KFLMO
62761 PMQ(JT)=PMQMO
62762 PX(JT)=PXMO
62763 PY(JT)=PYMO
62764 GAM(JT)=GAMMO
62765 IRANK(JT)=IRMO
62766 XTMO(JT)=XMO
62767 DO 930 J=1,9
62768 IF(J.LE.5) THEN
62769 DO 920 LINE=1,I-N-NR
62770 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
62771 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
62772 920 CONTINUE
62773 ENDIF
62774 IN(J)=INMO(J)
62775 930 CONTINUE
62776 GOTO 880
62777 ENDIF
62778 XTMO(JT)=XTMO3
62779C.. MOPS end of modification
62780
62781 DO 940 J=1,3
62782 IN(J)=IN(3*JT+J)
62783 940 CONTINUE
62784
62785C...Stepping within or from 'low' string region easy.
62786 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
62787 &P(IN(1),5)**2.GE.PR(JT)) THEN
62788 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
62789 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
62790 DO 950 J=1,4
62791 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
62792 950 CONTINUE
62793 GOTO 1040
62794 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
62795 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62796 P(IN(JR)+2,JT)=1D0
62797 IN(JR)=IN(JR)+4*JS
62798 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62799 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62800 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62801 P(IN(JT)+2,JT)=0D0
62802 IN(JT)=IN(JT)+4*JS
62803 ENDIF
62804 ENDIF
62805
62806C...Find new transverse directions (i.e. spacelike string vectors).
62807 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
62808 &IN(1).GT.IN(2)) GOTO 710
62809 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
62810 DO 970 J=1,4
62811 DP(1,J)=P(IN(1),J)
62812 DP(2,J)=P(IN(2),J)
62813 DP(3,J)=0D0
62814 DP(4,J)=0D0
62815 970 CONTINUE
62816 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
62817 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
62818 DHC12=DFOUR(1,2)
62819 IF(DHC12.LE.1D-2) THEN
62820 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62821 P(IN(JT)+2,JT)=0D0
62822 IN(JT)=IN(JT)+4*JS
62823 GOTO 960
62824 ENDIF
62825 IN(3)=N+NR+4*NS+5
62826 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
62827 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
62828 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
62829 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
62830 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
62831 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
62832 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
62833 DHCX1=DFOUR(3,1)/DHC12
62834 DHCX2=DFOUR(3,2)/DHC12
62835 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
62836 DHCY1=DFOUR(4,1)/DHC12
62837 DHCY2=DFOUR(4,2)/DHC12
62838 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
62839 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
62840 DO 980 J=1,4
62841 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
62842 P(IN(3),J)=DP(3,J)
62843 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
62844 & DHCYX*DP(3,J))
62845 980 CONTINUE
62846C...Express pT with respect to new axes, if sensible.
62847 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
62848 & FOUR(IN(3*JT+3)+1,IN(3)))
62849 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
62850 & FOUR(IN(3*JT+3)+1,IN(3)+1))
62851 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
62852 PX(3)=PXP
62853 PY(3)=PYP
62854 ENDIF
62855 ENDIF
62856
62857C...Sum up known four-momentum. Gives coefficients for m2 expression.
62858 DO 1010 J=1,4
62859 DHG(J)=0D0
62860 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
62861 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
62862 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
62863 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
62864 990 CONTINUE
62865 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
62866 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
62867 1000 CONTINUE
62868 1010 CONTINUE
62869 DHM(1)=FOUR(I,I)
62870 DHM(2)=2D0*FOUR(I,IN(1))
62871 DHM(3)=2D0*FOUR(I,IN(2))
62872 DHM(4)=2D0*FOUR(IN(1),IN(2))
62873
62874C...Find coefficients for Gamma expression.
62875 DO 1030 IN2=IN(1)+1,IN(2),4
62876 DO 1020 IN1=IN(1),IN2-1,4
62877 DHC=2D0*FOUR(IN1,IN2)
62878 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
62879 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
62880 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
62881 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
62882 1020 CONTINUE
62883 1030 CONTINUE
62884
62885C...Solve (m2, Gamma) equation system for energies taken.
62886 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
62887 IF(ABS(DHS1).LT.1D-4) GOTO 710
62888 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
62889 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
62890 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
62891 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
62892 &ABS(DHS1)-DHS2/DHS1)
62893 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
62894 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
62895 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
62896
62897C...Step to new region if necessary.
62898 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
62899 P(IN(JR)+2,4)=P(IN(JR)+2,3)
62900 P(IN(JR)+2,JT)=1D0
62901 IN(JR)=IN(JR)+4*JS
62902 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
62903 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
62904 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62905 P(IN(JT)+2,JT)=0D0
62906 IN(JT)=IN(JT)+4*JS
62907 ENDIF
62908 GOTO 960
62909 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
62910 P(IN(JT)+2,4)=P(IN(JT)+2,3)
62911 P(IN(JT)+2,JT)=0D0
62912 IN(JT)=IN(JT)+4*JS
62913 GOTO 960
62914 ENDIF
62915
62916C...Four-momentum of particle. Remaining quantities. Loop back.
62917 1040 DO 1050 J=1,4
62918 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
62919 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
62920 1050 CONTINUE
62921 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
62922 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
62923 &GOTO 200
62924 IF(P(I,4).LT.P(I,5)) GOTO 710
62925 KFL(JT)=-KFL(3)
62926 PMQ(JT)=PMQ(3)
62927 PX(JT)=-PX(3)
62928 PY(JT)=-PY(3)
62929 GAM(JT)=GAM(3)
62930 IF(IN(3).NE.IN(3*JT+3)) THEN
62931 DO 1060 J=1,4
62932 P(IN(3*JT+3),J)=P(IN(3),J)
62933 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
62934 1060 CONTINUE
62935 ENDIF
62936 DO 1070 JQ=1,2
62937 IN(3*JT+JQ)=IN(JQ)
62938 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
62939 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
62940 1070 CONTINUE
62941 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62942 &IBARRK(JT)=0
62943 GOTO 870
62944
62945C...Final hadron: side, flavour, hadron, mass.
62946 1080 I=I+1
62947 K(I,1)=1
62948 K(I,3)=IE(JR)
62949 K(I,4)=0
62950 K(I,5)=0
62951 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
62952 IF(K(I,2).EQ.0) GOTO 710
62953 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
62954 &IBARRK(JT)=0
62955 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62956 &K(I,3)=IJUORI(JT)
62957 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
62958 &K(I,3)=IJUORI(JR)
62959 P(I,5)=PYMASS(K(I,2))
62960 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
62961
62962C...Final two hadrons: find common setup of four-vectors.
62963 JQ=1
62964 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
62965 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
62966 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
62967 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
62968 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
62969 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
62970 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
62971 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
62972 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
62973 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
62974 ENDIF
62975
62976C...Solve kinematics for final two hadrons, if possible.
62977 WREM2=2D0*DHR1*DHR2*DHC12
62978 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
62979 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
62980 IF(FD.GE.1D0) GOTO 710
62981 FA=WREM2+PR(JT)-PR(JR)
62982 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
62983 PREVCF=PARJ(42)
62984 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
62985 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
62986 FB=SIGN(FB,JS*(PYR(0)-PREV))
62987 KFL1A=IABS(KFL(1))
62988 KFL2A=IABS(KFL(2))
62989 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
62990 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
62991 &4D0*WREM2*PR(JT))),DBLE(JS))
62992 DO 1090 J=1,4
62993 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
62994 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
62995 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
62996 P(I,J)=P(N+NRS,J)-P(I-1,J)
62997 1090 CONTINUE
62998 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
62999 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
63000 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
63001 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
63002 NTRYFN=NTRYFN+1
63003 IF(NTRYFN.LT.100) GOTO 140
63004 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
63005 ENDIF
63006
63007C...Mark jets as fragmented and give daughter pointers.
63008 N=I-NRS+1
63009 DO 1100 I=NSAV+1,NSAV+NP
63010 IM=K(I,3)
63011 K(IM,1)=K(IM,1)+10
63012 IF(MSTU(16).NE.2) THEN
63013 K(IM,4)=NSAV+1
63014 K(IM,5)=NSAV+1
63015 ELSE
63016 K(IM,4)=NSAV+2
63017 K(IM,5)=N
63018 ENDIF
63019 1100 CONTINUE
63020
63021C...Document string system. Move up particles.
63022 NSAV=NSAV+1
63023 K(NSAV,1)=11
63024 K(NSAV,2)=92
63025 K(NSAV,3)=IP
63026 K(NSAV,4)=NSAV+1
63027 K(NSAV,5)=N
63028 DO 1110 J=1,4
63029 P(NSAV,J)=DPS(J)
63030 V(NSAV,J)=V(IP,J)
63031 1110 CONTINUE
63032 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63033 V(NSAV,5)=0D0
63034 DO 1130 I=NSAV+1,N
63035 DO 1120 J=1,5
63036 K(I,J)=K(I+NRS-1,J)
63037 P(I,J)=P(I+NRS-1,J)
63038 V(I,J)=0D0
63039 1120 CONTINUE
63040 1130 CONTINUE
63041 MSTU91=MSTU(90)
63042 DO 1140 IZ=MSTU90+1,MSTU91
63043 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
63044 PARU9T(IZ)=PARU(90+IZ)
63045 1140 CONTINUE
63046 MSTU(90)=MSTU90
63047
63048C...Order particles in rank along the chain. Update mother pointer.
63049 DO 1160 I=NSAV+1,N
63050 DO 1150 J=1,5
63051 K(I-NSAV+N,J)=K(I,J)
63052 P(I-NSAV+N,J)=P(I,J)
63053 1150 CONTINUE
63054 1160 CONTINUE
63055 I1=NSAV
63056 DO 1190 I=N+1,2*N-NSAV
63057 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
63058 I1=I1+1
63059 DO 1170 J=1,5
63060 K(I1,J)=K(I,J)
63061 P(I1,J)=P(I,J)
63062 1170 CONTINUE
63063 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63064 DO 1180 IZ=MSTU90+1,MSTU91
63065 IF(MSTU9T(IZ).EQ.I) THEN
63066 MSTU(90)=MSTU(90)+1
63067 MSTU(90+MSTU(90))=I1
63068 PARU(90+MSTU(90))=PARU9T(IZ)
63069 ENDIF
63070 1180 CONTINUE
63071 1190 CONTINUE
63072 DO 1220 I=2*N-NSAV,N+1,-1
63073 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
63074 I1=I1+1
63075 DO 1200 J=1,5
63076 K(I1,J)=K(I,J)
63077 P(I1,J)=P(I,J)
63078 1200 CONTINUE
63079 IF(MSTU(16).NE.2) K(I1,3)=NSAV
63080 DO 1210 IZ=MSTU90+1,MSTU91
63081 IF(MSTU9T(IZ).EQ.I) THEN
63082 MSTU(90)=MSTU(90)+1
63083 MSTU(90+MSTU(90))=I1
63084 PARU(90+MSTU(90))=PARU9T(IZ)
63085 ENDIF
63086 1210 CONTINUE
63087 1220 CONTINUE
63088
63089C...Boost back particle system. Set production vertices.
63090 IF(MBST.EQ.0) THEN
63091 MSTU(33)=1
63092 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
63093 & DPS(3)/DPS(4))
63094 ELSE
63095 DO 1230 I=NSAV+1,N
63096 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
63097 IF(P(I,3).GT.0D0) THEN
63098 HHPEZ=(P(I,4)+P(I,3))*HHBZ
63099 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
63100 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63101 ELSE
63102 HHPEZ=(P(I,4)-P(I,3))/HHBZ
63103 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
63104 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
63105 ENDIF
63106 1230 CONTINUE
63107 ENDIF
63108 DO 1250 I=NSAV+1,N
63109 DO 1240 J=1,4
63110 V(I,J)=V(IP,J)
63111 1240 CONTINUE
63112 1250 CONTINUE
63113
63114 RETURN
63115 END
63116
63117C*********************************************************************
63118
63119C...PYJURF
63120C...From three given input vectors in PJU the boost VJU from
63121C...the "lab frame" to the junction rest frame is constructed.
63122
63123 SUBROUTINE PYJURF(PJU,VJU)
63124
63125C...Double precision and integer declarations.
63126 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63127 IMPLICIT INTEGER(I-N)
63128
63129C...Input, output and local arrays.
63130 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
63131 DATA TWOPI/6.283186D0/
63132
63133C...Calculate masses and other invariants.
63134 DO 100 J=1,4
63135 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63136 100 CONTINUE
63137 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
63138 PSUM(5)=SQRT(PSUM2)
63139 DO 120 I=1,3
63140 DO 110 J=1,3
63141 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
63142 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
63143 110 CONTINUE
63144 120 CONTINUE
63145
63146C...Pick I to be most massive parton and J to be the one closest to I.
63147 ITRY=0
63148 I=1
63149 IF(A(2,2).GT.A(1,1)) I=2
63150 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
63151 130 ITRY=ITRY+1
63152 J=1+MOD(I,3)
63153 K=1+MOD(J,3)
63154 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
63155 K=1+MOD(I,3)
63156 J=1+MOD(K,3)
63157 ENDIF
63158 PMI2=A(I,I)
63159 PMJ2=A(J,J)
63160 PMK2=A(K,K)
63161 AIJ=A(I,J)
63162 AIK=A(I,K)
63163 AJK=A(J,K)
63164
63165C...Trivial find new parton energies if all three partons are massless.
63166 IF(PMI2.LT.1D-4) THEN
63167 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
63168 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
63169 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
63170
63171C...Else find momentum range for parton I and values at extremes.
63172 ELSE
63173 PAIMIN=0D0
63174 PEIMIN=SQRT(PMI2)
63175 PEJMIN=AIJ/PEIMIN
63176 PEKMIN=AIK/PEIMIN
63177 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
63178 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
63179 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
63180 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
63181 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
63182 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
63183 HI=PEIMAX**2-0.25D0*PAIMAX**2
63184 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
63185 & 0.5D0*PAIMAX*AIJ)/HI
63186 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
63187 & 0.5D0*PAIMAX*AIK)/HI
63188 PEJMAX=SQRT(PAJMAX**2+PMJ2)
63189 PEKMAX=SQRT(PAKMAX**2+PMK2)
63190 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
63191
63192C...If unexpected values at upper endpoint then pick another parton.
63193 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
63194 I1=1+MOD(I,3)
63195 IF(A(I1,I1).GE.1D-4) THEN
63196 I=I1
63197 GOTO 130
63198 ENDIF
63199 ITRY=ITRY+1
63200 I1=1+MOD(I,3)
63201 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
63202 I=I1
63203 GOTO 130
63204 ENDIF
63205 ENDIF
63206
63207C..Start binary + linear search to find solution inside range.
63208 ITER=0
63209 ITMIN=0
63210 ITMAX=0
63211 PAI=0.5D0*(PAIMIN+PAIMAX)
63212 140 ITER=ITER+1
63213
63214C...Derive momentum of other two partons and distance to root.
63215 PEI=SQRT(PAI**2+PMI2)
63216 HI=PEI**2-0.25D0*PAI**2
63217 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
63218 PEJ=SQRT(PAJ**2+PMJ2)
63219 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
63220 PEK=SQRT(PAK**2+PMK2)
63221 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
63222
63223C...Pick next I momentum to explore, hopefully closer to root.
63224 IF(FNOW.GT.0D0) THEN
63225 PAIMIN=PAI
63226 FMIN=FNOW
63227 ITMIN=ITMIN+1
63228 ELSE
63229 PAIMAX=PAI
63230 FMAX=FNOW
63231 ITMAX=ITMAX+1
63232 ENDIF
63233 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
63234 & THEN
63235 PAI=0.5D0*(PAIMIN+PAIMAX)
63236 GOTO 140
63237 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
63238 & ABS(FNOW).GT.1D-12*PSUM2) THEN
63239 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
63240 GOTO 140
63241 ENDIF
63242 ENDIF
63243
63244C...Now know energies in junction rest frame.
63245 PENEW(I)=PEI
63246 PENEW(J)=PEJ
63247 PENEW(K)=PEK
63248
63249C...Boost (copy of) partons to their rest frame.
63250 VXCM=-PSUM(1)/PSUM(5)
63251 VYCM=-PSUM(2)/PSUM(5)
63252 VZCM=-PSUM(3)/PSUM(5)
63253 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
63254 DO 150 I=1,3
63255 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
63256 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
63257 PCM(I,1)=PJU(I,1)+FAC2*VXCM
63258 PCM(I,2)=PJU(I,2)+FAC2*VYCM
63259 PCM(I,3)=PJU(I,3)+FAC2*VZCM
63260 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
63261 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63262 150 CONTINUE
63263
63264C...Construct difference vectors and boost to junction rest frame.
63265 DO 160 J=1,3
63266 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
63267 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
63268 160 CONTINUE
63269 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
63270 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
63271 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
63272 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
63273 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
63274 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
63275 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
63276 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
63277 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
63278 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
63279 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
63280
63281C...Add two boosts, giving final result.
63282 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
63283 VJU(1)=VXJU+FCM*VXCM
63284 VJU(2)=VYJU+FCM*VYCM
63285 VJU(3)=VZJU+FCM*VZCM
63286 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
63287 VJU(5)=1D0
63288
63289C...In case of error in reconstruction: revert to CM frame of system.
63290 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63291 &(PCM(1,5)*PCM(2,5))
63292 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63293 &(PCM(1,5)*PCM(3,5))
63294 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63295 &(PCM(2,5)*PCM(3,5))
63296 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63297 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63298 DO 170 I=1,3
63299 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
63300 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
63301 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
63302 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
63303 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
63304 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
63305 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
63306 170 CONTINUE
63307 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
63308 &(PCM(1,5)*PCM(2,5))
63309 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
63310 &(PCM(1,5)*PCM(3,5))
63311 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
63312 &(PCM(2,5)*PCM(3,5))
63313 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
63314 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
63315 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
63316 VJU(1)=VXCM
63317 VJU(2)=VYCM
63318 VJU(3)=VZCM
63319 VJU(4)=GAMCM
63320 ENDIF
63321
63322 RETURN
63323 END
63324
63325C*********************************************************************
63326
63327C...PYINDF
63328C...Handles the fragmentation of a jet system (or a single
63329C...jet) according to independent fragmentation models.
63330
63331 SUBROUTINE PYINDF(IP)
63332
63333C...Double precision and integer declarations.
63334 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63335 IMPLICIT INTEGER(I-N)
63336 INTEGER PYK,PYCHGE,PYCOMP
63337C...Commonblocks.
63338 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63339 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63340 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63341 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
63342C...Local arrays.
63343 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
63344 &KFLO(2),PXO(2),PYO(2),WO(2)
63345
63346C.. MOPS error message
63347 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
63348 &' are not treated as expected in independent fragmentation')
63349
63350C...Reset counters. Identify parton system and take copy. Check flavour.
63351 NSAV=N
63352 MSTU90=MSTU(90)
63353 NJET=0
63354 KQSUM=0
63355 DO 100 J=1,5
63356 DPS(J)=0D0
63357 100 CONTINUE
63358 I=IP-1
63359 110 I=I+1
63360 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
63361 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
63362 IF(MSTU(21).GE.1) RETURN
63363 ENDIF
63364 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
63365 KC=PYCOMP(K(I,2))
63366 IF(KC.EQ.0) GOTO 110
63367 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
63368 IF(KQ.EQ.0) GOTO 110
63369 NJET=NJET+1
63370 IF(KQ.NE.2) KQSUM=KQSUM+KQ
63371 DO 120 J=1,5
63372 K(NSAV+NJET,J)=K(I,J)
63373 P(NSAV+NJET,J)=P(I,J)
63374 DPS(J)=DPS(J)+P(I,J)
63375 120 CONTINUE
63376 K(NSAV+NJET,3)=I
63377 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
63378 &K(I+1,1).EQ.2)) GOTO 110
63379 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
63380 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
63381 IF(MSTU(21).GE.1) RETURN
63382 ENDIF
63383
63384C...Boost copied system to CM frame. Find CM energy and sum flavours.
63385 IF(NJET.NE.1) THEN
63386 MSTU(33)=1
63387 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
63388 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
63389 ENDIF
63390 PECM=0D0
63391 DO 130 J=1,3
63392 NFI(J)=0
63393 130 CONTINUE
63394 DO 140 I=NSAV+1,NSAV+NJET
63395 PECM=PECM+P(I,4)
63396 KFA=IABS(K(I,2))
63397 IF(KFA.LE.3) THEN
63398 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
63399 ELSEIF(KFA.GT.1000) THEN
63400 KFLA=MOD(KFA/1000,10)
63401 KFLB=MOD(KFA/100,10)
63402 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
63403 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
63404 ENDIF
63405 140 CONTINUE
63406
63407C...Loop over attempts made. Reset counters.
63408 NTRY=0
63409 150 NTRY=NTRY+1
63410 IF(NTRY.GT.200) THEN
63411 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
63412 IF(MSTU(21).GE.1) RETURN
63413 ENDIF
63414 N=NSAV+NJET
63415 MSTU(90)=MSTU90
63416 DO 160 J=1,3
63417 NFL(J)=NFI(J)
63418 IFET(J)=0
63419 KFLF(J)=0
63420 160 CONTINUE
63421
63422C...Loop over jets to be fragmented.
63423 DO 230 IP1=NSAV+1,NSAV+NJET
63424 MSTJ(91)=0
63425 NSAV1=N
63426 MSTU91=MSTU(90)
63427
63428C...Initial flavour and momentum values. Jet along +z axis.
63429 KFLH=IABS(K(IP1,2))
63430 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
63431 KFLO(2)=0
63432 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
63433
63434C...Initial values for quark or diquark jet.
63435 170 IF(IABS(K(IP1,2)).NE.21) THEN
63436 NSTR=1
63437 KFLO(1)=K(IP1,2)
63438 CALL PYPTDI(0,PXO(1),PYO(1))
63439 WO(1)=WF
63440
63441C...Initial values for gluon treated like random quark jet.
63442 ELSEIF(MSTJ(2).LE.2) THEN
63443 NSTR=1
63444 IF(MSTJ(2).EQ.2) MSTJ(91)=1
63445 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63446 CALL PYPTDI(0,PXO(1),PYO(1))
63447 WO(1)=WF
63448
63449C...Initial values for gluon treated like quark-antiquark jet pair,
63450C...sharing energy according to Altarelli-Parisi splitting function.
63451 ELSE
63452 NSTR=2
63453 IF(MSTJ(2).EQ.4) MSTJ(91)=1
63454 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
63455 KFLO(2)=-KFLO(1)
63456 CALL PYPTDI(0,PXO(1),PYO(1))
63457 PXO(2)=-PXO(1)
63458 PYO(2)=-PYO(1)
63459 WO(1)=WF*PYR(0)**(1D0/3D0)
63460 WO(2)=WF-WO(1)
63461 ENDIF
63462
63463C...Initial values for rank, flavour, pT and W+.
63464 DO 220 ISTR=1,NSTR
63465 180 I=N
63466 MSTU(90)=MSTU91
63467 IRANK=0
63468 KFL1=KFLO(ISTR)
63469 PX1=PXO(ISTR)
63470 PY1=PYO(ISTR)
63471 W=WO(ISTR)
63472
63473C...New hadron. Generate flavour and hadron species.
63474 190 I=I+1
63475 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
63476 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
63477 IF(MSTU(21).GE.1) RETURN
63478 ENDIF
63479 IRANK=IRANK+1
63480 K(I,1)=1
63481 K(I,3)=IP1
63482 K(I,4)=0
63483 K(I,5)=0
63484 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
63485 IF(K(I,2).EQ.0) GOTO 180
63486 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
63487 IF(PYR(0).GT.PARJ(19)) GOTO 200
63488 ENDIF
63489
63490C...Find hadron mass. Generate four-momentum.
63491 P(I,5)=PYMASS(K(I,2))
63492 CALL PYPTDI(KFL1,PX2,PY2)
63493 P(I,1)=PX1+PX2
63494 P(I,2)=PY1+PY2
63495 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
63496 CALL PYZDIS(KFL1,KFL2,PR,Z)
63497 MZSAV=0
63498 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
63499 MZSAV=1
63500 MSTU(90)=MSTU(90)+1
63501 MSTU(90+MSTU(90))=I
63502 PARU(90+MSTU(90))=Z
63503 ENDIF
63504 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
63505 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
63506 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
63507 & P(I,3).LE.0.001D0) THEN
63508 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
63509 P(I,3)=0.0001D0
63510 P(I,4)=SQRT(PR)
63511 Z=P(I,4)/W
63512 ENDIF
63513
63514C...Remaining flavour and momentum.
63515 KFL1=-KFL2
63516 PX1=-PX2
63517 PY1=-PY2
63518 W=(1D0-Z)*W
63519 DO 210 J=1,5
63520 V(I,J)=0D0
63521 210 CONTINUE
63522
63523C...Check if pL acceptable. Go back for new hadron if enough energy.
63524 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
63525 I=I-1
63526 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
63527 ENDIF
63528 IF(W.GT.PARJ(31)) GOTO 190
63529 N=I
63530 220 CONTINUE
63531 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
63532 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
63533
63534C...Rotate jet to new direction.
63535 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
63536 PHI=PYANGL(P(IP1,1),P(IP1,2))
63537 MSTU(33)=1
63538 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
63539 K(K(IP1,3),4)=NSAV1+1
63540 K(K(IP1,3),5)=N
63541
63542C...End of jet generation loop. Skip conservation in some cases.
63543 230 CONTINUE
63544 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
63545 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
63546
63547C...Subtract off produced hadron flavours, finished if zero.
63548 DO 240 I=NSAV+NJET+1,N
63549 KFA=IABS(K(I,2))
63550 KFLA=MOD(KFA/1000,10)
63551 KFLB=MOD(KFA/100,10)
63552 KFLC=MOD(KFA/10,10)
63553 IF(KFLA.EQ.0) THEN
63554 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
63555 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
63556 ELSE
63557 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
63558 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
63559 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
63560 ENDIF
63561 240 CONTINUE
63562 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63563 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63564 IF(NREQ.EQ.0) GOTO 320
63565
63566C...Take away flavour of low-momentum particles until enough freedom.
63567 NREM=0
63568 250 IREM=0
63569 P2MIN=PECM**2
63570 DO 260 I=NSAV+NJET+1,N
63571 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
63572 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
63573 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
63574 260 CONTINUE
63575 IF(IREM.EQ.0) GOTO 150
63576 K(IREM,1)=7
63577 KFA=IABS(K(IREM,2))
63578 KFLA=MOD(KFA/1000,10)
63579 KFLB=MOD(KFA/100,10)
63580 KFLC=MOD(KFA/10,10)
63581 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
63582 IF(K(IREM,1).EQ.8) GOTO 250
63583 IF(KFLA.EQ.0) THEN
63584 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
63585 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
63586 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
63587 ELSE
63588 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
63589 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
63590 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
63591 ENDIF
63592 NREM=NREM+1
63593 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63594 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63595 IF(NREQ.GT.NREM) GOTO 250
63596 DO 270 I=NSAV+NJET+1,N
63597 IF(K(I,1).EQ.8) K(I,1)=1
63598 270 CONTINUE
63599
63600C...Find combination of existing and new flavours for hadron.
63601 280 NFET=2
63602 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
63603 IF(NREQ.LT.NREM) NFET=1
63604 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
63605 DO 290 J=1,NFET
63606 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
63607 KFLF(J)=ISIGN(1,NFL(1))
63608 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
63609 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
63610 290 CONTINUE
63611 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
63612 &GOTO 280
63613 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
63614 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
63615 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
63616 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
63617 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
63618 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
63619 IF(NFET.LE.2) KFLF(3)=0
63620 IF(KFLF(3).NE.0) THEN
63621 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
63622 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
63623 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
63624 & KFLFC=KFLFC+ISIGN(2,KFLFC)
63625 ELSE
63626 KFLFC=KFLF(1)
63627 ENDIF
63628 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
63629 IF(KF.EQ.0) GOTO 280
63630 DO 300 J=1,MAX(2,NFET)
63631 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
63632 300 CONTINUE
63633
63634C...Store hadron at random among free positions.
63635 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
63636 DO 310 I=NSAV+NJET+1,N
63637 IF(K(I,1).EQ.7) NPOS=NPOS-1
63638 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
63639 K(I,1)=1
63640 K(I,2)=KF
63641 P(I,5)=PYMASS(K(I,2))
63642 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63643 310 CONTINUE
63644 NREM=NREM-1
63645 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
63646 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
63647 IF(NREM.GT.0) GOTO 280
63648
63649C...Compensate for missing momentum in global scheme (3 options).
63650 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
63651 DO 340 J=1,3
63652 PSI(J)=0D0
63653 DO 330 I=NSAV+NJET+1,N
63654 PSI(J)=PSI(J)+P(I,J)
63655 330 CONTINUE
63656 340 CONTINUE
63657 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
63658 PWS=0D0
63659 DO 350 I=NSAV+NJET+1,N
63660 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
63661 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63662 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63663 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
63664 350 CONTINUE
63665 DO 370 I=NSAV+NJET+1,N
63666 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
63667 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
63668 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
63669 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
63670 DO 360 J=1,3
63671 P(I,J)=P(I,J)-PSI(J)*PW/PWS
63672 360 CONTINUE
63673 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63674 370 CONTINUE
63675
63676C...Compensate for missing momentum withing each jet separately.
63677 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
63678 DO 390 I=N+1,N+NJET
63679 K(I,1)=0
63680 DO 380 J=1,5
63681 P(I,J)=0D0
63682 380 CONTINUE
63683 390 CONTINUE
63684 DO 410 I=NSAV+NJET+1,N
63685 IR1=K(I,3)
63686 IR2=N+IR1-NSAV
63687 K(IR2,1)=K(IR2,1)+1
63688 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63689 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63690 DO 400 J=1,3
63691 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
63692 400 CONTINUE
63693 P(IR2,4)=P(IR2,4)+P(I,4)
63694 P(IR2,5)=P(IR2,5)+PLS
63695 410 CONTINUE
63696 PSS=0D0
63697 DO 420 I=N+1,N+NJET
63698 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
63699 420 CONTINUE
63700 DO 440 I=NSAV+NJET+1,N
63701 IR1=K(I,3)
63702 IR2=N+IR1-NSAV
63703 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
63704 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
63705 DO 430 J=1,3
63706 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
63707 & PLS*P(IR1,J)
63708 430 CONTINUE
63709 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63710 440 CONTINUE
63711 ENDIF
63712
63713C...Scale momenta for energy conservation.
63714 IF(MOD(MSTJ(3),5).NE.0) THEN
63715 PMS=0D0
63716 PES=0D0
63717 PQS=0D0
63718 DO 450 I=NSAV+NJET+1,N
63719 PMS=PMS+P(I,5)
63720 PES=PES+P(I,4)
63721 PQS=PQS+P(I,5)**2/P(I,4)
63722 450 CONTINUE
63723 IF(PMS.GE.PECM) GOTO 150
63724 NECO=0
63725 460 NECO=NECO+1
63726 PFAC=(PECM-PQS)/(PES-PQS)
63727 PES=0D0
63728 PQS=0D0
63729 DO 480 I=NSAV+NJET+1,N
63730 DO 470 J=1,3
63731 P(I,J)=PFAC*P(I,J)
63732 470 CONTINUE
63733 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
63734 PES=PES+P(I,4)
63735 PQS=PQS+P(I,5)**2/P(I,4)
63736 480 CONTINUE
63737 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
63738 ENDIF
63739
63740C...Origin of produced particles and parton daughter pointers.
63741 490 DO 500 I=NSAV+NJET+1,N
63742 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
63743 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
63744 500 CONTINUE
63745 DO 510 I=NSAV+1,NSAV+NJET
63746 I1=K(I,3)
63747 K(I1,1)=K(I1,1)+10
63748 IF(MSTU(16).NE.2) THEN
63749 K(I1,4)=NSAV+1
63750 K(I1,5)=NSAV+1
63751 ELSE
63752 K(I1,4)=K(I1,4)-NJET+1
63753 K(I1,5)=K(I1,5)-NJET+1
63754 IF(K(I1,5).LT.K(I1,4)) THEN
63755 K(I1,4)=0
63756 K(I1,5)=0
63757 ENDIF
63758 ENDIF
63759 510 CONTINUE
63760
63761C...Document independent fragmentation system. Remove copy of jets.
63762 NSAV=NSAV+1
63763 K(NSAV,1)=11
63764 K(NSAV,2)=93
63765 K(NSAV,3)=IP
63766 K(NSAV,4)=NSAV+1
63767 K(NSAV,5)=N-NJET+1
63768 DO 520 J=1,4
63769 P(NSAV,J)=DPS(J)
63770 V(NSAV,J)=V(IP,J)
63771 520 CONTINUE
63772 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
63773 V(NSAV,5)=0D0
63774 DO 540 I=NSAV+NJET,N
63775 DO 530 J=1,5
63776 K(I-NJET+1,J)=K(I,J)
63777 P(I-NJET+1,J)=P(I,J)
63778 V(I-NJET+1,J)=V(I,J)
63779 530 CONTINUE
63780 540 CONTINUE
63781 N=N-NJET+1
63782 DO 550 IZ=MSTU90+1,MSTU(90)
63783 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
63784 550 CONTINUE
63785
63786C...Boost back particle system. Set production vertices.
63787 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
63788 &DPS(2)/DPS(4),DPS(3)/DPS(4))
63789 DO 570 I=NSAV+1,N
63790 DO 560 J=1,4
63791 V(I,J)=V(IP,J)
63792 560 CONTINUE
63793 570 CONTINUE
63794
63795 RETURN
63796 END
63797
63798C*********************************************************************
63799
63800C...PYDECY
63801C...Handles the decay of unstable particles.
63802
63803 SUBROUTINE PYDECY(IP)
63804
63805C...Double precision and integer declarations.
63806 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
63807 IMPLICIT INTEGER(I-N)
63808 INTEGER PYK,PYCHGE,PYCOMP
63809C...Commonblocks.
63810 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
63811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
63812 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
63813 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
63814 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
63815C...Local arrays.
63816 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
63817 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
63818 CHARACTER CIDC*4
63819 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
63820
63821C...Functions: momentum in two-particle decays and four-product.
63822 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
63823 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)
63824
63825C...Initial values.
63826 NTRY=0
63827 NSAV=N
63828 KFA=IABS(K(IP,2))
63829 KFS=ISIGN(1,K(IP,2))
63830 KC=PYCOMP(KFA)
63831 MSTJ(92)=0
63832
63833C...Choose lifetime and determine decay vertex.
63834 IF(K(IP,1).EQ.5) THEN
63835 V(IP,5)=0D0
63836 ELSEIF(K(IP,1).NE.4) THEN
63837 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
63838 ENDIF
63839 DO 100 J=1,4
63840 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
63841 100 CONTINUE
63842
63843C...Determine whether decay allowed or not.
63844 MOUT=0
63845 IF(MSTJ(22).EQ.2) THEN
63846 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
63847 ELSEIF(MSTJ(22).EQ.3) THEN
63848 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
63849 ELSEIF(MSTJ(22).EQ.4) THEN
63850 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
63851 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
63852 ENDIF
63853 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
63854 K(IP,1)=4
63855 RETURN
63856 ENDIF
63857
63858C...Interface to external tau decay library (for tau polarization).
63859 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
63860
63861C...Starting values for pointers and momenta.
63862 ITAU=IP
63863 DO 110 J=1,4
63864 PTAU(J)=P(ITAU,J)
63865 PCMTAU(J)=P(ITAU,J)
63866 110 CONTINUE
63867
63868C...Iterate to find position and code of mother of tau.
63869 IMTAU=ITAU
63870 120 IMTAU=K(IMTAU,3)
63871
63872 IF(IMTAU.EQ.0) THEN
63873C...If no known origin then impossible to do anything further.
63874 KFORIG=0
63875 IORIG=0
63876
63877 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
63878C...If tau -> tau + gamma then add gamma energy and loop.
63879 IF(K(K(IMTAU,4),2).EQ.22) THEN
63880 DO 130 J=1,4
63881 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
63882 130 CONTINUE
63883 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
63884 DO 140 J=1,4
63885 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
63886 140 CONTINUE
63887 ENDIF
63888 GOTO 120
63889
63890 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
63891C...If coming from weak decay of hadron then W is not stored in record,
63892C...but can be reconstructed by adding neutrino momentum.
63893 KFORIG=-ISIGN(24,K(ITAU,2))
63894 IORIG=0
63895 DO 160 II=K(IMTAU,4),K(IMTAU,5)
63896 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
63897 DO 150 J=1,4
63898 PCMTAU(J)=PCMTAU(J)+P(II,J)
63899 150 CONTINUE
63900 ENDIF
63901 160 CONTINUE
63902
63903 ELSE
63904C...If coming from resonance decay then find latest copy of this
63905C...resonance (may not completely agree).
63906 KFORIG=K(IMTAU,2)
63907 IORIG=IMTAU
63908 DO 170 II=IMTAU+1,IP-1
63909 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
63910 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
63911 170 CONTINUE
63912 DO 180 J=1,4
63913 PCMTAU(J)=P(IORIG,J)
63914 180 CONTINUE
63915 ENDIF
63916
63917C...Boost tau to rest frame of production process (where known)
63918C...and rotate it to sit along +z axis.
63919 DO 190 J=1,3
63920 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
63921 190 CONTINUE
63922 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
63923 & -DBETAU(2),-DBETAU(3))
63924 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
63925 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
63926 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
63927 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
63928
63929C...Call tau decay routine (if meaningful) and fill extra info.
63930 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63931 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
63932 DO 200 II=NSAV+1,NSAV+NDECAY
63933 K(II,1)=1
63934 K(II,3)=IP
63935 K(II,4)=0
63936 K(II,5)=0
63937 200 CONTINUE
63938 N=NSAV+NDECAY
63939 ENDIF
63940
63941C...Boost back decay tau and decay products.
63942 DO 210 J=1,4
63943 P(ITAU,J)=PTAU(J)
63944 210 CONTINUE
63945 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
63946 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
63947 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
63948 & DBETAU(2),DBETAU(3))
63949
63950C...Skip past ordinary tau decay treatment.
63951 MMAT=0
63952 MBST=0
63953 ND=0
63954 GOTO 630
63955 ENDIF
63956 ENDIF
63957
63958C...B-Bbar mixing: flip sign of meson appropriately.
63959 MMIX=0
63960 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
63961 XBBMIX=PARJ(76)
63962 IF(KFA.EQ.531) XBBMIX=PARJ(77)
63963 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
63964 IF(MMIX.EQ.1) KFS=-KFS
63965 ENDIF
63966
63967C...Check existence of decay channels. Particle/antiparticle rules.
63968 KCA=KC
63969 IF(MDCY(KC,2).GT.0) THEN
63970 MDMDCY=MDME(MDCY(KC,2),2)
63971 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
63972 ENDIF
63973 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
63974 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
63975 RETURN
63976 ENDIF
63977 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
63978 IF(KCHG(KC,3).EQ.0) THEN
63979 KFSP=1
63980 KFSN=0
63981 IF(PYR(0).GT.0.5D0) KFS=-KFS
63982 ELSEIF(KFS.GT.0) THEN
63983 KFSP=1
63984 KFSN=0
63985 ELSE
63986 KFSP=0
63987 KFSN=1
63988 ENDIF
63989
63990C...Sum branching ratios of allowed decay channels.
63991 220 NOPE=0
63992 BRSU=0D0
63993 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
63994 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
63995 & KFSN*MDME(IDL,1).NE.3) GOTO 230
63996 IF(MDME(IDL,2).GT.100) GOTO 230
63997 NOPE=NOPE+1
63998 BRSU=BRSU+BRAT(IDL)
63999 230 CONTINUE
64000 IF(NOPE.EQ.0) THEN
64001 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
64002 RETURN
64003 ENDIF
64004
64005C...Select decay channel among allowed ones.
64006 240 RBR=BRSU*PYR(0)
64007 IDL=MDCY(KCA,2)-1
64008 250 IDL=IDL+1
64009 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
64010 &KFSN*MDME(IDL,1).NE.3) THEN
64011 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64012 ELSEIF(MDME(IDL,2).GT.100) THEN
64013 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
64014 ELSE
64015 IDC=IDL
64016 RBR=RBR-BRAT(IDL)
64017 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
64018 ENDIF
64019
64020C...Start readout of decay channel: matrix element, reset counters.
64021 MMAT=MDME(IDC,2)
64022 260 NTRY=NTRY+1
64023 IF(MOD(NTRY,200).EQ.0) THEN
64024 WRITE(CIDC,'(I4)') IDC
64025C...Do not print warning for some well-known special cases.
64026 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
64027 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
64028 & CIDC)
64029 GOTO 240
64030 ENDIF
64031 IF(NTRY.GT.1000) THEN
64032 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64033 IF(MSTU(21).GE.1) RETURN
64034 ENDIF
64035 I=N
64036 NP=0
64037 NQ=0
64038 MBST=0
64039 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
64040 DO 270 J=1,4
64041 PV(1,J)=0D0
64042 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
64043 270 CONTINUE
64044 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
64045 PV(1,5)=P(IP,5)
64046 PS=0D0
64047 PSQ=0D0
64048 MREM=0
64049 MHADDY=0
64050 IF(KFA.GT.80) MHADDY=1
64051C.. Random flavour and popcorn system memory.
64052 IRNDMO=0
64053 JTMO=0
64054 MSTU(121)=0
64055 MSTU(125)=10
64056
64057C...Read out decay products. Convert to standard flavour code.
64058 JTMAX=5
64059 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
64060 DO 280 JT=1,JTMAX
64061 IF(JT.LE.5) KP=KFDP(IDC,JT)
64062 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
64063 IF(KP.EQ.0) GOTO 280
64064 KPA=IABS(KP)
64065 KCP=PYCOMP(KPA)
64066 IF(KPA.GT.80) MHADDY=1
64067 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
64068 KFP=KP
64069 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
64070 KFP=KFS*KP
64071 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
64072 KFP=-KFS*MOD(KFA/10,10)
64073 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
64074 KFP=KFS*(100*MOD(KFA/10,100)+3)
64075 ELSEIF(KPA.EQ.81) THEN
64076 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
64077 ELSEIF(KP.EQ.82) THEN
64078 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
64079 IF(KFP.EQ.0) GOTO 260
64080 KFP=-KFP
64081 IRNDMO=1
64082 MSTJ(93)=1
64083 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
64084 ELSEIF(KP.EQ.-82) THEN
64085 KFP=MSTU(124)
64086 ENDIF
64087 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
64088
64089C...Add decay product to event record or to quark flavour list.
64090 KFPA=IABS(KFP)
64091 KQP=KCHG(KCP,2)
64092 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
64093 NQ=NQ+1
64094 KFLO(NQ)=KFP
64095C...set rndmflav popcorn system pointer
64096 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
64097 MSTJ(93)=2
64098 PSQ=PSQ+PYMASS(KFLO(NQ))
64099 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
64100 & MOD(NQ,2).EQ.1) THEN
64101 NQ=NQ-1
64102 PS=PS-P(I,5)
64103 K(I,1)=1
64104 KFI=K(I,2)
64105 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
64106 IF(K(I,2).EQ.0) GOTO 260
64107 MSTJ(93)=1
64108 P(I,5)=PYMASS(K(I,2))
64109 PS=PS+P(I,5)
64110 ELSE
64111 I=I+1
64112 NP=NP+1
64113 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
64114 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
64115 K(I,1)=1+MOD(NQ,2)
64116 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
64117 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
64118 K(I,2)=KFP
64119 K(I,3)=IP
64120 K(I,4)=0
64121 K(I,5)=0
64122 P(I,5)=PYMASS(KFP)
64123 PS=PS+P(I,5)
64124 ENDIF
64125 280 CONTINUE
64126
64127C...Check masses for resonance decays.
64128 IF(MHADDY.EQ.0) THEN
64129 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
64130 ENDIF
64131
64132C...Choose decay multiplicity in phase space model.
64133 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
64134 PSP=PS
64135 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
64136 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
64137 300 NTRY=NTRY+1
64138C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
64139 IF(IRNDMO.EQ.0) THEN
64140 MSTU(121)=0
64141 JTMO=0
64142 ELSEIF(IRNDMO.EQ.1) THEN
64143 IRNDMO=2
64144 ELSE
64145 GOTO 260
64146 ENDIF
64147 IF(NTRY.GT.1000) THEN
64148 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
64149 IF(MSTU(21).GE.1) RETURN
64150 ENDIF
64151 IF(MMAT.LE.20) THEN
64152 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
64153 & SIN(PARU(2)*PYR(0))
64154 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
64155 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
64156 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
64157 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
64158 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
64159 ELSE
64160 ND=MMAT-20
64161 ENDIF
64162C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
64163 MSTU(125)=ND-NQ/2
64164 IF(MSTU(121).GT.MSTU(125)) GOTO 300
64165
64166C...Form hadrons from flavour content.
64167 DO 310 JT=1,NQ
64168 KFL1(JT)=KFLO(JT)
64169 310 CONTINUE
64170 IF(ND.EQ.NP+NQ/2) GOTO 330
64171 DO 320 I=N+NP+1,N+ND-NQ/2
64172C.. Stick to started popcorn system, else pick side at random
64173 JT=JTMO
64174 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
64175 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
64176 IF(K(I,2).EQ.0) GOTO 300
64177 MSTU(125)=MSTU(125)-1
64178 JTMO=0
64179 IF(MSTU(121).GT.0) JTMO=JT
64180 KFL1(JT)=-KFL2
64181 320 CONTINUE
64182 330 JT=2
64183 JT2=3
64184 JT3=4
64185 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
64186 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
64187 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
64188 IF(JT.EQ.3) JT2=2
64189 IF(JT.EQ.4) JT3=2
64190 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
64191 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
64192 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
64193 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
64194
64195C...Check that sum of decay product masses not too large.
64196 PS=PSP
64197 DO 340 I=N+NP+1,N+ND
64198 K(I,1)=1
64199 K(I,3)=IP
64200 K(I,4)=0
64201 K(I,5)=0
64202 P(I,5)=PYMASS(K(I,2))
64203 PS=PS+P(I,5)
64204 340 CONTINUE
64205 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
64206
64207C...Rescale energy to subtract off spectator quark mass.
64208 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
64209 & .AND.NP.GE.3) THEN
64210 PS=PS-P(N+NP,5)
64211 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
64212 DO 350 J=1,5
64213 P(N+NP,J)=PQT*PV(1,J)
64214 PV(1,J)=(1D0-PQT)*PV(1,J)
64215 350 CONTINUE
64216 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64217 ND=NP-1
64218 MREM=1
64219
64220C...Fully specified final state: check mass broadening effects.
64221 ELSE
64222 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
64223 ND=NP
64224 ENDIF
64225
64226C...Determine position of grandmother, number of sisters.
64227 NM=0
64228 KFAS=0
64229 MSGN=0
64230 IF(MMAT.EQ.3) THEN
64231 IM=K(IP,3)
64232 IF(IM.LT.0.OR.IM.GE.IP) IM=0
64233 IF(IM.NE.0) KFAM=IABS(K(IM,2))
64234 IF(IM.NE.0) THEN
64235 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
64236 IF(K(IL,3).EQ.IM) NM=NM+1
64237 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
64238 360 CONTINUE
64239 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
64240 & MOD(KFAM/1000,10).NE.0) NM=0
64241 IF(NM.EQ.2) THEN
64242 KFAS=IABS(K(ISIS,2))
64243 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
64244 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
64245 ENDIF
64246 ENDIF
64247 ENDIF
64248
64249C...Kinematics of one-particle decays.
64250 IF(ND.EQ.1) THEN
64251 DO 370 J=1,4
64252 P(N+1,J)=P(IP,J)
64253 370 CONTINUE
64254 GOTO 630
64255 ENDIF
64256
64257C...Calculate maximum weight ND-particle decay.
64258 PV(ND,5)=P(N+ND,5)
64259 IF(ND.GE.3) THEN
64260 WTMAX=1D0/WTCOR(ND-2)
64261 PMAX=PV(1,5)-PS+P(N+ND,5)
64262 PMIN=0D0
64263 DO 380 IL=ND-1,1,-1
64264 PMAX=PMAX+P(N+IL,5)
64265 PMIN=PMIN+P(N+IL+1,5)
64266 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
64267 380 CONTINUE
64268 ENDIF
64269
64270C...Find virtual gamma mass in Dalitz decay.
64271 390 IF(ND.EQ.2) THEN
64272 ELSEIF(MMAT.EQ.2) THEN
64273 PMES=4D0*PMAS(11,1)**2
64274 PMRHO2=PMAS(131,1)**2
64275 PGRHO2=PMAS(131,2)**2
64276 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
64277 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
64278 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
64279 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
64280 IF(WT.LT.PYR(0)) GOTO 400
64281 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
64282
64283C...M-generator gives weight. If rejected, try again.
64284 ELSE
64285 410 RORD(1)=1D0
64286 DO 440 IL1=2,ND-1
64287 RSAV=PYR(0)
64288 DO 420 IL2=IL1-1,1,-1
64289 IF(RSAV.LE.RORD(IL2)) GOTO 430
64290 RORD(IL2+1)=RORD(IL2)
64291 420 CONTINUE
64292 430 RORD(IL2+1)=RSAV
64293 440 CONTINUE
64294 RORD(ND)=0D0
64295 WT=1D0
64296 DO 450 IL=ND-1,1,-1
64297 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
64298 & (PV(1,5)-PS)
64299 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64300 450 CONTINUE
64301 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
64302 ENDIF
64303
64304C...Perform two-particle decays in respective CM frame.
64305 460 DO 480 IL=1,ND-1
64306 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
64307 UE(3)=2D0*PYR(0)-1D0
64308 PHI=PARU(2)*PYR(0)
64309 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
64310 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
64311 DO 470 J=1,3
64312 P(N+IL,J)=PA*UE(J)
64313 PV(IL+1,J)=-PA*UE(J)
64314 470 CONTINUE
64315 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
64316 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
64317 480 CONTINUE
64318
64319C...Lorentz transform decay products to lab frame.
64320 DO 490 J=1,4
64321 P(N+ND,J)=PV(ND,J)
64322 490 CONTINUE
64323 DO 530 IL=ND-1,1,-1
64324 DO 500 J=1,3
64325 BE(J)=PV(IL,J)/PV(IL,4)
64326 500 CONTINUE
64327 GA=PV(IL,4)/PV(IL,5)
64328 DO 520 I=N+IL,N+ND
64329 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64330 DO 510 J=1,3
64331 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64332 510 CONTINUE
64333 P(I,4)=GA*(P(I,4)+BEP)
64334 520 CONTINUE
64335 530 CONTINUE
64336
64337C...Check that no infinite loop in matrix element weight.
64338 NTRY=NTRY+1
64339 IF(NTRY.GT.800) GOTO 560
64340
64341C...Matrix elements for omega and phi decays.
64342 IF(MMAT.EQ.1) THEN
64343 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
64344 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
64345 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
64346 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
64347
64348C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
64349 ELSEIF(MMAT.EQ.2) THEN
64350 FOUR12=FOUR(N+1,N+2)
64351 FOUR13=FOUR(N+1,N+3)
64352 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
64353 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
64354 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
64355
64356C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
64357C...V vector), of form cos**2(theta02) in V1 rest frame, and for
64358C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
64359 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
64360 FOUR10=FOUR(IP,IM)
64361 FOUR12=FOUR(IP,N+1)
64362 FOUR02=FOUR(IM,N+1)
64363 PMS1=P(IP,5)**2
64364 PMS0=P(IM,5)**2
64365 PMS2=P(N+1,5)**2
64366 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
64367 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
64368 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
64369 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
64370 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
64371 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
64372
64373C...Matrix element for "onium" -> g + g + g or gamma + g + g.
64374 ELSEIF(MMAT.EQ.4) THEN
64375 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64376 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
64377 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
64378 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
64379 & ((1D0-HX3)/(HX1*HX2))**2
64380 IF(WT.LT.2D0*PYR(0)) GOTO 390
64381 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
64382 & GOTO 390
64383
64384C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
64385 ELSEIF(MMAT.EQ.41) THEN
64386 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
64387 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
64388 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
64389 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
64390
64391C...Matrix elements for weak decays (only semileptonic for c and b)
64392 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64393 & .AND.ND.EQ.3) THEN
64394 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
64395 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
64396 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64397 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
64398 DO 550 J=1,4
64399 P(N+NP+1,J)=0D0
64400 DO 540 IS=N+3,N+NP
64401 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
64402 540 CONTINUE
64403 550 CONTINUE
64404 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
64405 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
64406 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
64407 ENDIF
64408
64409C...Scale back energy and reattach spectator.
64410 560 IF(MREM.EQ.1) THEN
64411 DO 570 J=1,5
64412 PV(1,J)=PV(1,J)/(1D0-PQT)
64413 570 CONTINUE
64414 ND=ND+1
64415 MREM=0
64416 ENDIF
64417
64418C...Low invariant mass for system with spectator quark gives particle,
64419C...not two jets. Readjust momenta accordingly.
64420 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
64421 MSTJ(93)=1
64422 PM2=PYMASS(K(N+2,2))
64423 MSTJ(93)=1
64424 PM3=PYMASS(K(N+3,2))
64425 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
64426 & (PARJ(32)+PM2+PM3)**2) GOTO 630
64427 K(N+2,1)=1
64428 KFTEMP=K(N+2,2)
64429 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
64430 IF(K(N+2,2).EQ.0) GOTO 260
64431 P(N+2,5)=PYMASS(K(N+2,2))
64432 PS=P(N+1,5)+P(N+2,5)
64433 PV(2,5)=P(N+2,5)
64434 MMAT=0
64435 ND=2
64436 GOTO 460
64437 ELSEIF(MMAT.EQ.44) THEN
64438 MSTJ(93)=1
64439 PM3=PYMASS(K(N+3,2))
64440 MSTJ(93)=1
64441 PM4=PYMASS(K(N+4,2))
64442 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
64443 & (PARJ(32)+PM3+PM4)**2) GOTO 600
64444 K(N+3,1)=1
64445 KFTEMP=K(N+3,2)
64446 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
64447 IF(K(N+3,2).EQ.0) GOTO 260
64448 P(N+3,5)=PYMASS(K(N+3,2))
64449 DO 580 J=1,3
64450 P(N+3,J)=P(N+3,J)+P(N+4,J)
64451 580 CONTINUE
64452 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)
64453 HA=P(N+1,4)**2-P(N+2,4)**2
64454 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
64455 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
64456 & (P(N+1,3)-P(N+2,3))**2
64457 HD=(PV(1,4)-P(N+3,4))**2
64458 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
64459 HF=HD*HC-HB**2
64460 HG=HD*HC-HA*HB
64461 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
64462 DO 590 J=1,3
64463 PCOR=HH*(P(N+1,J)-P(N+2,J))
64464 P(N+1,J)=P(N+1,J)+PCOR
64465 P(N+2,J)=P(N+2,J)-PCOR
64466 590 CONTINUE
64467 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)
64468 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)
64469 ND=ND-1
64470 ENDIF
64471
64472C...Check invariant mass of W jets. May give one particle or start over.
64473 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
64474 &.AND.IABS(K(N+1,2)).LT.10) THEN
64475 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
64476 MSTJ(93)=1
64477 PM1=PYMASS(K(N+1,2))
64478 MSTJ(93)=1
64479 PM2=PYMASS(K(N+2,2))
64480 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
64481 KFLDUM=INT(1.5D0+PYR(0))
64482 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
64483 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
64484 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
64485 PSM=PYMASS(KF1)+PYMASS(KF2)
64486 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
64487 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
64488 IF(MMAT.EQ.48) GOTO 390
64489 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
64490 K(N+1,1)=1
64491 KFTEMP=K(N+1,2)
64492 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
64493 IF(K(N+1,2).EQ.0) GOTO 260
64494 P(N+1,5)=PYMASS(K(N+1,2))
64495 K(N+2,2)=K(N+3,2)
64496 P(N+2,5)=P(N+3,5)
64497 PS=P(N+1,5)+P(N+2,5)
64498 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
64499 PV(2,5)=P(N+3,5)
64500 MMAT=0
64501 ND=2
64502 GOTO 460
64503 ENDIF
64504
64505C...Phase space decay of partons from W decay.
64506 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
64507 KFLO(1)=K(N+1,2)
64508 KFLO(2)=K(N+2,2)
64509 K(N+1,1)=K(N+3,1)
64510 K(N+1,2)=K(N+3,2)
64511 DO 620 J=1,5
64512 PV(1,J)=P(N+1,J)+P(N+2,J)
64513 P(N+1,J)=P(N+3,J)
64514 620 CONTINUE
64515 PV(1,5)=PMR
64516 N=N+1
64517 NP=0
64518 NQ=2
64519 PS=0D0
64520 MSTJ(93)=2
64521 PSQ=PYMASS(KFLO(1))
64522 MSTJ(93)=2
64523 PSQ=PSQ+PYMASS(KFLO(2))
64524 MMAT=11
64525 GOTO 290
64526 ENDIF
64527
64528C...Boost back for rapidly moving particle.
64529 630 N=N+ND
64530 IF(MBST.EQ.1) THEN
64531 DO 640 J=1,3
64532 BE(J)=P(IP,J)/P(IP,4)
64533 640 CONTINUE
64534 GA=P(IP,4)/P(IP,5)
64535 DO 660 I=NSAV+1,N
64536 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
64537 DO 650 J=1,3
64538 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
64539 650 CONTINUE
64540 P(I,4)=GA*(P(I,4)+BEP)
64541 660 CONTINUE
64542 ENDIF
64543
64544C...Fill in position of decay vertex.
64545 DO 680 I=NSAV+1,N
64546 DO 670 J=1,4
64547 V(I,J)=VDCY(J)
64548 670 CONTINUE
64549 V(I,5)=0D0
64550 680 CONTINUE
64551
64552C...Set up for parton shower evolution from jets.
64553 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
64554 K(NSAV+1,1)=3
64555 K(NSAV+2,1)=3
64556 K(NSAV+3,1)=3
64557 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64558 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64559 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64560 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64561 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64562 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64563 MSTJ(92)=-(NSAV+1)
64564 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
64565 K(NSAV+2,1)=3
64566 K(NSAV+3,1)=3
64567 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
64568 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
64569 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
64570 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
64571 MSTJ(92)=NSAV+2
64572 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64573 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
64574 K(NSAV+1,1)=3
64575 K(NSAV+2,1)=3
64576 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
64577 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
64578 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
64579 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
64580 MSTJ(92)=NSAV+1
64581 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
64582 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
64583 MSTJ(92)=NSAV+1
64584 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
64585 & THEN
64586 K(NSAV+1,1)=3
64587 K(NSAV+2,1)=3
64588 K(NSAV+3,1)=3
64589 KCP=PYCOMP(K(NSAV+1,2))
64590 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
64591 JCON=4
64592 IF(KQP.LT.0) JCON=5
64593 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
64594 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
64595 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
64596 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
64597 MSTJ(92)=NSAV+1
64598 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
64599 K(NSAV+1,1)=3
64600 K(NSAV+3,1)=3
64601 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
64602 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
64603 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
64604 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
64605 MSTJ(92)=NSAV+1
64606 ENDIF
64607
64608C...Mark decayed particle; special option for B-Bbar mixing.
64609 IF(K(IP,1).EQ.5) K(IP,1)=15
64610 IF(K(IP,1).LE.10) K(IP,1)=11
64611 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
64612 K(IP,4)=NSAV+1
64613 K(IP,5)=N
64614
64615 RETURN
64616 END
64617
64618
64619C*********************************************************************
64620
64621C...PYDCYK
64622C...Handles flavour production in the decay of unstable particles
64623C...and small string clusters.
64624
64625 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
64626
64627C...Double precision and integer declarations.
64628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64629 IMPLICIT INTEGER(I-N)
64630 INTEGER PYK,PYCHGE,PYCOMP
64631C...Commonblocks.
64632 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64633 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64634 SAVE /PYDAT1/,/PYDAT2/
64635
64636
64637C.. Call PYKFDI directly if no popcorn option is on
64638 IF(MSTJ(12).LT.2) THEN
64639 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64640 MSTU(124)=KFL3
64641 RETURN
64642 ENDIF
64643
64644 KFL3=0
64645 KF=0
64646 IF(KFL1.EQ.0) RETURN
64647 KF1A=IABS(KFL1)
64648 KF2A=IABS(KFL2)
64649
64650 NSTO=130
64651 NMAX=MIN(MSTU(125),10)
64652
64653C.. Identify rank 0 cluster qq
64654 IRANK=1
64655 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
64656
64657 IF(KF2A.GT.0)THEN
64658C.. Join jets: Fails if store not empty
64659 IF(MSTU(121).GT.0) THEN
64660 MSTU(121)=0
64661 RETURN
64662 ENDIF
64663 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
64664 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
64665C.. Pick popcorn meson from store, return same qq, decrease store
64666 KF=MSTU(NSTO+MSTU(121))
64667 KFL3=-KFL1
64668 MSTU(121)=MSTU(121)-1
64669 ELSE
64670C.. Generate new flavour. Then done if no diquark is generated
64671 100 CALL PYKFDI(KFL1,0,KFL3,KF)
64672 IF(MSTU(121).EQ.-1) GOTO 100
64673 MSTU(124)=KFL3
64674 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
64675
64676C.. Simple case if no dynamical popcorn suppressions are considered
64677 IF(MSTJ(12).LT.4) THEN
64678 IF(MSTU(121).EQ.0) RETURN
64679 NMES=1
64680 KFPREV=-KFL3
64681 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64682C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
64683 IF(IABS(KFL3).LE.10)THEN
64684 KFL3=-KFPREV
64685 RETURN
64686 ENDIF
64687 GOTO 120
64688 ENDIF
64689
64690C test output qq against fake Gamma, then return if no popcorn.
64691 GB=2D0
64692 IF(IRANK.NE.0)THEN
64693 CALL PYZDIS(1,2103,5D0,Z)
64694 GB=5D0*(1D0-Z)/Z
64695 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
64696 MSTU(121)=0
64697 GOTO 100
64698 ENDIF
64699 ENDIF
64700 IF(MSTU(121).EQ.0) RETURN
64701
64702C..Set store size memory. Pick fake dynamical variables of qq.
64703 NMES=MSTU(121)
64704 CALL PYPTDI(1,PX3,PY3)
64705 X=1D0
64706 POPM=0D0
64707 G=GB
64708 POPG=GB
64709
64710C.. Pick next popcorn meson, test with fake dynamical variables
64711 110 KFPREV=-KFL3
64712 PX1=-PX3
64713 PY1=-PY3
64714 CALL PYKFDI(KFPREV,0,KFL3,KFM)
64715 IF(MSTU(121).EQ.-1) GOTO 100
64716 CALL PYPTDI(KFL3,PX3,PY3)
64717 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
64718 CALL PYZDIS(KFPREV,KFL3,PM,Z)
64719 G=(1D0-Z)*(G+PM/Z)
64720 X=(1D0-Z)*X
64721
64722 PTST=1D0
64723 GTST=1D0
64724 RTST=PYR(0)
64725 IF(MSTJ(12).GT.4)THEN
64726 POPMN=SQRT((1D0-X)*(G/X-GB))
64727 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
64728 PTST=EXP((POPM-POPMN)*PARF(193))
64729 POPM=POPMN
64730 ENDIF
64731 IF(IRANK.NE.0)THEN
64732 POPGN=X*GB
64733 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
64734 POPG=POPGN
64735 ENDIF
64736 IF(RTST.GT.PTST*GTST)THEN
64737 MSTU(121)=0
64738 IF(RTST.GT.PTST) MSTU(121)=-1
64739 GOTO 100
64740 ENDIF
64741
64742C.. Store meson
64743 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
64744 IF(MSTU(121).GT.0) GOTO 110
64745
64746C.. Test accepted system size. If OK set global popcorn size variable.
64747 IF(NMES.GT.NMAX)THEN
64748 KF=0
64749 KFL3=0
64750 RETURN
64751 ENDIF
64752 MSTU(121)=NMES
64753 ENDIF
64754
64755 RETURN
64756 END
64757
64758C********************************************************************
64759
64760C...PYKFDI
64761C...Generates a new flavour pair and combines off a hadron
64762
64763 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
64764
64765C...Double precision and integer declarations.
64766 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64767 IMPLICIT INTEGER(I-N)
64768 INTEGER PYK,PYCHGE,PYCOMP
64769C...Commonblocks.
64770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64772 SAVE /PYDAT1/,/PYDAT2/
64773C...Local arrays.
64774 DIMENSION PD(7)
64775
64776 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
64777
64778C...Default flavour values. Input consistency checks.
64779 KF1A=IABS(KFL1)
64780 KF2A=IABS(KFL2)
64781 KFL3=0
64782 KF=0
64783 IF(KF1A.EQ.0) RETURN
64784 IF(KF2A.NE.0)THEN
64785 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
64786 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
64787 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
64788 ENDIF
64789
64790C...Check if tabulated flavour probabilities are to be used.
64791 IF(MSTJ(15).EQ.1) THEN
64792 IF(MSTJ(12).GE.5) CALL PYERRM(29,
64793 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
64794 & ' together with MSTJ(12)>=5 modification')
64795 KTAB1=-1
64796 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
64797 KFL1A=MOD(KF1A/1000,10)
64798 KFL1B=MOD(KF1A/100,10)
64799 KFL1S=MOD(KF1A,10)
64800 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
64801 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
64802 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
64803 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
64804 KTAB2=0
64805 IF(KF2A.NE.0) THEN
64806 KTAB2=-1
64807 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
64808 KFL2A=MOD(KF2A/1000,10)
64809 KFL2B=MOD(KF2A/100,10)
64810 KFL2S=MOD(KF2A,10)
64811 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
64812 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
64813 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
64814 ENDIF
64815 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
64816 ENDIF
64817
64818C.. Recognize rank 0 diquark case
64819 100 IRANK=1
64820 KFDIQ=MAX(KF1A,KF2A)
64821 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
64822
64823C.. Join two flavours to meson or baryon. Test for popcorn.
64824 IF(KF2A.GT.0)THEN
64825 MBARY=0
64826 IF(KFDIQ.GT.10) THEN
64827 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
64828 & CALL PYNMES(KFDIQ)
64829 IF(MSTU(121).NE.0) THEN
64830 MSTU(121)=0
64831 RETURN
64832 ENDIF
64833 MBARY=2
64834 ENDIF
64835 KFQOLD=KF1A
64836 KFQVER=KF2A
64837 GOTO 130
64838 ENDIF
64839
64840C.. Separate incoming flavours, curtain flavour consistency check
64841 KFIN=KFL1
64842 KFQOLD=KF1A
64843 KFQPOP=KF1A/10000
64844 IF(KF1A.GT.10)THEN
64845 KFIN=-KFL1
64846 KFL1A=MOD(KF1A/1000,10)
64847 KFL1B=MOD(KF1A/100,10)
64848 IF(IRANK.EQ.0)THEN
64849 QAWT=1D0
64850 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
64851 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
64852 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
64853 ENDIF
64854 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
64855 MSTU(121)=0
64856 RETURN
64857 ENDIF
64858 KFQOLD=KFL1A+KFL1B-KFQPOP
64859 ENDIF
64860
64861C...Meson/baryon choice. Set number of mesons if starting a popcorn
64862C...system.
64863 110 MBARY=0
64864 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
64865 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
64866 MBARY=1
64867 CALL PYNMES(0)
64868 ENDIF
64869 ELSEIF(KF1A.GT.10)THEN
64870 MBARY=2
64871 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
64872 IF(MSTU(121).GT.0) MBARY=-1
64873 ENDIF
64874
64875C..x->H+q: Choose single vertex quark. Jump to form hadron.
64876 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
64877 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
64878 KFL3=ISIGN(KFQVER,-KFIN)
64879 GOTO 130
64880 ENDIF
64881
64882C..x->H+qq: (IDW=proper PARF position for diquark weights)
64883 IDW=160
64884 IF(MBARY.EQ.1)THEN
64885 IF(MSTU(121).EQ.0) IDW=150
64886 SQWT=PARF(IDW+1)
64887 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
64888 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
64889C.. Shift to s-curtain parameters if needed
64890 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
64891 PARF(194)=PARF(138)*PARF(139)
64892 PARF(193)=PARJ(8)+PARJ(9)
64893 ENDIF
64894 ENDIF
64895
64896C.. x->H+qq: Get vertex quark
64897 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64898 IDW=MSTU(122)
64899 MSTU(121)=MSTU(121)-1
64900 IF(IDW.EQ.170) THEN
64901 IF(MSTU(121).EQ.0)THEN
64902 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
64903 ELSE
64904 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
64905 ENDIF
64906 ELSE
64907 IF(MSTU(121).EQ.0)THEN
64908 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
64909 ELSE
64910 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
64911 ENDIF
64912 ENDIF
64913 IPOS=200+30*IPOS+1
64914
64915 IMES=-1
64916 RMES=PYR(0)*PARF(194)
64917 120 IMES=IMES+1
64918 RMES=RMES-PARF(IPOS+IMES)
64919 IF(IMES.EQ.30) THEN
64920 MSTU(121)=-1
64921 KF=-111
64922 RETURN
64923 ENDIF
64924 IF(RMES.GT.0D0) GOTO 120
64925 KMUL=IMES/5
64926 KFJ=2*KMUL+1
64927 IF(KMUL.EQ.2) KFJ=10003
64928 IF(KMUL.EQ.3) KFJ=10001
64929 IF(KMUL.EQ.4) KFJ=20003
64930 IF(KMUL.EQ.5) KFJ=5
64931 IDIAG=0
64932 KFQVER=MOD(IMES,5)+1
64933 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
64934 IF(KFQVER.GT.3)THEN
64935 IDIAG=KFQVER-3
64936 KFQVER=KFQOLD
64937 ENDIF
64938 ELSE
64939 IF(MBARY.EQ.-1) IDW=170
64940 SQWT=PARF(IDW+2)
64941 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
64942 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
64943 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
64944 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
64945 KFQVER=KFQPOP
64946 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
64947 ENDIF
64948 ENDIF
64949
64950C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
64951 KFLDS=3
64952 IF(KFQPOP.NE.KFQVER)THEN
64953 SWT=PARF(IDW+7)
64954 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
64955 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
64956 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
64957 ENDIF
64958 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
64959 & +10000*KFQPOP
64960 KFL3=ISIGN(KFDIQ,KFIN)
64961
64962C..x->M+y: flavour for meson.
64963 130 IF(MBARY.LE.0)THEN
64964 KFLA=MAX(KFQOLD,KFQVER)
64965 KFLB=MIN(KFQOLD,KFQVER)
64966 KFS=ISIGN(1,KFL1)
64967 IF(KFLA.NE.KFQOLD) KFS=-KFS
64968C... Form meson, with spin and flavour mixing for diagonal states.
64969 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
64970 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
64971 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
64972 RETURN
64973 ENDIF
64974 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
64975 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
64976 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
64977 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
64978 IF(PYR(0).LT.PARJ(14)) KMUL=2
64979 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
64980 RMUL=PYR(0)
64981 IF(RMUL.LT.PARJ(15)) KMUL=3
64982 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
64983 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
64984 ENDIF
64985 KFLS=3
64986 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
64987 IF(KMUL.EQ.5) KFLS=5
64988 IF(KFLA.NE.KFLB)THEN
64989 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
64990 ELSE
64991 RMIX=PYR(0)
64992 IMIX=2*KFLA+10*KMUL
64993 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
64994 & INT(RMIX+PARF(IMIX)))+KFLS
64995 IF(KFLA.GE.4) KF=110*KFLA+KFLS
64996 ENDIF
64997 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
64998 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
64999
65000C..Optional extra suppression of eta and eta'.
65001C..Allow shift to qq->B+q in old version (set IRANK to 0)
65002 IF(KF.EQ.221.OR.KF.EQ.331)THEN
65003 IF(PYR(0).GT.PARJ(25+KF/300))THEN
65004 IF(KF2A.GT.0) GOTO 130
65005 IF(MSTJ(12).LT.4) IRANK=0
65006 GOTO 110
65007 ENDIF
65008 ENDIF
65009 MSTU(121)=0
65010
65011C.. x->B+y: Flavour for baryon
65012 ELSE
65013 KFLA=KFQVER
65014 IF(KF1A.LE.10) KFLA=KFQOLD
65015 KFLB=MOD(KFDIQ/1000,10)
65016 KFLC=MOD(KFDIQ/100,10)
65017 KFLDS=MOD(KFDIQ,10)
65018 KFLD=MAX(KFLA,KFLB,KFLC)
65019 KFLF=MIN(KFLA,KFLB,KFLC)
65020 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65021
65022C... SU(6) factors for formation of baryon.
65023 KBARY=3
65024 KDMAX=5
65025 KFLG=KFLB
65026 IF(KFLB.NE.KFLC)THEN
65027 KBARY=2*KFLDS-1
65028 KDMAX=1+KFLDS/2
65029 IF(KFLB.GT.2) KDMAX=KDMAX+2
65030 ENDIF
65031 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
65032 KBARY=KBARY+1
65033 KFLG=KFLA
65034 ENDIF
65035
65036 SU6MAX=PARF(140+KDMAX)
65037 SU6DEC=PARJ(18)
65038 SU6S =PARF(146)
65039 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
65040 SU6MAX=1D0
65041 SU6DEC=1D0
65042 SU6S =1D0
65043 ENDIF
65044 SU6OCT=PARF(60+KBARY)
65045 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
65046 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
65047 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
65048 ELSE
65049 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
65050 ENDIF
65051 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
65052
65053C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
65054 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
65055 MSTU(121)=0
65056 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
65057 GOTO 110
65058 ENDIF
65059
65060C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
65061 KSIG=1
65062 KFLS=2
65063 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
65064 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
65065 KSIG=KFLDS/3
65066 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
65067 ENDIF
65068 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
65069 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
65070 ENDIF
65071 RETURN
65072
65073C...Use tabulated probabilities to select new flavour and hadron.
65074 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
65075 KT3L=1
65076 KT3U=6
65077 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
65078 KT3L=1
65079 KT3U=6
65080 ELSEIF(KTAB2.EQ.0) THEN
65081 KT3L=1
65082 KT3U=22
65083 ELSE
65084 KT3L=KTAB2
65085 KT3U=KTAB2
65086 ENDIF
65087 RFL=0D0
65088 DO 160 KTS=0,2
65089 DO 150 KT3=KT3L,KT3U
65090 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
65091 150 CONTINUE
65092 160 CONTINUE
65093 RFL=PYR(0)*RFL
65094 DO 180 KTS=0,2
65095 KTABS=KTS
65096 DO 170 KT3=KT3L,KT3U
65097 KTAB3=KT3
65098 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
65099 IF(RFL.LE.0D0) GOTO 190
65100 170 CONTINUE
65101 180 CONTINUE
65102 190 CONTINUE
65103
65104C...Reconstruct flavour of produced quark/diquark.
65105 IF(KTAB3.LE.6) THEN
65106 KFL3A=KTAB3
65107 KFL3B=0
65108 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
65109 ELSE
65110 KFL3A=1
65111 IF(KTAB3.GE.8) KFL3A=2
65112 IF(KTAB3.GE.11) KFL3A=3
65113 IF(KTAB3.GE.16) KFL3A=4
65114 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
65115 KFL3=1000*KFL3A+100*KFL3B+1
65116 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
65117 & KFL3+2
65118 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
65119 ENDIF
65120
65121C...Reconstruct meson code.
65122 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
65123 &KFL3B.NE.0)) THEN
65124 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65125 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
65126 KF=110+2*KTABS+1
65127 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
65128 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
65129 & 25*KTABS)) KF=330+2*KTABS+1
65130 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
65131 KFLA=MAX(KTAB1,KTAB3)
65132 KFLB=MIN(KTAB1,KTAB3)
65133 KFS=ISIGN(1,KFL1)
65134 IF(KFLA.NE.KF1A) KFS=-KFS
65135 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65136 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
65137 KFS=ISIGN(1,KFL1)
65138 IF(KFL1A.EQ.KFL3A) THEN
65139 KFLA=MAX(KFL1B,KFL3B)
65140 KFLB=MIN(KFL1B,KFL3B)
65141 IF(KFLA.NE.KFL1B) KFS=-KFS
65142 ELSEIF(KFL1A.EQ.KFL3B) THEN
65143 KFLA=KFL3A
65144 KFLB=KFL1B
65145 KFS=-KFS
65146 ELSEIF(KFL1B.EQ.KFL3A) THEN
65147 KFLA=KFL1A
65148 KFLB=KFL3B
65149 ELSEIF(KFL1B.EQ.KFL3B) THEN
65150 KFLA=MAX(KFL1A,KFL3A)
65151 KFLB=MIN(KFL1A,KFL3A)
65152 IF(KFLA.NE.KFL1A) KFS=-KFS
65153 ELSE
65154 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
65155 GOTO 100
65156 ENDIF
65157 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
65158
65159C...Reconstruct baryon code.
65160 ELSE
65161 IF(KTAB1.GE.7) THEN
65162 KFLA=KFL3A
65163 KFLB=KFL1A
65164 KFLC=KFL1B
65165 ELSE
65166 KFLA=KFL1A
65167 KFLB=KFL3A
65168 KFLC=KFL3B
65169 ENDIF
65170 KFLD=MAX(KFLA,KFLB,KFLC)
65171 KFLF=MIN(KFLA,KFLB,KFLC)
65172 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
65173 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
65174 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
65175 ENDIF
65176
65177C...Check that constructed flavour code is an allowed one.
65178 IF(KFL2.NE.0) KFL3=0
65179 KC=PYCOMP(KF)
65180 IF(KC.EQ.0) THEN
65181 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
65182 & 'failed')
65183 GOTO 100
65184 ENDIF
65185
65186 RETURN
65187 END
65188
65189C*********************************************************************
65190
65191C...PYNMES
65192C...Generates number of popcorn mesons and stores some relevant
65193C...parameters.
65194
65195 SUBROUTINE PYNMES(KFDIQ)
65196
65197C...Double precision and integer declarations.
65198 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65199 IMPLICIT INTEGER(I-N)
65200 INTEGER PYK,PYCHGE,PYCOMP
65201C...Commonblocks.
65202 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65203 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65204 SAVE /PYDAT1/,/PYDAT2/
65205
65206 MSTU(121)=0
65207 IF(MSTJ(12).LT.2) RETURN
65208
65209C..Old version: Get 1 or 0 popcorn mesons
65210 IF(MSTJ(12).LT.5)THEN
65211 POPWT=PARF(131)
65212 IF(KFDIQ.NE.0) THEN
65213 KFDIQA=IABS(KFDIQ)
65214 KFA=MOD(KFDIQA/1000,10)
65215 KFB=MOD(KFDIQA/100,10)
65216 KFS=MOD(KFDIQA,10)
65217 POPWT=PARF(132)
65218 IF(KFA.EQ.3) POPWT=PARF(133)
65219 IF(KFB.EQ.3) POPWT=PARF(134)
65220 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
65221 ENDIF
65222 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
65223 RETURN
65224 ENDIF
65225
65226C..New version: Store popcorn- or rank 0 diquark parameters
65227 MSTU(122)=170
65228 PARF(193)=PARJ(8)
65229 PARF(194)=PARF(139)
65230 IF(KFDIQ.NE.0) THEN
65231 MSTU(122)=180
65232 PARF(193)=PARJ(10)
65233 PARF(194)=PARF(140)
65234 ENDIF
65235 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
65236 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
65237 & '(PYNMES:) Neglecting too large popcorn possibility')
65238 RETURN
65239 ENDIF
65240
65241C..New version: Get number of popcorn mesons
65242 100 RTST=PYR(0)
65243 MSTU(121)=-1
65244 110 MSTU(121)=MSTU(121)+1
65245 RTST=RTST/PARF(194)
65246 IF(RTST.LT.1D0) GOTO 110
65247 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
65248 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
65249 RETURN
65250 END
65251
65252C***************************************************************
65253
65254C...PYKFIN
65255C...Precalculates a set of diquark and popcorn weights.
65256
65257 SUBROUTINE PYKFIN
65258
65259C...Double precision and integer declarations.
65260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65261 IMPLICIT INTEGER(I-N)
65262 INTEGER PYK,PYCHGE,PYCOMP
65263C...Commonblocks.
65264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65265 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65266 SAVE /PYDAT1/,/PYDAT2/
65267
65268 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
65269
65270
65271 MSTU(123)=1
65272C..Diquark indices for dimensional variables
65273 IUD1=1
65274 IUU1=2
65275 IUS0=3
65276 ISU0=4
65277 IUS1=5
65278 ISU1=6
65279 ISS1=7
65280
65281C.. *** SU(6) factors **
65282C..Modify with decuplet- (and Sigma/Lambda-) suppression.
65283 PARF(146)=1D0
65284 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
65285 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
65286 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
65287 DO 100 I=1,6
65288 SU6(I)=PARF(60+I)
65289 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
65290 100 CONTINUE
65291 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
65292 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
65293 DO 110 I=1,6
65294 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
65295 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
65296 110 CONTINUE
65297
65298C..SU(6)max q q' s,c,b
65299 SU6MUD =MAX(SU6(1) , SU6(8) )
65300 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
65301 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
65302 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
65303 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
65304 SU6M(IUS0)=SU6M(ISU0)
65305 SU6M(ISS1)=SU6M(IUU1)
65306 SU6M(IUS1)=SU6M(ISU1)
65307
65308C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
65309 PARF(141)=SU6MUD
65310 PARF(142)=SU6M(IUD1)
65311 PARF(143)=SU6M(ISU0)
65312 PARF(144)=SU6M(ISU1)
65313 PARF(145)=SU6M(ISS1)
65314
65315C..diquark SU(6) survival =
65316C..sum over quark (quark tunnel weight)*(SU(6)).
65317 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
65318 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
65319 DMB(IUS0)=DMB(ISU0)
65320 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
65321 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
65322 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
65323 DMB(IUS1)=DMB(ISU1)
65324 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
65325
65326C.. *** Tunneling factors for Diquark production***
65327C.. T: half a curtain pair = sqrt(curtain pair factor)
65328 IF(MSTJ(12).GE.5) THEN
65329 PMUD0=PYMASS(2101)
65330 PMUD1=PYMASS(2103)-PMUD0
65331 PMUS0=PYMASS(3201)-PMUD0
65332 PMUS1=PYMASS(3203)-PMUS0-PMUD0
65333 PMSS1=PYMASS(3303)-PMUS0-PMUD0
65334 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
65335 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
65336 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
65337 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
65338 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
65339 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
65340 QBB(IUD1)=QBB(IUU1)
65341 ELSE
65342 PAR2M=SQRT(PARJ(2))
65343 PAR3M=SQRT(PARJ(3))
65344 PAR4M=SQRT(PARJ(4))
65345 QBB(ISU0)=PAR2M*PAR3M
65346 QBB(IUS0)=PAR3M
65347 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
65348 QBB(IUU1)=PAR4M
65349 QBB(ISU1)=PAR4M*QBB(ISU0)
65350 QBB(IUS1)=PAR4M*QBB(IUS0)
65351 QBB(IUD1)=PAR4M
65352 ENDIF
65353
65354C.. tau: spin*(vertex factor)*(T = half-curtain factor)
65355 QBM(ISU0)=QBB(ISU0)
65356 QBM(IUS0)=PARJ(2)*QBB(IUS0)
65357 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
65358 QBM(IUU1)=6D0*QBB(IUU1)
65359 QBM(ISU1)=3D0*QBB(ISU1)
65360 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
65361 QBM(IUD1)=3D0*QBB(IUD1)
65362
65363C.. Combine T and tau to diquark weight for q-> B+B+..
65364 DO 120 I=1,7
65365 QBB(I)=QBB(I)*QBM(I)
65366 120 CONTINUE
65367
65368 IF(MSTJ(12).GE.5)THEN
65369C..New version: tau for rank 0 diquark.
65370 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
65371 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
65372 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
65373 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
65374 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
65375 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
65376 DMB(7+IUD1)=DMB(7+IUU1)/2D0
65377
65378C..New version: curtain flavour ratios.
65379C.. s/u for q->B+M+...
65380C.. s/u for rank 0 diquark: su -> ...M+B+...
65381C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65382 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65383 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65384 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
65385 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
65386 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
65387 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
65388 ELSE
65389C..Old version: reset unused rank 0 diquark weights and
65390C.. unused diquark SU(6) survival weights
65391 DO 130 I=1,7
65392 IF(MSTJ(12).LT.3) DMB(I)=1D0
65393 DMB(7+I)=1D0
65394 130 CONTINUE
65395
65396C..Old version: Shuffle PARJ(7) into tau
65397 QBM(IUS0)=QBM(IUS0)*PARJ(7)
65398 QBM(ISS1)=QBM(ISS1)*PARJ(7)
65399 QBM(IUS1)=QBM(IUS1)*PARJ(7)
65400
65401C..Old version: curtain flavour ratios.
65402C.. s/u for q->B+M+...
65403C.. s/u for rank 0 diquark: su -> ...M+B+...
65404C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
65405 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
65406 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
65407 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
65408 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
65409 ENDIF
65410
65411C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
65412C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
65413 DO 140 I=1,7
65414 DMB(7+I)=DMB(7+I)*DMB(I)
65415 DMB(I)=DMB(I)*QBM(I)
65416 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
65417 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
65418 140 CONTINUE
65419
65420C.. *** Popcorn factors ***
65421
65422 IF(MSTJ(12).LT.5)THEN
65423C.. Old version: Resulting popcorn weights.
65424 PARF(138)=PARJ(6)
65425 WS=PARF(135)*PARF(138)
65426 WQ=WU*PARJ(5)/3D0
65427 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
65428 PARF(133)=WQ*
65429 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
65430 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
65431 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
65432 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
65433 & (1D0+QBB(IUD1)+QBB(IUU1)+
65434 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
65435 ELSE
65436C..New version: Store weights for popcorn mesons,
65437C..get prel. popcorn weights.
65438 DO 150 IPOS=201,1400
65439 PARF(IPOS)=0D0
65440 150 CONTINUE
65441 DO 160 I=138,140
65442 PARF(I)=0D0
65443 160 CONTINUE
65444 IPOS=200
65445 PARF(193)=PARJ(8)
65446 DO 240 MR=0,7,7
65447 IF(MR.EQ.7) PARF(193)=PARJ(10)
65448 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
65449 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65450 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
65451 DO 230 NMES=0,1
65452 IF(NMES.EQ.1) SQWT=PARJ(2)
65453 DO 220 KFQPOP=1,4
65454 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
65455 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
65456 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
65457 QQWT=0.5D0
65458 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
65459 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
65460 ENDIF
65461 DO 210 KFQOLD =1,5
65462 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
65463 IF(NMES.EQ.1) THEN
65464 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
65465 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
65466 ENDIF
65467 WTTOT=0D0
65468 WTFAIL=0D0
65469 DO 190 KMUL=0,5
65470 PJWT=PARJ(12+KMUL)
65471 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
65472 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
65473 IF(PJWT.LE.0D0) GOTO 190
65474 IF(PJWT.GT.1D0) PJWT=1D0
65475 IMES=5*KMUL
65476 IMIX=2*KFQOLD+10*KMUL
65477 KFJ=2*KMUL+1
65478 IF(KMUL.EQ.2) KFJ=10003
65479 IF(KMUL.EQ.3) KFJ=10001
65480 IF(KMUL.EQ.4) KFJ=20003
65481 IF(KMUL.EQ.5) KFJ=5
65482 DO 180 KFQVER =1,3
65483 KFLA=MAX(KFQOLD,KFQVER)
65484 KFLB=MIN(KFQOLD,KFQVER)
65485 SWT=PARJ(11+KFLA/3+KFLA/4)
65486 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
65487 SWT=SWT*PJWT
65488 QWT=SQWT/(2D0+SQWT)
65489 IF(KFQVER.LT.3)THEN
65490 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
65491 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
65492 ENDIF
65493 IF(KFQVER.NE.KFQOLD)THEN
65494 IMES=IMES+1
65495 KFM=100*KFLA+10*KFLB+KFJ
65496 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65497 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
65498 WTTOT=WTTOT+PARF(IPOS+IMES)
65499 ELSE
65500 DO 170 ID=3,5
65501 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
65502 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
65503 IF(ID.EQ.5) DWT=PARF(IMIX)
65504 KFM=110*(ID-2)+KFJ
65505 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
65506 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
65507 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
65508 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
65509 PARF(IPOS+5*KMUL+ID)=
65510 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
65511 ENDIF
65512 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
65513 170 CONTINUE
65514 ENDIF
65515 180 CONTINUE
65516 190 CONTINUE
65517 DO 200 IMES=1,30
65518 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
65519 200 CONTINUE
65520 IF(MR.EQ.7) PARF(140)=
65521 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
65522 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
65523 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
65524 IPOS=IPOS+30
65525 210 CONTINUE
65526 220 CONTINUE
65527 230 CONTINUE
65528 240 CONTINUE
65529 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
65530 MSTU(121)=0
65531
65532 ENDIF
65533
65534C..Recombine diquark weights to flavour and spin ratios
65535 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
65536 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
65537 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
65538 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
65539 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
65540 PARF(155)=QBB(ISU1)/QBB(ISU0)
65541 PARF(156)=QBB(IUS1)/QBB(IUS0)
65542 PARF(157)=QBB(IUD1)
65543
65544 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
65545 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
65546 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
65547 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
65548 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
65549 PARF(165)=QBM(ISU1)/QBM(ISU0)
65550 PARF(166)=QBM(IUS1)/QBM(IUS0)
65551 PARF(167)=QBM(IUD1)
65552
65553 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
65554 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
65555 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
65556 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
65557 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
65558 PARF(175)=DMB(ISU1)/DMB(ISU0)
65559 PARF(176)=DMB(IUS1)/DMB(IUS0)
65560 PARF(177)=DMB(IUD1)
65561
65562 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
65563 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
65564 PARF(187)=DMB(7+IUD1)
65565
65566 RETURN
65567 END
65568
65569
65570C*********************************************************************
65571
65572C...PYPTDI
65573C...Generates transverse momentum according to a Gaussian.
65574
65575 SUBROUTINE PYPTDI(KFL,PX,PY)
65576
65577C...Double precision and integer declarations.
65578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65579 IMPLICIT INTEGER(I-N)
65580 INTEGER PYK,PYCHGE,PYCOMP
65581C...Commonblocks.
65582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65583 SAVE /PYDAT1/
65584
65585C...Generate p_T and azimuthal angle, gives p_x and p_y.
65586 KFLA=IABS(KFL)
65587 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
65588 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
65589 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
65590 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
65591 PHI=PARU(2)*PYR(0)
65592 PX=PT*COS(PHI)
65593 PY=PT*SIN(PHI)
65594
65595 RETURN
65596 END
65597
65598C*********************************************************************
65599
65600C...PYZDIS
65601C...Generates the longitudinal splitting variable z.
65602
65603 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
65604
65605C...Double precision and integer declarations.
65606 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65607 IMPLICIT INTEGER(I-N)
65608 INTEGER PYK,PYCHGE,PYCOMP
65609C...Commonblocks.
65610 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65611 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65612 SAVE /PYDAT1/,/PYDAT2/
65613
65614C...Check if heavy flavour fragmentation.
65615 KFLA=IABS(KFL1)
65616 KFLB=IABS(KFL2)
65617 KFLH=KFLA
65618 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
65619
65620C...Lund symmetric scaling function: determine parameters of shape.
65621 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
65622 &MSTJ(11).GE.4) THEN
65623 FA=PARJ(41)
65624 IF(MSTJ(91).EQ.1) FA=PARJ(43)
65625 IF(KFLB.GE.10) FA=FA+PARJ(45)
65626 FBB=PARJ(42)
65627 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
65628 FB=FBB*PR
65629 FC=1D0
65630 IF(KFLA.GE.10) FC=FC-PARJ(45)
65631 IF(KFLB.GE.10) FC=FC+PARJ(45)
65632 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
65633 FRED=PARJ(46)
65634 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
65635 FC=FC+FRED*FBB*PARF(100+KFLH)**2
65636 ENDIF
65637 MC=1
65638 IF(ABS(FC-1D0).GT.0.01D0) MC=2
65639
65640C...Determine position of maximum. Special cases for a = 0 or a = c.
65641 IF(FA.LT.0.02D0) THEN
65642 MA=1
65643 ZMAX=1D0
65644 IF(FC.GT.FB) ZMAX=FB/FC
65645 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
65646 MA=2
65647 ZMAX=FB/(FB+FC)
65648 ELSE
65649 MA=3
65650 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
65651 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
65652 ENDIF
65653
65654C...Subdivide z range if distribution very peaked near endpoint.
65655 MMAX=2
65656 IF(ZMAX.LT.0.1D0) THEN
65657 MMAX=1
65658 ZDIV=2.75D0*ZMAX
65659 IF(MC.EQ.1) THEN
65660 FINT=1D0-LOG(ZDIV)
65661 ELSE
65662 ZDIVC=ZDIV**(1D0-FC)
65663 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
65664 ENDIF
65665 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
65666 MMAX=3
65667 FSCB=SQRT(4D0+(FC/FB)**2)
65668 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
65669 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
65670 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
65671 FINT=1D0+FB*(1D0-ZDIV)
65672 ENDIF
65673
65674C...Choice of z, preweighted for peaks at low or high z.
65675 100 Z=PYR(0)
65676 FPRE=1D0
65677 IF(MMAX.EQ.1) THEN
65678 IF(FINT*PYR(0).LE.1D0) THEN
65679 Z=ZDIV*Z
65680 ELSEIF(MC.EQ.1) THEN
65681 Z=ZDIV**Z
65682 FPRE=ZDIV/Z
65683 ELSE
65684 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
65685 FPRE=(ZDIV/Z)**FC
65686 ENDIF
65687 ELSEIF(MMAX.EQ.3) THEN
65688 IF(FINT*PYR(0).LE.1D0) THEN
65689 Z=ZDIV+LOG(Z)/FB
65690 FPRE=EXP(FB*(Z-ZDIV))
65691 ELSE
65692 Z=ZDIV+Z*(1D0-ZDIV)
65693 ENDIF
65694 ENDIF
65695
65696C...Weighting according to correct formula.
65697 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
65698 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
65699 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
65700 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
65701 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
65702
65703C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
65704 ELSE
65705 FC=PARJ(50+MAX(1,KFLH))
65706 IF(MSTJ(91).EQ.1) FC=PARJ(59)
65707 110 Z=PYR(0)
65708 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
65709 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
65710 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
65711 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
65712 & GOTO 110
65713 ELSE
65714 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
65715 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
65716 ENDIF
65717 ENDIF
65718
65719 RETURN
65720 END
65721
65722C*********************************************************************
65723
65724C...PYSHOW
65725C...Generates timelike parton showers from given partons.
65726
65727 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
65728
65729C...Double precision and integer declarations.
65730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65731 IMPLICIT INTEGER(I-N)
65732 INTEGER PYK,PYCHGE,PYCOMP
65733C...Parameter statement to help give large particle numbers.
65734 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
65735 &KEXCIT=4000000,KDIMEN=5000000)
65736 PARAMETER (MAXNUR=1000)
65737C...Commonblocks.
65738 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
65739 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65740 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65741 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65742 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
65743 COMMON/PYINT1/MINT(400),VINT(400)
65744 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
65745C...Local arrays.
65746 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
65747 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
65748 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
65749 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
65750 &IREF(1000)
65751
65752C...Check that QMAX not too low.
65753 IF(MSTJ(41).LE.0) THEN
65754 RETURN
65755 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
65756 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
65757 ELSE
65758 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
65759 & RETURN
65760 ENDIF
65761
65762C...Store positions of shower initiating partons.
65763 MPSPD=0
65764 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
65765 NPA=1
65766 IPA(1)=IP1
65767 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
65768 & MSTU(32))) THEN
65769 NPA=2
65770 IPA(1)=IP1
65771 IPA(2)=IP2
65772 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
65773 & .AND.IP2.GE.-80) THEN
65774 NPA=IABS(IP2)
65775 DO 100 I=1,NPA
65776 IPA(I)=IP1+I-1
65777 100 CONTINUE
65778 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
65779 &IP2.EQ.-100) THEN
65780 MPSPD=1
65781 NPA=2
65782 IPA(1)=IP1+6
65783 IPA(2)=IP1+7
65784 ELSE
65785 CALL PYERRM(12,
65786 & '(PYSHOW:) failed to reconstruct showering system')
65787 IF(MSTU(21).GE.1) RETURN
65788 ENDIF
65789
65790C...Send off to PYPTFS for pT-ordered evolution if requested,
65791C...if at least 2 partons, and without predefined shower branchings.
65792 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
65793 &MPSPD.EQ.0) THEN
65794 NPART=NPA
65795 DO 110 II=1,NPART
65796 IPART(II)=IPA(II)
65797 PTPART(II)=0.5D0*QMAX
65798 110 CONTINUE
65799 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
65800 RETURN
65801 ENDIF
65802
65803C...Initialization of cutoff masses etc.
65804 DO 120 IFL=0,40
65805 ISCOL(IFL)=0
65806 ISCHG(IFL)=0
65807 KSH(IFL)=0
65808 120 CONTINUE
65809 ISCOL(21)=1
65810 KSH(21)=1
65811 PMTH(1,21)=PYMASS(21)
65812 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
65813 PMTH(3,21)=2D0*PMTH(2,21)
65814 PMTH(4,21)=PMTH(3,21)
65815 PMTH(5,21)=PMTH(3,21)
65816 PMTH(1,22)=PYMASS(22)
65817 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
65818 PMTH(3,22)=2D0*PMTH(2,22)
65819 PMTH(4,22)=PMTH(3,22)
65820 PMTH(5,22)=PMTH(3,22)
65821 PMQTH1=PARJ(82)
65822 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
65823 PMQT1E=MIN(PMQTH1,PARJ(90))
65824 PMQTH2=PMTH(2,21)
65825 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
65826 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
65827 DO 130 IFL=1,5
65828 ISCOL(IFL)=1
65829 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
65830 KSH(IFL)=1
65831 PMTH(1,IFL)=PYMASS(IFL)
65832 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
65833 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
65834 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65835 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65836 130 CONTINUE
65837 DO 140 IFL=11,15,2
65838 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
65839 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
65840 PMTH(1,IFL)=PYMASS(IFL)
65841 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
65842 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
65843 PMTH(4,IFL)=PMTH(3,IFL)
65844 PMTH(5,IFL)=PMTH(3,IFL)
65845 140 CONTINUE
65846 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
65847 ALAMS=PARJ(81)**2
65848 ALFM=LOG(PT2MIN/ALAMS)
65849
65850C...Check on phase space available for emission.
65851 IREJ=0
65852 DO 150 J=1,5
65853 PS(J)=0D0
65854 150 CONTINUE
65855 PM=0D0
65856 KFLA(2)=0
65857 DO 170 I=1,NPA
65858 KFLA(I)=IABS(K(IPA(I),2))
65859 PMA(I)=P(IPA(I),5)
65860C...Special cutoff masses for initial partons (may be a heavy quark,
65861C...squark, ..., and need not be on the mass shell).
65862 IR=30+I
65863 IF(NPA.LE.1) IREF(I)=IR
65864 IF(NPA.GE.2) IREF(I+1)=IR
65865 ISCOL(IR)=0
65866 ISCHG(IR)=0
65867 KSH(IR)=0
65868 IF(KFLA(I).LE.8) THEN
65869 ISCOL(IR)=1
65870 IF(MSTJ(41).GE.2) ISCHG(IR)=1
65871 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
65872 & KFLA(I).EQ.17) THEN
65873 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
65874 ELSEIF(KFLA(I).EQ.21) THEN
65875 ISCOL(IR)=1
65876 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
65877 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
65878 ISCOL(IR)=1
65879 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
65880 ISCOL(IR)=1
65881C...QUARKONIA+++
65882C...same for QQ~[3S18]
65883 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
65884 & KFLA(I).EQ.9900553)) THEN
65885 ISCOL(IR)=1
65886C...QUARKONIA---
65887 ENDIF
65888 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
65889 PMTH(1,IR)=PMA(I)
65890 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
65891 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
65892 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
65893 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
65894 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
65895 ELSEIF(ISCOL(IR).EQ.1) THEN
65896 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
65897 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
65898 PMTH(4,IR)=PMTH(3,IR)
65899 PMTH(5,IR)=PMTH(3,IR)
65900 ELSEIF(ISCHG(IR).EQ.1) THEN
65901 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
65902 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
65903 PMTH(4,IR)=PMTH(3,IR)
65904 PMTH(5,IR)=PMTH(3,IR)
65905 ENDIF
65906 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
65907 PM=PM+PMA(I)
65908 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
65909 DO 160 J=1,4
65910 PS(J)=PS(J)+P(IPA(I),J)
65911 160 CONTINUE
65912 170 CONTINUE
65913 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
65914 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
65915 IF(NPA.EQ.1) PS(5)=PS(4)
65916 IF(PS(5).LE.PM+PMQT1E) RETURN
65917
65918C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
65919 KFSRCE=0
65920 IF(IP2.LE.0) THEN
65921 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
65922 KFSRCE=IABS(K(K(IP1,3),2))
65923 ELSE
65924 IPAR1=MAX(1,K(IP1,3))
65925 IPAR2=MAX(1,K(IP2,3))
65926 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
65927 & KFSRCE=IABS(K(K(IPAR1,3),2))
65928 ENDIF
65929 ITYPES=0
65930 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
65931 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
65932 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
65933 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
65934 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
65935 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
65936 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
65937 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
65938
65939C...Identify two primary showerers.
65940 ITYPE1=0
65941 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
65942 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
65943 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
65944 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
65945 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
65946 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
65947 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
65948 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
65949 ITYPE2=0
65950 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
65951 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
65952 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
65953 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
65954 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
65955 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
65956 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
65957 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
65958
65959C...Order of showerers. Presence of gluino.
65960 ITYPMN=MIN(ITYPE1,ITYPE2)
65961 ITYPMX=MAX(ITYPE1,ITYPE2)
65962 IORD=1
65963 IF(ITYPE1.GT.ITYPE2) IORD=2
65964 IGLUI=0
65965 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
65966
65967C...Check if 3-jet matrix elements to be used.
65968 M3JC=0
65969 ALPHA=0.5D0
65970 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
65971 IF(MSTJ(38).NE.0) THEN
65972 M3JC=MSTJ(38)
65973 ALPHA=PARJ(80)
65974 MSTJ(38)=0
65975 ELSEIF(MSTJ(47).GE.6) THEN
65976 M3JC=MSTJ(47)
65977 ELSE
65978 ICLASS=1
65979 ICOMBI=4
65980
65981C...Vector/axial vector -> q + qbar; q -> q + V.
65982 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
65983 & ITYPES.EQ.3)) THEN
65984 ICLASS=2
65985 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
65986 ICOMBI=1
65987 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
65988 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
65989C...gamma*/Z0: assume e+e- initial state if unknown.
65990 EI=-1D0
65991 IF(KFSRCE.EQ.23) THEN
65992 IANNFL=K(K(IP1,3),3)
65993 IF(IANNFL.NE.0) THEN
65994 KANNFL=IABS(K(IANNFL,2))
65995 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
65996 ENDIF
65997 ENDIF
65998 AI=SIGN(1D0,EI+0.1D0)
65999 VI=AI-4D0*EI*PARU(102)
66000 EF=KCHG(KFLA(1),1)/3D0
66001 AF=SIGN(1D0,EF+0.1D0)
66002 VF=AF-4D0*EF*PARU(102)
66003 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
66004 SH=PS(5)**2
66005 SQMZ=PMAS(23,1)**2
66006 SQWZ=PS(5)*PMAS(23,2)
66007 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
66008 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
66009 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
66010 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
66011 ICOMBI=3
66012 ALPHA=VECT/(VECT+AXIV)
66013 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
66014 ICOMBI=4
66015 ENDIF
66016C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
66017 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
66018 ICLASS=2
66019 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66020 & ITYPES.EQ.1)) THEN
66021 ICLASS=3
66022
66023C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
66024 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
66025 ICLASS=4
66026 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
66027 ICOMBI=1
66028 ELSEIF(KFSRCE.EQ.36) THEN
66029 ICOMBI=2
66030 ENDIF
66031 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66032 & ITYPES.EQ.1)) THEN
66033 ICLASS=5
66034
66035C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
66036 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66037 & ITYPES.EQ.3)) THEN
66038 ICLASS=6
66039 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
66040 & ITYPES.EQ.2)) THEN
66041 ICLASS=7
66042 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
66043 ICLASS=8
66044 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
66045 & ITYPES.EQ.2)) THEN
66046 ICLASS=9
66047
66048C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
66049 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
66050 & ITYPES.EQ.5)) THEN
66051 ICLASS=10
66052 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66053 & ITYPES.EQ.2)) THEN
66054 ICLASS=11
66055 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
66056 & ITYPES.EQ.1)) THEN
66057 ICLASS=12
66058
66059C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
66060 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
66061 ICLASS=13
66062 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66063 & ITYPES.EQ.2)) THEN
66064 ICLASS=14
66065 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
66066 & ITYPES.EQ.1)) THEN
66067 ICLASS=15
66068
66069C...g -> ~g + ~g (eikonal approximation).
66070 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
66071 ICLASS=16
66072 ENDIF
66073 M3JC=5*ICLASS+ICOMBI
66074 ENDIF
66075 ENDIF
66076
66077C...Find if interference with initial state partons.
66078 MIIS=0
66079 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
66080 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
66081 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
66082 &MIIS=MSTJ(50)-3
66083 IF(MIIS.NE.0) THEN
66084 DO 190 I=1,2
66085 KCII(I)=0
66086 KCA=PYCOMP(KFLA(I))
66087 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
66088 NIIS(I)=0
66089 IF(KCII(I).NE.0) THEN
66090 DO 180 J=1,2
66091 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
66092 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
66093 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
66094 NIIS(I)=NIIS(I)+1
66095 IIIS(I,NIIS(I))=ICSI
66096 ENDIF
66097 180 CONTINUE
66098 ENDIF
66099 190 CONTINUE
66100 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
66101 ENDIF
66102
66103C...Boost interfering initial partons to rest frame
66104C...and reconstruct their polar and azimuthal angles.
66105 IF(MIIS.NE.0) THEN
66106 DO 210 I=1,2
66107 DO 200 J=1,5
66108 K(N+I,J)=K(IPA(I),J)
66109 P(N+I,J)=P(IPA(I),J)
66110 V(N+I,J)=0D0
66111 200 CONTINUE
66112 210 CONTINUE
66113 DO 230 I=3,2+NIIS(1)
66114 DO 220 J=1,5
66115 K(N+I,J)=K(IIIS(1,I-2),J)
66116 P(N+I,J)=P(IIIS(1,I-2),J)
66117 V(N+I,J)=0D0
66118 220 CONTINUE
66119 230 CONTINUE
66120 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66121 DO 240 J=1,5
66122 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
66123 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
66124 V(N+I,J)=0D0
66125 240 CONTINUE
66126 250 CONTINUE
66127 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
66128 & -PS(2)/PS(4),-PS(3)/PS(4))
66129 PHI=PYANGL(P(N+1,1),P(N+1,2))
66130 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
66131 THE=PYANGL(P(N+1,3),P(N+1,1))
66132 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
66133 DO 260 I=3,2+NIIS(1)
66134 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
66135 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
66136 260 CONTINUE
66137 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
66138 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
66139 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
66140 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
66141 270 CONTINUE
66142 ENDIF
66143
66144C...Boost 3 or more partons to their rest frame.
66145 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
66146 &-PS(2)/PS(4),-PS(3)/PS(4))
66147
66148C...Define imagined single initiator of shower for parton system.
66149 NS=N
66150 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
66151 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66152 IF(MSTU(21).GE.1) RETURN
66153 ENDIF
66154 280 N=NS
66155 IF(NPA.GE.2) THEN
66156 K(N+1,1)=11
66157 K(N+1,2)=21
66158 K(N+1,3)=0
66159 K(N+1,4)=0
66160 K(N+1,5)=0
66161 P(N+1,1)=0D0
66162 P(N+1,2)=0D0
66163 P(N+1,3)=0D0
66164 P(N+1,4)=PS(5)
66165 P(N+1,5)=PS(5)
66166 V(N+1,5)=PS(5)**2
66167 N=N+1
66168 IREF(1)=21
66169 ENDIF
66170
66171C...Loop over partons that may branch.
66172 NEP=NPA
66173 IM=NS
66174 IF(NPA.EQ.1) IM=NS-1
66175 290 IM=IM+1
66176 IF(N.GT.NS) THEN
66177 IF(IM.GT.N) GOTO 600
66178 KFLM=IABS(K(IM,2))
66179 IR=IREF(IM-NS)
66180 IF(KSH(IR).EQ.0) GOTO 290
66181 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
66182 IGM=K(IM,3)
66183 ELSE
66184 IGM=-1
66185 ENDIF
66186 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
66187 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
66188 IF(MSTU(21).GE.1) RETURN
66189 ENDIF
66190
66191C...Position of aunt (sister to branching parton).
66192C...Origin and flavour of daughters.
66193 IAU=0
66194 IF(IGM.GT.0) THEN
66195 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
66196 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
66197 ENDIF
66198 IF(IGM.GE.0) THEN
66199 K(IM,4)=N+1
66200 DO 300 I=1,NEP
66201 K(N+I,3)=IM
66202 300 CONTINUE
66203 ELSE
66204 K(N+1,3)=IPA(1)
66205 ENDIF
66206 IF(IGM.LE.0) THEN
66207 DO 310 I=1,NEP
66208 K(N+I,2)=K(IPA(I),2)
66209 310 CONTINUE
66210 ELSEIF(KFLM.NE.21) THEN
66211 K(N+1,2)=K(IM,2)
66212 K(N+2,2)=K(IM,5)
66213 IREF(N+1-NS)=IREF(IM-NS)
66214 IREF(N+2-NS)=IABS(K(N+2,2))
66215 ELSEIF(K(IM,5).EQ.21) THEN
66216 K(N+1,2)=21
66217 K(N+2,2)=21
66218 IREF(N+1-NS)=21
66219 IREF(N+2-NS)=21
66220 ELSE
66221 K(N+1,2)=K(IM,5)
66222 K(N+2,2)=-K(IM,5)
66223 IREF(N+1-NS)=IABS(K(N+1,2))
66224 IREF(N+2-NS)=IABS(K(N+2,2))
66225 ENDIF
66226
66227C...Reset flags on daughters and tries made.
66228 DO 320 IP=1,NEP
66229 K(N+IP,1)=3
66230 K(N+IP,4)=0
66231 K(N+IP,5)=0
66232 KFLD(IP)=IABS(K(N+IP,2))
66233 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
66234 ITRY(IP)=0
66235 ISL(IP)=0
66236 ISI(IP)=0
66237 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
66238 320 CONTINUE
66239 ISLM=0
66240
66241C...Maximum virtuality of daughters.
66242 IF(IGM.LE.0) THEN
66243 DO 330 I=1,NPA
66244 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
66245 P(N+I,5)=MIN(QMAX,PS(5))
66246 IR=IREF(N+I-NS)
66247 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
66248 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
66249 330 CONTINUE
66250 ELSE
66251 IF(MSTJ(43).LE.2) PEM=V(IM,2)
66252 IF(MSTJ(43).GE.3) PEM=P(IM,4)
66253 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
66254 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
66255 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
66256 ENDIF
66257 DO 340 I=1,NEP
66258 PMSD(I)=P(N+I,5)
66259 IF(ISI(I).EQ.1) THEN
66260 IR=IREF(N+I-NS)
66261 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
66262 ENDIF
66263 V(N+I,5)=P(N+I,5)**2
66264 340 CONTINUE
66265
66266C...Choose one of the daughters for evolution.
66267 350 INUM=0
66268 IF(NEP.EQ.1) INUM=1
66269 DO 360 I=1,NEP
66270 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
66271 360 CONTINUE
66272 DO 370 I=1,NEP
66273 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
66274 IR=IREF(N+I-NS)
66275 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
66276 ENDIF
66277 370 CONTINUE
66278 IF(INUM.EQ.0) THEN
66279 RMAX=0D0
66280 DO 380 I=1,NEP
66281 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
66282 RPM=P(N+I,5)/PMSD(I)
66283 IR=IREF(N+I-NS)
66284 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
66285 RMAX=RPM
66286 INUM=I
66287 ENDIF
66288 ENDIF
66289 380 CONTINUE
66290 ENDIF
66291
66292C...Cancel choice of predetermined daughter already treated.
66293 INUM=MAX(1,INUM)
66294 INUMT=INUM
66295 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
66296 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
66297 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
66298 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
66299 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
66300 ENDIF
66301
66302C...Store information on choice of evolving daughter.
66303 IEP(1)=N+INUM
66304 DO 390 I=2,NEP
66305 IEP(I)=IEP(I-1)+1
66306 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
66307 390 CONTINUE
66308 DO 400 I=1,NEP
66309 KFL(I)=IABS(K(IEP(I),2))
66310 400 CONTINUE
66311 ITRY(INUM)=ITRY(INUM)+1
66312 IF(ITRY(INUM).GT.200) THEN
66313 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
66314 IF(MSTU(21).GE.1) RETURN
66315 ENDIF
66316 Z=0.5D0
66317 IR=IREF(IEP(1)-NS)
66318 IF(KSH(IR).EQ.0) GOTO 450
66319 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
66320
66321C...Check if evolution already predetermined for daughter.
66322 IPSPD=0
66323 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
66324 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
66325 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
66326 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
66327 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
66328 ENDIF
66329 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
66330 ISSET(INUM)=0
66331 IF(IPSPD.NE.0) ISSET(INUM)=1
66332 ENDIF
66333
66334C...Select side for interference with initial state partons.
66335 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
66336 III=IEP(1)-NS-1
66337 ISII(III)=0
66338 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
66339 ISII(III)=1
66340 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
66341 IF(PYR(0).GT.0.5D0) ISII(III)=1
66342 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
66343 ISII(III)=1
66344 IF(PYR(0).GT.0.5D0) ISII(III)=2
66345 ENDIF
66346 ENDIF
66347
66348C...Calculate allowed z range.
66349 IF(NEP.EQ.1) THEN
66350 PMED=PS(4)
66351 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66352 PMED=P(IM,5)
66353 ELSE
66354 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
66355 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
66356 ENDIF
66357 IF(MOD(MSTJ(43),2).EQ.1) THEN
66358 ZC=PMTH(2,21)/PMED
66359 ZCE=PMTH(2,22)/PMED
66360 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
66361 ELSE
66362 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
66363 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
66364 PMTMPE=PMTH(2,22)
66365 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
66366 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
66367 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
66368 ENDIF
66369 ZC=MIN(ZC,0.491D0)
66370 ZCE=MIN(ZCE,0.49991D0)
66371 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
66372 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
66373 P(IEP(1),5)=PMTH(1,IR)
66374 V(IEP(1),5)=P(IEP(1),5)**2
66375 GOTO 450
66376 ENDIF
66377
66378C...Integral of Altarelli-Parisi z kernel for QCD.
66379C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
66380 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
66381 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
66382C...QUARKONIA+++
66383C...Evolution of QQ~[3S18] state if MSTP(148)=1.
66384 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
66385 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66386 FBR=6D0*LOG((1D0-ZC)/ZC)
66387C...QUARKONIA---
66388 ELSEIF(MSTJ(49).EQ.0) THEN
66389 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
66390 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
66391
66392C...Integral of Altarelli-Parisi z kernel for scalar gluon.
66393 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
66394 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
66395 ELSEIF(MSTJ(49).EQ.1) THEN
66396 FBR=(1D0-2D0*ZC)/3D0
66397 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
66398
66399C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
66400 ELSEIF(KFL(1).EQ.21) THEN
66401 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
66402 ELSE
66403 FBR=2D0*LOG((1D0-ZC)/ZC)
66404 ENDIF
66405
66406C...Reset QCD probability for colourless.
66407 IF(ISCOL(IR).EQ.0) FBR=0D0
66408
66409C...Integral of Altarelli-Parisi kernel for photon emission.
66410 FBRE=0D0
66411 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
66412 IF(KFL(1).LE.18) THEN
66413 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
66414 ENDIF
66415 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
66416 ENDIF
66417
66418C...Inner veto algorithm starts. Find maximum mass for evolution.
66419 410 PMS=V(IEP(1),5)
66420 IF(IGM.GE.0) THEN
66421 PM2=0D0
66422 DO 420 I=2,NEP
66423 PM=P(IEP(I),5)
66424 IRI=IREF(IEP(I)-NS)
66425 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
66426 PM2=PM2+PM
66427 420 CONTINUE
66428 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
66429 ENDIF
66430
66431C...Select mass for daughter in QCD evolution.
66432 B0=27D0/6D0
66433 DO 430 IFF=4,MSTJ(45)
66434 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
66435 430 CONTINUE
66436C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66437 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
66438C...Already predetermined choice.
66439 IF(IPSPD.NE.0) THEN
66440 PMSQCD=P(IPSPD,5)**2
66441 ELSEIF(FBR.LT.1D-3) THEN
66442 PMSQCD=0D0
66443 ELSEIF(MSTJ(44).LE.0) THEN
66444 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
66445 ELSEIF(MSTJ(44).EQ.1) THEN
66446 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
66447 ELSE
66448 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
66449 ENDIF
66450C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66451 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
66452 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
66453 V(IEP(1),5)=PMSQCD
66454 MCE=1
66455
66456C...Select mass for daughter in QED evolution.
66457 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
66458C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
66459 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
66460 IF(FBRE.LT.1D-3) THEN
66461 PMSQED=0D0
66462 ELSE
66463 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
66464 & (PARU(101)*FBRE)))
66465 ENDIF
66466C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
66467 PMSQED=PMSQED+PMTH(1,IR)**2
66468 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
66469 & PMTH(2,IR)**2
66470 IF(PMSQED.GT.PMSQCD) THEN
66471 V(IEP(1),5)=PMSQED
66472 MCE=2
66473 ENDIF
66474 ENDIF
66475
66476C...Check whether daughter mass below cutoff.
66477 P(IEP(1),5)=SQRT(V(IEP(1),5))
66478 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
66479 P(IEP(1),5)=PMTH(1,IR)
66480 V(IEP(1),5)=P(IEP(1),5)**2
66481 GOTO 450
66482 ENDIF
66483
66484C...Already predetermined choice of z, and flavour in g -> qqbar.
66485 IF(IPSPD.NE.0) THEN
66486 IPSGD1=K(IPSPD,4)
66487 IPSGD2=K(IPSPD,5)
66488 PMSGD1=P(IPSGD1,5)**2
66489 PMSGD2=P(IPSGD2,5)**2
66490 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
66491 & 4D0*PMSGD1*PMSGD2))
66492 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
66493 & PMSGD1+PMSGD2)/ALAMPS
66494 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
66495 IF(KFL(1).NE.21) THEN
66496 K(IEP(1),5)=21
66497 ELSE
66498 K(IEP(1),5)=IABS(K(IPSGD1,2))
66499 ENDIF
66500
66501C...Select z value of branching: q -> qgamma.
66502 ELSEIF(MCE.EQ.2) THEN
66503 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
66504 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66505 K(IEP(1),5)=22
66506
66507C...QUARKONIA+++
66508C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
66509 ELSEIF(MSTJ(49).EQ.0.AND.
66510 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
66511 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66512C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
66513 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
66514 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66515 K(IEP(1),5)=21
66516C...QUARKONIA---
66517
66518C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
66519 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
66520 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66521C...Only do z weighting when no ME correction afterwards.
66522 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
66523 K(IEP(1),5)=21
66524 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
66525 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
66526 IF(PYR(0).GT.0.5D0) Z=1D0-Z
66527 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
66528 K(IEP(1),5)=21
66529 ELSEIF(MSTJ(49).NE.1) THEN
66530 Z=PYR(0)
66531 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
66532 KFLB=1+INT(MSTJ(45)*PYR(0))
66533 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66534 IF(PMQ.GE.1D0) GOTO 410
66535 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
66536 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
66537 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
66538 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
66539 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
66540 ELSE
66541 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
66542 ENDIF
66543 K(IEP(1),5)=KFLB
66544
66545C...Ditto for scalar gluon model.
66546 ELSEIF(KFL(1).NE.21) THEN
66547 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
66548 K(IEP(1),5)=21
66549 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
66550 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66551 K(IEP(1),5)=21
66552 ELSE
66553 Z=ZC+(1D0-2D0*ZC)*PYR(0)
66554 KFLB=1+INT(MSTJ(45)*PYR(0))
66555 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
66556 IF(PMQ.GE.1D0) GOTO 410
66557 K(IEP(1),5)=KFLB
66558 ENDIF
66559
66560C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
66561 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
66562 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66563 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66564 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
66565 ELSE
66566 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
66567 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
66568 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
66569 IF(PT2APP.LT.PT2MIN) GOTO 410
66570 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
66571 ENDIF
66572 ENDIF
66573
66574C...Check if z consistent with chosen m.
66575 IF(KFL(1).EQ.21) THEN
66576 IRGD1=IABS(K(IEP(1),5))
66577 IRGD2=IRGD1
66578 ELSE
66579 IRGD1=IR
66580 IRGD2=IABS(K(IEP(1),5))
66581 ENDIF
66582 IF(NEP.EQ.1) THEN
66583 PED=PS(4)
66584 ELSEIF(NEP.GE.3) THEN
66585 PED=P(IEP(1),4)
66586 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66587 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
66588 ELSE
66589 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
66590 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
66591 ENDIF
66592 IF(MOD(MSTJ(43),2).EQ.1) THEN
66593 PMQTH3=0.5D0*PARJ(82)
66594 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66595 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
66596 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
66597 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
66598 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66599 & 4D0*PMQ1*PMQ2)))
66600 ZH=1D0+PMQ1-PMQ2
66601 ELSE
66602 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
66603 ZH=1D0
66604 ENDIF
66605 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
66606 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66607 ELSEIF(IPSPD.NE.0) THEN
66608 ELSE
66609 ZL=0.5D0*(ZH-ZD)
66610 ZU=0.5D0*(ZH+ZD)
66611 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
66612 ENDIF
66613 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
66614 &(1D0-ZU)))
66615 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66616
66617C...Width suppression for q -> q + g.
66618 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
66619 IF(IGM.EQ.0) THEN
66620 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
66621 ELSE
66622 EGLU=PMED*(1D0-Z)
66623 ENDIF
66624 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
66625 IF(MSTJ(40).EQ.1) THEN
66626 IF(CHI.LT.PYR(0)) GOTO 410
66627 ELSEIF(MSTJ(40).EQ.2) THEN
66628 IF(1D0-CHI.LT.PYR(0)) GOTO 410
66629 ENDIF
66630 ENDIF
66631
66632C...Three-jet matrix element correction.
66633 IF(M3JC.GE.1) THEN
66634 WME=1D0
66635 WSHOW=1D0
66636
66637C...QED matrix elements: only for massless case so far.
66638 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
66639 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66640 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66641 X3=(1D0-X1)+(1D0-X2)
66642 KI1=K(IPA(INUM),2)
66643 KI2=K(IPA(3-INUM),2)
66644 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
66645 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
66646 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
66647 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
66648 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
66649 ELSEIF(MCE.EQ.2) THEN
66650
66651C...QCD matrix elements, including mass effects.
66652 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
66653 PS1ME=V(IEP(1),5)
66654 PM1ME=PMTH(1,IR)
66655 M3JCC=M3JC
66656 IF(IR.GE.31.AND.IGM.EQ.0) THEN
66657C...QCD ME: original parton, first branching.
66658 PM2ME=PMTH(1,63-IR)
66659 ECMME=PS(5)
66660 ELSEIF(IR.GE.31) THEN
66661C...QCD ME: original parton, subsequent branchings.
66662 PM2ME=PMTH(1,63-IR)
66663 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66664 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66665 ELSEIF(K(IM,2).EQ.21) THEN
66666C...QCD ME: secondary partons, first branching.
66667 PM2ME=PM1ME
66668 ZMME=V(IM,1)
66669 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
66670 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
66671 & 4D0*PS1ME*PM2ME**2))
66672 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
66673 & V(IM,5)
66674 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66675 M3JCC=66
66676 ELSE
66677C...QCD ME: secondary partons, subsequent branchings.
66678 PM2ME=PM1ME
66679 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
66680 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
66681 M3JCC=66
66682 ENDIF
66683C...Construct ME variables.
66684 R1ME=PM1ME/ECMME
66685 R2ME=PM2ME/ECMME
66686 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
66687 X2=1D0+R2ME**2-PS1ME/ECMME**2
66688C...Call ME, with right order important for two inequivalent showerers.
66689 IF(IR.EQ.IORD+30) THEN
66690 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
66691 ELSE
66692 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
66693 ENDIF
66694C...Split up total ME when two radiating partons.
66695 ISPRAD=1
66696 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
66697 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
66698 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
66699 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
66700 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
66701 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
66702 & MAX(1D-10,2D0-X1-X2)
66703C...Evaluate shower rate to be compared with.
66704 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
66705 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
66706 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
66707 ELSEIF(MSTJ(49).NE.1) THEN
66708
66709C...Toy model scalar theory matrix elements; no mass effects.
66710 ELSE
66711 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
66712 X2=1D0-V(IEP(1),5)/V(NS+1,5)
66713 X3=(1D0-X1)+(1D0-X2)
66714 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
66715 WME=X3**2
66716 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
66717 & PARJ(171)
66718 ENDIF
66719
66720 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
66721 ENDIF
66722
66723C...Impose angular ordering by rejection of nonordered emission.
66724 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
66725 PEMAO=V(IM,1)*P(IM,4)
66726 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
66727 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
66728 MAOD=0
66729 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
66730 & .OR.MSTJ(42).EQ.7)) THEN
66731 MAOD=0
66732 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
66733 & .OR.MSTJ(42).EQ.6)) THEN
66734 MAOD=1
66735 PMDAO=PMTH(2,K(IEP(1),5))
66736 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
66737 ELSE
66738 MAOD=1
66739 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
66740 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
66741 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
66742 ENDIF
66743 MAOM=1
66744 IAOM=IM
66745 440 IF(K(IAOM,5).EQ.22) THEN
66746 IAOM=K(IAOM,3)
66747 IF(K(IAOM,3).LE.NS) MAOM=0
66748 IF(MAOM.EQ.1) GOTO 440
66749 ENDIF
66750 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
66751 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
66752 IF(THE2ID.LT.THE2IM) GOTO 410
66753 ENDIF
66754 ENDIF
66755
66756C...Impose user-defined maximum angle at first branching.
66757 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
66758 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
66759 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
66760 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66761 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
66762 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66763 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
66764 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
66765 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
66766 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
66767 ENDIF
66768 ENDIF
66769
66770C...Impose angular constraint in first branching from interference
66771C...with initial state partons.
66772 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
66773 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
66774 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
66775 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
66776 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
66777 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
66778 ENDIF
66779 ENDIF
66780
66781C...End of inner veto algorithm. Check if only one leg evolved so far.
66782 450 V(IEP(1),1)=Z
66783 ISL(1)=0
66784 ISL(2)=0
66785 IF(NEP.EQ.1) GOTO 490
66786 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
66787 DO 460 I=1,NEP
66788 IR=IREF(N+I-NS)
66789 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
66790 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
66791 ENDIF
66792 460 CONTINUE
66793
66794C...Check if chosen multiplet m1,m2,z1,z2 is physical.
66795 IF(NEP.GE.3) THEN
66796 PMSUM=0D0
66797 DO 470 I=1,NEP
66798 PMSUM=PMSUM+P(N+I,5)
66799 470 CONTINUE
66800 IF(PMSUM.GE.PS(5)) GOTO 350
66801 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
66802 DO 480 I1=N+1,N+2
66803 IRDA=IREF(I1-NS)
66804 IF(KSH(IRDA).EQ.0) GOTO 480
66805 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
66806 IF(IRDA.EQ.21) THEN
66807 IRGD1=IABS(K(I1,5))
66808 IRGD2=IRGD1
66809 ELSE
66810 IRGD1=IRDA
66811 IRGD2=IABS(K(I1,5))
66812 ENDIF
66813 I2=2*N+3-I1
66814 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
66815 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
66816 ELSE
66817 IF(I1.EQ.N+1) ZM=V(IM,1)
66818 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
66819 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
66820 & 4D0*V(N+1,5)*V(N+2,5))
66821 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
66822 & V(IM,5)
66823 ENDIF
66824 IF(MOD(MSTJ(43),2).EQ.1) THEN
66825 PMQTH3=0.5D0*PARJ(82)
66826 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
66827 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
66828 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
66829 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
66830 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
66831 & 4D0*PMQ1*PMQ2)))
66832 ZH=1D0+PMQ1-PMQ2
66833 ELSE
66834 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
66835 ZH=1D0
66836 ENDIF
66837 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
66838 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66839 ELSE
66840 ZL=0.5D0*(ZH-ZD)
66841 ZU=0.5D0*(ZH+ZD)
66842 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66843 & ISSET(1).EQ.0) THEN
66844 ISL(1)=1
66845 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
66846 & ISSET(2).EQ.0) THEN
66847 ISL(2)=1
66848 ENDIF
66849 ENDIF
66850 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
66851 & ZL*(1D0-ZU)))
66852 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
66853 480 CONTINUE
66854 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
66855 ISL(3-ISLM)=0
66856 ISLM=3-ISLM
66857 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
66858 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
66859 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
66860 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
66861 IF(ISL(1).EQ.1) ISL(2)=0
66862 IF(ISL(1).EQ.0) ISLM=1
66863 IF(ISL(2).EQ.0) ISLM=2
66864 ENDIF
66865 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
66866 ENDIF
66867 IRD1=IREF(N+1-NS)
66868 IRD2=IREF(N+2-NS)
66869 IF(IGM.GT.0) THEN
66870 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
66871 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
66872 PMQ1=V(N+1,5)/V(IM,5)
66873 PMQ2=V(N+2,5)/V(IM,5)
66874 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
66875 & 4D0*PMQ1*PMQ2)))
66876 ZH=1D0+PMQ1-PMQ2
66877 ZL=0.5D0*(ZH-ZD)
66878 ZU=0.5D0*(ZH+ZD)
66879 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
66880 ENDIF
66881 ENDIF
66882
66883C...Accepted branch. Construct four-momentum for initial partons.
66884 490 MAZIP=0
66885 MAZIC=0
66886 IF(NEP.EQ.1) THEN
66887 P(N+1,1)=0D0
66888 P(N+1,2)=0D0
66889 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
66890 & P(N+1,5))))
66891 P(N+1,4)=P(IPA(1),4)
66892 V(N+1,2)=P(N+1,4)
66893 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
66894 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
66895 P(N+1,1)=0D0
66896 P(N+1,2)=0D0
66897 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
66898 P(N+1,4)=PED1
66899 P(N+2,1)=0D0
66900 P(N+2,2)=0D0
66901 P(N+2,3)=-P(N+1,3)
66902 P(N+2,4)=P(IM,5)-PED1
66903 V(N+1,2)=P(N+1,4)
66904 V(N+2,2)=P(N+2,4)
66905 ELSEIF(NEP.GE.3) THEN
66906C...Rescale all momenta for energy conservation.
66907 LOOP=0
66908 PES=0D0
66909 PQS=0D0
66910 DO 510 I=1,NEP
66911 DO 500 J=1,4
66912 P(N+I,J)=P(IPA(I),J)
66913 500 CONTINUE
66914 PES=PES+P(N+I,4)
66915 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66916 510 CONTINUE
66917 520 LOOP=LOOP+1
66918 FAC=(PS(5)-PQS)/(PES-PQS)
66919 PES=0D0
66920 PQS=0D0
66921 DO 540 I=1,NEP
66922 DO 530 J=1,3
66923 P(N+I,J)=FAC*P(N+I,J)
66924 530 CONTINUE
66925 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)
66926 V(N+I,2)=P(N+I,4)
66927 PES=PES+P(N+I,4)
66928 PQS=PQS+P(N+I,5)**2/P(N+I,4)
66929 540 CONTINUE
66930 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
66931
66932C...Construct transverse momentum for ordinary branching in shower.
66933 ELSE
66934 ZM=V(IM,1)
66935 LOOPPT=0
66936 550 LOOPPT=LOOPPT+1
66937 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
66938 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
66939 IF(PZM.LE.0D0) THEN
66940 PTS=0D0
66941 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
66942 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
66943 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
66944 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
66945 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
66946 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
66947 ELSE
66948 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
66949 ENDIF
66950 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
66951 ZM=0.05D0+0.9D0*ZM
66952 GOTO 550
66953 ELSEIF(PTS.LT.0D0) THEN
66954 GOTO 280
66955 ENDIF
66956 PT=SQRT(MAX(0D0,PTS))
66957
66958C...Global statistics.
66959 MINT(353)=MINT(353)+1
66960 VINT(353)=VINT(353)+PT
66961 IF (MINT(353).EQ.1) VINT(358)=PT
66962
66963C...Find coefficient of azimuthal asymmetry due to gluon polarization.
66964 HAZIP=0D0
66965 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
66966 & .AND.IAU.NE.0) THEN
66967 IF(K(IGM,3).NE.0) MAZIP=1
66968 ZAU=V(IGM,1)
66969 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
66970 IF(MAZIP.EQ.0) ZAU=0D0
66971 IF(K(IGM,2).NE.21) THEN
66972 HAZIP=2D0*ZAU/(1D0+ZAU**2)
66973 ELSE
66974 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
66975 ENDIF
66976 IF(K(N+1,2).NE.21) THEN
66977 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
66978 ELSE
66979 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
66980 ENDIF
66981 ENDIF
66982
66983C...Find coefficient of azimuthal asymmetry due to soft gluon
66984C...interference.
66985 HAZIC=0D0
66986 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
66987 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
66988 IF(K(IGM,3).NE.0) MAZIC=N+1
66989 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
66990 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
66991 & ZM.GT.0.5D0) MAZIC=N+2
66992 IF(K(IAU,2).EQ.22) MAZIC=0
66993 ZS=ZM
66994 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
66995 ZGM=V(IGM,1)
66996 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
66997 IF(MAZIC.EQ.0) ZGM=1D0
66998 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
66999 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
67000 HAZIC=MIN(0.95D0,HAZIC)
67001 ENDIF
67002 ENDIF
67003
67004C...Construct energies for ordinary branching in shower.
67005 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
67006 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67007 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67008 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67009 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67010 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
67011 P(N+1,4)=PEM*V(IM,1)
67012 ELSE
67013 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
67014 & SQRT(PMLS)*ZM)/V(IM,5)
67015 ENDIF
67016
67017C...Already predetermined choice of phi angle or not
67018 PHI=PARU(2)*PYR(0)
67019 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
67020 IPSPD=IP1+IM-NS-2
67021 IF(K(IPSPD,4).GT.0) THEN
67022 IPSGD1=K(IPSPD,4)
67023 IF(IM.EQ.NS+2) THEN
67024 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67025 ELSE
67026 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
67027 ENDIF
67028 ENDIF
67029 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
67030 IPSPD=IP1+IM-NS-2
67031 IF(K(IPSPD,4).GT.0) THEN
67032 IPSGD1=K(IPSPD,4)
67033 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
67034 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
67035 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
67036 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
67037 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
67038 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
67039 ENDIF
67040 ENDIF
67041
67042C...Construct momenta for ordinary branching in shower.
67043 P(N+1,1)=PT*COS(PHI)
67044 P(N+1,2)=PT*SIN(PHI)
67045 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
67046 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
67047 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
67048 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
67049 ELSEIF(PZM.GT.0D0) THEN
67050 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
67051 & 2D0*PEM*P(N+1,4))/PZM
67052 ELSE
67053 P(N+1,3)=0D0
67054 ENDIF
67055 P(N+2,1)=-P(N+1,1)
67056 P(N+2,2)=-P(N+1,2)
67057 P(N+2,3)=PZM-P(N+1,3)
67058 P(N+2,4)=PEM-P(N+1,4)
67059 IF(MSTJ(43).LE.2) THEN
67060 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
67061 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
67062 ENDIF
67063 ENDIF
67064
67065C...Rotate and boost daughters.
67066 IF(IGM.GT.0) THEN
67067 IF(MSTJ(43).LE.2) THEN
67068 BEX=P(IGM,1)/P(IGM,4)
67069 BEY=P(IGM,2)/P(IGM,4)
67070 BEZ=P(IGM,3)/P(IGM,4)
67071 GA=P(IGM,4)/P(IGM,5)
67072 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
67073 & P(IM,4))
67074 ELSE
67075 BEX=0D0
67076 BEY=0D0
67077 BEZ=0D0
67078 GA=1D0
67079 GABEP=0D0
67080 ENDIF
67081 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
67082 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
67083 IF(PTIMB.GT.1D-4) THEN
67084 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
67085 ELSE
67086 PHI=0D0
67087 ENDIF
67088 DO 570 I=N+1,N+2
67089 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
67090 & SIN(THE)*COS(PHI)*P(I,3)
67091 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
67092 & SIN(THE)*SIN(PHI)*P(I,3)
67093 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
67094 DP(4)=P(I,4)
67095 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
67096 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
67097 P(I,1)=DP(1)+DGABP*BEX
67098 P(I,2)=DP(2)+DGABP*BEY
67099 P(I,3)=DP(3)+DGABP*BEZ
67100 P(I,4)=GA*(DP(4)+DBP)
67101 570 CONTINUE
67102 ENDIF
67103
67104C...Weight with azimuthal distribution, if required.
67105 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
67106 DO 580 J=1,3
67107 DPT(1,J)=P(IM,J)
67108 DPT(2,J)=P(IAU,J)
67109 DPT(3,J)=P(N+1,J)
67110 580 CONTINUE
67111 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
67112 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
67113 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
67114 DO 590 J=1,3
67115 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
67116 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
67117 590 CONTINUE
67118 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
67119 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
67120 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
67121 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
67122 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
67123 IF(MAZIP.NE.0) THEN
67124 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
67125 & GOTO 560
67126 ENDIF
67127 IF(MAZIC.NE.0) THEN
67128 IF(MAZIC.EQ.N+2) CAD=-CAD
67129 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
67130 & .LT.PYR(0)) GOTO 560
67131 ENDIF
67132 ENDIF
67133 ENDIF
67134
67135C...Azimuthal anisotropy due to interference with initial state partons.
67136 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
67137 &K(N+2,2).EQ.21)) THEN
67138 III=IM-NS-1
67139 IF(ISII(III).GE.1) THEN
67140 IAZIID=N+1
67141 IF(K(N+1,2).NE.21) IAZIID=N+2
67142 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
67143 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
67144 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
67145 IF(III.EQ.2) THEIID=PARU(1)-THEIID
67146 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
67147 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
67148 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
67149 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
67150 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
67151 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
67152 & .LT.PYR(0)) GOTO 560
67153 ENDIF
67154 ENDIF
67155
67156C...Continue loop over partons that may branch, until none left.
67157 IF(IGM.GE.0) K(IM,1)=14
67158 N=N+NEP
67159 NEP=2
67160 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
67161 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
67162 IF(MSTU(21).GE.1) N=NS
67163 IF(MSTU(21).GE.1) RETURN
67164 ENDIF
67165 GOTO 290
67166
67167C...Set information on imagined shower initiator.
67168 600 IF(NPA.GE.2) THEN
67169 K(NS+1,1)=11
67170 K(NS+1,2)=94
67171 K(NS+1,3)=IP1
67172 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
67173 K(NS+1,4)=NS+2
67174 K(NS+1,5)=NS+1+NPA
67175 IIM=1
67176 ELSE
67177 IIM=0
67178 ENDIF
67179
67180C...Reconstruct string drawing information.
67181 DO 610 I=NS+1+IIM,N
67182 KQ=KCHG(PYCOMP(K(I,2)),2)
67183 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
67184 K(I,1)=1
67185 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
67186 & IABS(K(I,2)).LE.18) THEN
67187 K(I,1)=1
67188 ELSEIF(K(I,1).LE.10) THEN
67189 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
67190 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
67191 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
67192 ID1=MOD(K(I,4),MSTU(5))
67193 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
67194 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
67195 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
67196 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
67197 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67198 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
67199 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67200 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
67201 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
67202 K(ID2,5)=K(ID2,5)+MSTU(5)*I
67203 ELSE
67204 ID1=MOD(K(I,4),MSTU(5))
67205 ID2=ID1+1
67206 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
67207 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
67208 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
67209 K(ID1,4)=K(ID1,4)+MSTU(5)*I
67210 K(ID1,5)=K(ID1,5)+MSTU(5)*I
67211 ELSE
67212 K(ID1,4)=0
67213 K(ID1,5)=0
67214 ENDIF
67215 K(ID2,4)=0
67216 K(ID2,5)=0
67217 ENDIF
67218 610 CONTINUE
67219
67220C...Transformation from CM frame.
67221 IF(NPA.EQ.1) THEN
67222 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
67223 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
67224 MSTU(33)=1
67225 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
67226 ELSEIF(NPA.EQ.2) THEN
67227 BEX=PS(1)/PS(4)
67228 BEY=PS(2)/PS(4)
67229 BEZ=PS(3)/PS(4)
67230 GA=PS(4)/PS(5)
67231 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
67232 & /(1D0+GA)-P(IPA(1),4))
67233 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
67234 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
67235 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
67236 MSTU(33)=1
67237 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
67238 ELSE
67239 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
67240 & PS(3)/PS(4))
67241 MSTU(33)=1
67242 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
67243 ENDIF
67244
67245C...Decay vertex of shower.
67246 DO 630 I=NS+1,N
67247 DO 620 J=1,5
67248 V(I,J)=V(IP1,J)
67249 620 CONTINUE
67250 630 CONTINUE
67251
67252C...Delete trivial shower, else connect initiators.
67253 IF(N.LE.NS+NPA+IIM) THEN
67254 N=NS
67255 ELSE
67256 DO 640 IP=1,NPA
67257 K(IPA(IP),1)=14
67258 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
67259 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
67260 K(NS+IIM+IP,3)=IPA(IP)
67261 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
67262 IF(K(NS+IIM+IP,1).NE.1) THEN
67263 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
67264 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
67265 ENDIF
67266 640 CONTINUE
67267 ENDIF
67268
67269 RETURN
67270 END
67271
67272C*********************************************************************
67273
67274C...PYPTFS
67275C...Generates pT-ordered timelike final-state parton showers.
67276
67277C...MODE defines how to find radiators and recoilers.
67278C... = 0 : based on colour flow between undecayed partons.
67279C... = 1 : for IPART <= NPARTD only consider primary partons,
67280C... whether decayed or not; else as above.
67281C... = 2 : based on common history, whether decayed or not.
67282
67283 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
67284
67285C...Double precision and integer declarations.
67286 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67287 IMPLICIT INTEGER(I-N)
67288 INTEGER PYK,PYCHGE,PYCOMP
67289C...Parameter statement to help give large particle numbers.
67290 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
67291 &KEXCIT=4000000,KDIMEN=5000000)
67292C...Parameter statement for maximum size of showers.
67293 PARAMETER (MAXNUR=1000)
67294C...Commonblocks.
67295 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
67296 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67297 COMMON/PYCTAG/NCT,MCT(4000,2)
67298 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67299 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67300 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
67301 COMMON/PYINT1/MINT(400),VINT(400)
67302 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
67303 &/PYINT1/
67304C...Local arrays.
67305 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
67306 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
67307 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
67308 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
67309C...Statement functions.
67310 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
67311 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
67312
67313C...Initial values. Check that valid system.
67314 PTGEN=0D0
67315 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
67316 &MSTJ(41).NE.12) RETURN
67317 IF(NPART.LE.0) THEN
67318 CALL PYERRM(2,'(PYPTFS:) showering system too small')
67319 RETURN
67320 ENDIF
67321 PT2CMX=PTMAX**2
67322
67323C...Mass thresholds and Lambda for QCD evolution.
67324 PMB=PMAS(5,1)
67325 PMC=PMAS(4,1)
67326 ALAM5=PARJ(81)
67327 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
67328 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
67329 PMBS=PMB**2
67330 PMCS=PMC**2
67331 ALAM5S=ALAM5**2
67332 ALAM4S=ALAM4**2
67333 ALAM3S=ALAM3**2
67334
67335C...Cutoff scale for QCD evolution. Starting pT2.
67336 NFLAV=MAX(0,MIN(5,MSTJ(45)))
67337 PT0C=0.5D0*PARJ(82)
67338 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
67339
67340C...Parameters for QED evolution.
67341 AEM2PI=PARU(101)/PARU(2)
67342 PT0EQ=0.5D0*PARJ(83)
67343 PT0EL=0.5D0*PARJ(90)
67344
67345C...Reset. Remove irrelevant colour tags.
67346 NEVOL=0
67347 DO 100 J=1,4
67348 PSUM(J)=0D0
67349 100 CONTINUE
67350 DO 110 I=MINT(84)+1,N
67351 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
67352 K(I,5)=0
67353 MCT(I,2)=0
67354 ENDIF
67355 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
67356 K(I,4)=0
67357 MCT(I,1)=0
67358 ENDIF
67359 110 CONTINUE
67360 NPARTS=NPART
67361
67362C...Begin loop to set up showering partons. Sum four-momenta.
67363 DO 210 IP=1,NPART
67364 I=IPART(IP)
67365 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
67366 IF(K(I,1).GT.10) GOTO 210
67367 ELSEIF(K(I,3).GT.MINT(84)) THEN
67368 IF(K(I,3).GT.MINT(84)+2) GOTO 210
67369 ELSE
67370 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 210
67371 ENDIF
67372 DO 120 J=1,4
67373 PSUM(J)=PSUM(J)+P(I,J)
67374 120 CONTINUE
67375
67376C...Find colour and charge, but skip diquarks.
67377 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 210
67378 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
67379 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
67380
67381C...Either colour or anticolour charge radiates; for gluon both.
67382 DO 160 JSGCOL=1,-1,-2
67383 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
67384 JCOL=4+(1-JSGCOL)/2
67385 JCOLR=9-JCOL
67386
67387C...Basic info about radiating parton.
67388 NEVOL=NEVOL+1
67389 IPOS(NEVOL)=I
67390 IFLG(NEVOL)=0
67391 ISCOL(NEVOL)=JSGCOL
67392 ISCHG(NEVOL)=0
67393 PTSCA(NEVOL)=PTPART(IP)
67394
67395C...Begin search for colour recoiler when MODE = 0 or 1.
67396 IF(MODE.LE.1) THEN
67397C...Find sister with matching anticolour to the radiating parton.
67398 IROLD=I
67399 IRNEW=K(IROLD,JCOL)/MSTU(5)
67400 MOVE=1
67401
67402C...The following will add MCT colour tracing for unprepped events
67403C...If not done, trace Les Houches colour tags for this dipole
67404C IF (MCT(I,JCOL-3).EQ.0) THEN
67405C CALL PYCTTR(I,JCOL,INEW)
67406C...Clean up mother/daughter 'read' tags set by PYCTTR
67407C DO 125 IR=1,N
67408C K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
67409C K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
67410C 125 CONTINUE
67411C ENDIF
67412
67413C...Skip radiation off loose colour ends.
67414 130 IF(IRNEW.EQ.0) THEN
67415 NEVOL=NEVOL-1
67416 GOTO 160
67417
67418C...Optionally skip radiation on dipole to beam remnant.
67419 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
67420 NEVOL=NEVOL-1
67421 GOTO 160
67422
67423C...For now always skip radiation on dipole to junction.
67424 ELSEIF(K(IRNEW,2).EQ.88) THEN
67425 NEVOL=NEVOL-1
67426 GOTO 160
67427
67428C...For MODE=1: if reached primary then done.
67429 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
67430 & IRNEW.LE.NPARTD) THEN
67431
67432C...If sister stable and points back then done.
67433 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67434 & THEN
67435 IF(K(IRNEW,1).LT.10) THEN
67436
67437C...If sister unstable then go to her daughter.
67438 ELSE
67439 IROLD=IRNEW
67440 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67441 MOVE=2
67442 GOTO 130
67443 ENDIF
67444
67445C...If found mother then look for aunt.
67446 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67447 & IROLD) THEN
67448 IROLD=IRNEW
67449 IRNEW=K(IROLD,JCOL)/MSTU(5)
67450 GOTO 130
67451
67452C...If daughter stable then done.
67453 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
67454 & THEN
67455 IF(K(IRNEW,1).LT.10) THEN
67456
67457C...If daughter unstable then go to granddaughter.
67458 ELSE
67459 IROLD=IRNEW
67460 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67461 MOVE=2
67462 GOTO 130
67463 ENDIF
67464
67465C...If daughter points to another daughter then done or move up.
67466 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
67467 & IROLD) THEN
67468 IF(K(IRNEW,1).LT.10) THEN
67469 ELSE
67470 IROLD=IRNEW
67471 IRNEW=K(IRNEW,JCOL)/MSTU(5)
67472 MOVE=1
67473 GOTO 130
67474 ENDIF
67475 ENDIF
67476
67477C...Begin search for colour recoiler when MODE = 2.
67478 ELSE
67479 IROLD=I
67480 IRNEW=K(IROLD,JCOL)/MSTU(5)
67481 140 IF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
67482C...Step up to mother if radiating parton already branched.
67483 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
67484 IROLD=IRNEW
67485 IRNEW=K(IROLD,JCOL)/MSTU(5)
67486 GOTO 140
67487C...Pick sister by history if no anticolour available.
67488 ELSE
67489 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67490 IRNEW=IROLD-1
67491 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
67492 & THEN
67493 IRNEW=IROLD+1
67494C...Last resort: pick at random among other primaries.
67495 ELSE
67496 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67497 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67498 ENDIF
67499 ENDIF
67500 ENDIF
67501C...Trace down if sister branched.
67502 150 IF(K(IRNEW,1).GT.10) THEN
67503 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
67504 GOTO 150
67505 ENDIF
67506 ENDIF
67507
67508C...Now found other end of colour dipole.
67509 IREC(NEVOL)=IRNEW
67510 ENDIF
67511 160 CONTINUE
67512
67513C...Also electrical charge may radiate; so far only quarks and leptons.
67514 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
67515 & IABS(K(I,2)).LE.18) THEN
67516
67517C...Basic info about radiating parton.
67518 NEVOL=NEVOL+1
67519 IPOS(NEVOL)=I
67520 IFLG(NEVOL)=0
67521 ISCOL(NEVOL)=0
67522 ISCHG(NEVOL)=KCHA
67523 PTSCA(NEVOL)=PTPART(IP)
67524
67525C...Pick nearest (= smallest invariant mass) charged particle
67526C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
67527 IF(MODE.LE.1) THEN
67528 IRNEW=0
67529 PM2MIN=VINT(2)
67530 DO 170 IP2=1,NPART+N-MINT(53)
67531 IF(IP2.EQ.IP) GOTO 170
67532 IF(IP2.LE.NPART) THEN
67533 I2=IPART(IP2)
67534 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
67535 IF(K(I2,1).GT.10) GOTO 170
67536 ELSEIF(K(I2,3).GT.MINT(84)) THEN
67537 IF(K(I2,3).GT.MINT(84)+2) GOTO 170
67538 ELSE
67539 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 170
67540 ENDIF
67541 ELSE
67542 I2=MINT(53)+IP2-NPART
67543 ENDIF
67544 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 170
67545 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
67546 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
67547 IF(PM2INV.LT.PM2MIN) THEN
67548 IRNEW=I2
67549 PM2MIN=PM2INV
67550 ENDIF
67551 170 CONTINUE
67552 IF(IRNEW.EQ.0) THEN
67553 NEVOL=NEVOL-1
67554 GOTO 210
67555 ENDIF
67556
67557C...Begin search for charge recoiler when MODE = 2.
67558 ELSE
67559 IROLD=I
67560C...Pick sister by history; step up if parton already branched.
67561 180 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
67562 IROLD=K(IROLD,3)
67563 GOTO 180
67564 ENDIF
67565 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
67566 IRNEW=IROLD-1
67567 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
67568 IRNEW=IROLD+1
67569C...Last resort: pick at random among other primaries.
67570 ELSE
67571 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
67572 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
67573 ENDIF
67574C...Trace down if sister branched.
67575 190 IF(K(IRNEW,1).GT.10) THEN
67576 DO 200 IR=IRNEW+1,N
67577 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
67578 IRNEW=IR
67579 GOTO 190
67580 ENDIF
67581 200 CONTINUE
67582 ENDIF
67583 ENDIF
67584 IREC(NEVOL)=IRNEW
67585 ENDIF
67586
67587C...End loop to set up showering partons. System invariant mass.
67588 210 CONTINUE
67589 IF(NEVOL.LE.0) RETURN
67590 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
67591
67592C...Check if 3-jet matrix elements to be used.
67593 M3JC=0
67594 ALPHA=0.5D0
67595 NMESYS=0
67596 IF(MSTJ(47).GE.1) THEN
67597
67598C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
67599 KFSRCE=0
67600 IPART1=K(IPART(1),3)
67601 IPART2=K(IPART(2),3)
67602 220 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
67603 KFSRCE=IABS(K(IPART1,2))
67604 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
67605 IPART1=K(IPART1,3)
67606 GOTO 220
67607 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
67608 IPART2=K(IPART2,3)
67609 GOTO 220
67610 ENDIF
67611 ITYPES=0
67612 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
67613 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
67614 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
67615 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
67616 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
67617 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
67618 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
67619 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
67620
67621C...Identify two primary showerers.
67622 KFLA1=IABS(K(IPART(1),2))
67623 ITYPE1=0
67624 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
67625 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
67626 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
67627 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
67628 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
67629 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
67630 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
67631 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
67632 KFLA2=IABS(K(IPART(2),2))
67633 ITYPE2=0
67634 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
67635 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
67636 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
67637 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
67638 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
67639 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
67640 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
67641 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
67642
67643C...Order of showerers. Presence of gluino.
67644 ITYPMN=MIN(ITYPE1,ITYPE2)
67645 ITYPMX=MAX(ITYPE1,ITYPE2)
67646 IORD=1
67647 IF(ITYPE1.GT.ITYPE2) IORD=2
67648 IGLUI=0
67649 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
67650
67651C...Require exactly two primary showerers for ME corrections.
67652 NPRIM=0
67653 IF(IPART1.GT.0) THEN
67654 DO 230 I=1,N
67655 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
67656 230 CONTINUE
67657 ENDIF
67658 IF(NPRIM.NE.2) THEN
67659
67660C...Predetermined and default matrix element kinds.
67661 ELSEIF(MSTJ(38).NE.0) THEN
67662 M3JC=MSTJ(38)
67663 ALPHA=PARJ(80)
67664 MSTJ(38)=0
67665 ELSEIF(MSTJ(47).GE.6) THEN
67666 M3JC=MSTJ(47)
67667 ELSE
67668 ICLASS=1
67669 ICOMBI=4
67670
67671C...Vector/axial vector -> q + qbar; q -> q + V.
67672 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
67673 & ITYPES.EQ.3)) THEN
67674 ICLASS=2
67675 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
67676 ICOMBI=1
67677 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
67678 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
67679C...gamma*/Z0: assume e+e- initial state if unknown.
67680 EI=-1D0
67681 IF(KFSRCE.EQ.23) THEN
67682 IANNFL=IPART1
67683 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67684 IF(IANNFL.GT.0) THEN
67685 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
67686 ENDIF
67687 IF(IANNFL.NE.0) THEN
67688 KANNFL=IABS(K(IANNFL,2))
67689 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
67690 ENDIF
67691 ENDIF
67692 AI=SIGN(1D0,EI+0.1D0)
67693 VI=AI-4D0*EI*PARU(102)
67694 EF=KCHG(KFLA1,1)/3D0
67695 AF=SIGN(1D0,EF+0.1D0)
67696 VF=AF-4D0*EF*PARU(102)
67697 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
67698 SH=PSUM(5)**2
67699 SQMZ=PMAS(23,1)**2
67700 SQWZ=PSUM(5)*PMAS(23,2)
67701 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
67702 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
67703 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
67704 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
67705 ICOMBI=3
67706 ALPHA=VECT/(VECT+AXIV)
67707 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
67708 ICOMBI=4
67709 ENDIF
67710C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
67711 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
67712 ICLASS=2
67713 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67714 & ITYPES.EQ.1)) THEN
67715 ICLASS=3
67716
67717C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
67718 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
67719 ICLASS=4
67720 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
67721 ICOMBI=1
67722 ELSEIF(KFSRCE.EQ.36) THEN
67723 ICOMBI=2
67724 ENDIF
67725 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67726 & ITYPES.EQ.1)) THEN
67727 ICLASS=5
67728
67729C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
67730 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67731 & ITYPES.EQ.3)) THEN
67732 ICLASS=6
67733 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
67734 & ITYPES.EQ.2)) THEN
67735 ICLASS=7
67736 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
67737 ICLASS=8
67738 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
67739 & ITYPES.EQ.2)) THEN
67740 ICLASS=9
67741
67742C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
67743 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
67744 & ITYPES.EQ.5)) THEN
67745 ICLASS=10
67746 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67747 & ITYPES.EQ.2)) THEN
67748 ICLASS=11
67749 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
67750 & ITYPES.EQ.1)) THEN
67751 ICLASS=12
67752
67753C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
67754 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
67755 ICLASS=13
67756 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67757 & ITYPES.EQ.2)) THEN
67758 ICLASS=14
67759 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
67760 & ITYPES.EQ.1)) THEN
67761 ICLASS=15
67762
67763C...g -> ~g + ~g (eikonal approximation).
67764 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
67765 ICLASS=16
67766 ENDIF
67767 M3JC=5*ICLASS+ICOMBI
67768 ENDIF
67769
67770C...Store pair that together define matrix element treatment.
67771 IF(M3JC.NE.0) THEN
67772 NMESYS=1
67773 MESYS(NMESYS,0)=M3JC
67774 MESYS(NMESYS,1)=IPART(1)
67775 MESYS(NMESYS,2)=IPART(2)
67776 ENDIF
67777
67778C...Store qqbar or l+l- pairs for QED radiation.
67779 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
67780 NMESYS=NMESYS+1
67781 MESYS(NMESYS,0)=101
67782 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
67783 MESYS(NMESYS,1)=IPART(1)
67784 MESYS(NMESYS,2)=IPART(2)
67785 ENDIF
67786
67787C...Store other qqbar/l+l- pairs from g/gamma branchings.
67788 DO 270 I1=1,N
67789 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 270
67790 I1M=K(I1,3)
67791 240 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
67792 I1M=K(I1M,3)
67793 GOTO 240
67794 ENDIF
67795C...Move up this check to avoid out-of-bounds.
67796 IF(I1M.EQ.0) GOTO 270
67797 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 270
67798 DO 260 I2=I1+1,N
67799 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 260
67800 I2M=K(I2,3)
67801 250 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
67802 I2M=K(I2M,3)
67803 GOTO 250
67804 ENDIF
67805 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
67806 NMESYS=NMESYS+1
67807 MESYS(NMESYS,0)=66
67808 MESYS(NMESYS,1)=I1
67809 MESYS(NMESYS,2)=I2
67810 NMESYS=NMESYS+1
67811 MESYS(NMESYS,0)=102
67812 MESYS(NMESYS,1)=I1
67813 MESYS(NMESYS,2)=I2
67814 ENDIF
67815 260 CONTINUE
67816 270 CONTINUE
67817 ENDIF
67818
67819C..Loopback point for counting number of emissions.
67820 NGEN=0
67821 280 NGEN=NGEN+1
67822
67823C...Begin loop to evolve all existing partons, if required.
67824 290 IMX=0
67825 PT2MX=0D0
67826 DO 360 IEVOL=1,NEVOL
67827 IF(IFLG(IEVOL).EQ.0) THEN
67828
67829C...Basic info on radiator and recoil.
67830 I=IPOS(IEVOL)
67831 IR=IREC(IEVOL)
67832 SHT=SHAT(I,IR)
67833 PM2I=P(I,5)**2
67834 PM2R=P(IR,5)**2
67835
67836C...Invariant mass of "dipole".Starting value for pT evolution.
67837 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
67838 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
67839
67840C...Case of evolution by QCD branching.
67841 IF(ISCOL(IEVOL).NE.0) THEN
67842
67843C...Parton-by-parton maximum scale from initial conditions.
67844 IF(MSTP(72).EQ.0) THEN
67845 DO 300 IPRT=1,NPARTS
67846 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
67847 300 CONTINUE
67848 ENDIF
67849
67850C...If kinematically impossible then do not evolve.
67851 IF(PT2.LT.PT2CMN) THEN
67852 IFLG(IEVOL)=-1
67853 GOTO 360
67854 ENDIF
67855
67856C...Check if part of system for which ME corrections should be applied.
67857 IMESYS=0
67858 DO 310 IME=1,NMESYS
67859 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67860 & MESYS(IME,0).LT.100) IMESYS=IME
67861 310 CONTINUE
67862
67863C...Special flag for colour octet states.
67864 MOCT=0
67865 IF(K(I,2).EQ.21) MOCT=1
67866 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
67867
67868C...Upper estimate for matrix element weighting and colour factor.
67869C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
67870 WTPSGL=2D0
67871 COLFAC=4D0/3D0
67872 IF(MOCT.GE.1) COLFAC=3D0/2D0
67873 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
67874 WTPSQQ=0.5D0*0.5D0*NFLAV
67875
67876C...Determine overestimated z range: switch at c and b masses.
67877 320 IZRG=1
67878 PT2MNE=PT2CMN
67879 B0=27D0/6D0
67880 ALAMS=ALAM3S
67881 IF(PT2.GT.1.01D0*PMCS) THEN
67882 IZRG=2
67883 PT2MNE=PMCS
67884 B0=25D0/6D0
67885 ALAMS=ALAM4S
67886 ENDIF
67887 IF(PT2.GT.1.01D0*PMBS) THEN
67888 IZRG=3
67889 PT2MNE=PMBS
67890 B0=23D0/6D0
67891 ALAMS=ALAM5S
67892 ENDIF
67893 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
67894 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
67895
67896C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
67897 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
67898 EVCOEF=EVEMGL
67899 IF(MOCT.EQ.1) THEN
67900 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
67901 EVCOEF=EVCOEF+EVEMQQ
67902 ENDIF
67903
67904C...Pick pT2 (in overestimated z range).
67905 330 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
67906
67907C...Loopback if crossed c/b mass thresholds.
67908 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
67909 PT2=PMBS
67910 GOTO 320
67911 ENDIF
67912 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
67913 PT2=PMCS
67914 GOTO 320
67915 ENDIF
67916
67917C...Finish if below lower cutoff.
67918 IF(PT2.LT.PT2CMN) THEN
67919 IFLG(IEVOL)=-1
67920 GOTO 360
67921 ENDIF
67922
67923C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
67924 IFLAG=1
67925 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
67926
67927C...Pick z: dz/(1-z) or dz.
67928 IF(IFLAG.EQ.1) THEN
67929 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
67930 ELSE
67931 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
67932 ENDIF
67933
67934C...Loopback if outside allowed range for given pT2.
67935 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
67936 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
67937 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 330
67938 PM2=PM2I+PT2/(Z*(1D0-Z))
67939 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 330
67940
67941C...No weighting for primary partons; to be done later on.
67942 IF(IMESYS.GT.0) THEN
67943
67944C...Weighting of q->qg/X->Xg branching.
67945 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
67946 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 330
67947
67948C...Weighting of g->gg branching.
67949 ELSEIF(IFLAG.EQ.1) THEN
67950 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 330
67951
67952C...Flavour choice and weighting of g->qqbar branching.
67953 ELSE
67954 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
67955 PMQ=PMAS(KFQ,1)
67956 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
67957 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
67958 IF(WTME.LT.PYR(0)) GOTO 330
67959 IFLAG=10+KFQ
67960 ENDIF
67961
67962C...Case of evolution by QED branching.
67963 ELSEIF(ISCHG(IEVOL).NE.0) THEN
67964
67965C...If kinematically impossible then do not evolve.
67966 PT2EMN=PT0EQ**2
67967 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
67968 IF(PT2.LT.PT2EMN) THEN
67969 IFLG(IEVOL)=-1
67970 GOTO 360
67971 ENDIF
67972
67973C...Check if part of system for which ME corrections should be applied.
67974 IMESYS=0
67975 DO 340 IME=1,NMESYS
67976 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
67977 & MESYS(IME,0).GT.100) IMESYS=IME
67978 340 CONTINUE
67979
67980C...Charge. Matrix element weighting factor.
67981 CHG=ISCHG(IEVOL)/3D0
67982 WTPSGA=2D0
67983
67984C...Determine overestimated z range. Find evolution coefficient.
67985 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
67986 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
67987 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
67988
67989C...Pick pT2 (in overestimated z range).
67990 350 PT2=PT2*PYR(0)**(1D0/EVCOEF)
67991
67992C...Finish if below lower cutoff.
67993 IF(PT2.LT.PT2EMN) THEN
67994 IFLG(IEVOL)=-1
67995 GOTO 360
67996 ENDIF
67997
67998C...Pick z: dz/(1-z).
67999 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
68000
68001C...Loopback if outside allowed range for given pT2.
68002 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
68003 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
68004 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
68005 PM2=PM2I+PT2/(Z*(1D0-Z))
68006 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
68007
68008C...Weighting by branching kernel, except if ME weighting later.
68009 IF(IMESYS.EQ.0) THEN
68010 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 350
68011 ENDIF
68012 IFLAG=3
68013 ENDIF
68014
68015C...Save acceptable branching.
68016 IFLG(IEVOL)=IFLAG
68017 IMESAV(IEVOL)=IMESYS
68018 PT2SAV(IEVOL)=PT2
68019 ZSAV(IEVOL)=Z
68020 SHTSAV(IEVOL)=SHT
68021 ENDIF
68022
68023C...Check if branching has highest pT.
68024 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
68025 IMX=IEVOL
68026 PT2MX=PT2SAV(IEVOL)
68027 ENDIF
68028 360 CONTINUE
68029
68030C...Finished if no more branchings to be done.
68031 IF(IMX.EQ.0) GOTO 480
68032
68033C...Restore info on hardest branching to be processed.
68034 I=IPOS(IMX)
68035 IR=IREC(IMX)
68036 KCOL=ISCOL(IMX)
68037 KCHA=ISCHG(IMX)
68038 IMESYS=IMESAV(IMX)
68039 PT2=PT2SAV(IMX)
68040 Z=ZSAV(IMX)
68041 SHT=SHTSAV(IMX)
68042 PM2I=P(I,5)**2
68043 PM2R=P(IR,5)**2
68044 PM2=PM2I+PT2/(Z*(1D0-Z))
68045
68046C...Special flag for colour octet states.
68047 MOCT=0
68048 IF(K(I,2).EQ.21) MOCT=1
68049 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
68050
68051C...Restore further info for g->qqbar branching.
68052 KFQ=0
68053 IF(IFLG(IMX).GT.10) THEN
68054 KFQ=IFLG(IMX)-10
68055 PMQ=PMAS(KFQ,1)
68056 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
68057 ENDIF
68058
68059C...For branching g include azimuthal asymmetries from polarization.
68060 ASYPOL=0D0
68061 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
68062C...Trace grandmother via intermediate recoil copies.
68063 KFGM=0
68064 IM=I
68065 370 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
68066 & K(IM,3).GT.0) THEN
68067 IM=K(IM,3)
68068 IF(IM.GT.MINT(84)) GOTO 370
68069 ENDIF
68070 IGM=K(IM,3)
68071 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
68072 & KFGM=IABS(K(IGM,2))
68073C...Define approximate energy sharing by identifying aunt.
68074 IAU=IM+1
68075 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
68076 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
68077 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
68078C...Coefficient from gluon production.
68079 IF(KFGM.LE.6) THEN
68080 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
68081 ELSE
68082 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
68083 ENDIF
68084C...Coefficient from gluon decay.
68085 IF(KFQ.EQ.0) THEN
68086 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
68087 ELSE
68088 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
68089 ENDIF
68090 ENDIF
68091 ENDIF
68092
68093C...Create new slots for branching products and recoil.
68094 INEW=N+1
68095 IGNEW=N+2
68096 IRNEW=N+3
68097 N=N+3
68098
68099C...Set status, flavour and mother of new ones.
68100 K(INEW,1)=K(I,1)
68101 K(IGNEW,1)=3
68102 IF(KCHA.NE.0) K(IGNEW,1)=1
68103 K(IRNEW,1)=K(IR,1)
68104 IF(KFQ.EQ.0) THEN
68105 K(INEW,2)=K(I,2)
68106 K(IGNEW,2)=21
68107 IF(KCHA.NE.0) K(IGNEW,2)=22
68108 ELSE
68109 K(INEW,2)=-ISIGN(KFQ,KCOL)
68110 K(IGNEW,2)=-K(INEW,2)
68111 ENDIF
68112 K(IRNEW,2)=K(IR,2)
68113 K(INEW,3)=I
68114 K(IGNEW,3)=I
68115 K(IRNEW,3)=IR
68116
68117C...Find rest frame and angles of branching+recoil.
68118 DO 380 J=1,5
68119 P(INEW,J)=P(I,J)
68120 P(IGNEW,J)=0D0
68121 P(IRNEW,J)=P(IR,J)
68122 380 CONTINUE
68123 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
68124 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
68125 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
68126 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
68127 PHI=PYANGL(P(INEW,1),P(INEW,2))
68128 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
68129
68130C...Derive kinematics of branching: generics (like g->gg).
68131 DO 390 J=1,4
68132 P(INEW,J)=0D0
68133 P(IRNEW,J)=0D0
68134 390 CONTINUE
68135 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
68136 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
68137 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
68138 PTCOR=SQRT(MAX(0D0,PT2COR))
68139 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
68140 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
68141C...Specific kinematics reduction for q->qg with m_q > 0.
68142 IF(MOCT.NE.1) THEN
68143 PTCOR=(1D0-PM2I/PM2)*PTCOR
68144 PZN=PZN+PM2I*PZG/PM2
68145 PZG=(1D0-PM2I/PM2)*PZG
68146C...Specific kinematics reduction for g->qqbar with m_q > 0.
68147 ELSEIF(KFQ.NE.0) THEN
68148 P(INEW,5)=PMQ
68149 P(IGNEW,5)=PMQ
68150 PTCOR=ROOTQQ*PTCOR
68151 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
68152 PZG=PZM-PZN
68153 ENDIF
68154
68155C...Pick phi and construct kinematics of branching.
68156 400 PHIROT=PARU(2)*PYR(0)
68157 P(INEW,1)=PTCOR*COS(PHIROT)
68158 P(INEW,2)=PTCOR*SIN(PHIROT)
68159 P(INEW,3)=PZN
68160 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
68161 P(IGNEW,1)=-P(INEW,1)
68162 P(IGNEW,2)=-P(INEW,2)
68163 P(IGNEW,3)=PZG
68164 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
68165 P(IRNEW,1)=0D0
68166 P(IRNEW,2)=0D0
68167 P(IRNEW,3)=-PZM
68168 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
68169
68170C...Boost branching system to lab frame.
68171 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
68172
68173C...Renew choice of phi angle according to polarization asymmetry.
68174 IF(ABS(ASYPOL).GT.1D-3) THEN
68175 DO 410 J=1,3
68176 DPT(1,J)=P(I,J)
68177 DPT(2,J)=P(IAU,J)
68178 DPT(3,J)=P(INEW,J)
68179 410 CONTINUE
68180 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
68181 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
68182 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
68183 DO 420 J=1,3
68184 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
68185 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
68186 420 CONTINUE
68187 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
68188 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
68189 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
68190 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
68191 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
68192 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
68193 & GOTO 400
68194 ENDIF
68195 ENDIF
68196
68197C...Matrix element corrections for primary partons when requested.
68198 IF(IMESYS.GT.0) THEN
68199 M3JC=MESYS(IMESYS,0)
68200
68201C...Identify recoiling partner and set up three-body kinematics.
68202 IRP=MESYS(IMESYS,1)
68203 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
68204 IF(IRP.EQ.IR) IRP=IRNEW
68205 DO 430 J=1,4
68206 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
68207 430 CONTINUE
68208 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
68209 & PSUM(3)**2))
68210 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
68211 & PSUM(3)*P(INEW,3))/PSUM(5)**2
68212 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
68213 & PSUM(3)*P(IRP,3))/PSUM(5)**2
68214 X3=2D0-X1-X2
68215 R1ME=P(INEW,5)/PSUM(5)
68216 R2ME=P(IRP,5)/PSUM(5)
68217
68218C...Matrix elements for gluon emission.
68219 IF(M3JC.LT.100) THEN
68220
68221C...Call ME, with right order important for two inequivalent showerers.
68222 IF(MESYS(IMESYS,IORD).EQ.I) THEN
68223 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
68224 ELSE
68225 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
68226 ENDIF
68227
68228C...Split up total ME when two radiating partons.
68229 ISPRAD=1
68230 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
68231 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
68232 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
68233 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
68234 & MAX(1D-10,2D0-X1-X2)
68235
68236C...Evaluate shower rate.
68237 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68238 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68239 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
68240
68241C...Matrix elements for photon emission: still rather primitive.
68242 ELSE
68243
68244C...For generic charge combination currently only massless expression.
68245 IF(M3JC.EQ.101) THEN
68246 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
68247 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
68248 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
68249 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
68250
68251C...For flavour neutral system assume vector source and include masses.
68252 ELSE
68253 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
68254 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
68255 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
68256 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
68257 ENDIF
68258 ENDIF
68259
68260C...Perform weighting with W_ME/W_PS.
68261 IF(WME.LT.PYR(0)*WPS) THEN
68262 N=N-3
68263 IFLG(IMX)=0
68264 PT2CMX=PT2
68265 GOTO 290
68266 ENDIF
68267 ENDIF
68268
68269C...Now for sure accepted branching. Save highest pT.
68270 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
68271
68272C...Update status for obsolete ones. Bookkkep the moved original parton
68273C...and new daughter (arbitrary choice for g->gg or g->qqbar).
68274C...Do not bookkeep radiated photon, since it cannot radiate further.
68275 K(I,1)=K(I,1)+10
68276 K(IR,1)=K(IR,1)+10
68277 DO 440 IP=1,NPART
68278 IF(IPART(IP).EQ.I) IPART(IP)=INEW
68279 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
68280 440 CONTINUE
68281 IF(KCHA.EQ.0) THEN
68282 NPART=NPART+1
68283 IPART(NPART)=IGNEW
68284 ENDIF
68285
68286C...Initialize colour flow of branching.
68287C...Use both old and new style colour tags for flexibility.
68288 K(INEW,4)=0
68289 K(IGNEW,4)=0
68290 K(INEW,5)=0
68291 K(IGNEW,5)=0
68292 JCOLP=4+(1-KCOL)/2
68293 JCOLN=9-JCOLP
68294 MCT(INEW,1)=0
68295 MCT(INEW,2)=0
68296 MCT(IGNEW,1)=0
68297 MCT(IGNEW,2)=0
68298 MCT(IRNEW,1)=0
68299 MCT(IRNEW,2)=0
68300
68301C...Trivial colour flow for l->lgamma and q->qgamma.
68302 IF(IABS(KCHA).EQ.3) THEN
68303 K(I,4)=INEW
68304 K(I,5)=IGNEW
68305 ELSEIF(KCHA.NE.0) THEN
68306 IF(K(I,4).NE.0) THEN
68307 K(I,4)=K(I,4)+INEW
68308 K(INEW,4)=MSTU(5)*I
68309 MCT(INEW,1)=MCT(I,1)
68310 ENDIF
68311 IF(K(I,5).NE.0) THEN
68312 K(I,5)=K(I,5)+INEW
68313 K(INEW,5)=MSTU(5)*I
68314 MCT(INEW,2)=MCT(I,2)
68315 ENDIF
68316
68317C...Set colour flow for q->qg and g->gg.
68318 ELSEIF(KFQ.EQ.0) THEN
68319 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68320 K(IGNEW,JCOLP)=MSTU(5)*I
68321 K(INEW,JCOLP)=MSTU(5)*IGNEW
68322 K(IGNEW,JCOLN)=MSTU(5)*INEW
68323 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68324 NCT=NCT+1
68325 MCT(INEW,JCOLP-3)=NCT
68326 MCT(IGNEW,JCOLN-3)=NCT
68327 IF(MOCT.GE.1) THEN
68328 K(I,JCOLN)=K(I,JCOLN)+INEW
68329 K(INEW,JCOLN)=MSTU(5)*I
68330 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68331 ENDIF
68332
68333C...Set colour flow for g->qqbar.
68334 ELSE
68335 K(I,JCOLN)=K(I,JCOLN)+INEW
68336 K(INEW,JCOLN)=MSTU(5)*I
68337 K(I,JCOLP)=K(I,JCOLP)+IGNEW
68338 K(IGNEW,JCOLP)=MSTU(5)*I
68339 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
68340 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
68341 ENDIF
68342
68343C...Daughter info for colourless recoiling parton.
68344 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
68345 K(IR,4)=IRNEW
68346 K(IR,5)=IRNEW
68347 K(IRNEW,4)=0
68348 K(IRNEW,5)=0
68349
68350C...Colour of recoiling parton sails through unchanged.
68351 ELSE
68352 IF(K(IR,4).NE.0) THEN
68353 K(IR,4)=K(IR,4)+IRNEW
68354 K(IRNEW,4)=MSTU(5)*IR
68355 MCT(IRNEW,1)=MCT(IR,1)
68356 ENDIF
68357 IF(K(IR,5).NE.0) THEN
68358 K(IR,5)=K(IR,5)+IRNEW
68359 K(IRNEW,5)=MSTU(5)*IR
68360 MCT(IRNEW,2)=MCT(IR,2)
68361 ENDIF
68362 ENDIF
68363
68364C...Vertex information trivial.
68365 DO 450 J=1,5
68366 V(INEW,J)=V(I,J)
68367 V(IGNEW,J)=V(I,J)
68368 V(IRNEW,J)=V(IR,J)
68369 450 CONTINUE
68370
68371C...Update list of old radiators.
68372 DO 460 IEVOL=1,NEVOL
68373 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
68374 IPOS(IEVOL)=INEW
68375 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
68376 IREC(IEVOL)=IRNEW
68377 IFLG(IEVOL)=0
68378 ELSEIF(IPOS(IEVOL).EQ.I) THEN
68379 IPOS(IEVOL)=INEW
68380 IFLG(IEVOL)=0
68381 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
68382 IPOS(IEVOL)=IRNEW
68383 IREC(IEVOL)=INEW
68384 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
68385 IFLG(IEVOL)=0
68386 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
68387 IPOS(IEVOL)=IRNEW
68388 IFLG(IEVOL)=0
68389 ENDIF
68390C...Update links of old connected partons.
68391 IF(IREC(IEVOL).EQ.I) THEN
68392 IREC(IEVOL)=INEW
68393 IFLG(IEVOL)=0
68394 ELSEIF(IREC(IEVOL).EQ.IR) THEN
68395 IREC(IEVOL)=IRNEW
68396 IFLG(IEVOL)=0
68397 ENDIF
68398 460 CONTINUE
68399
68400C...q->qg or g->gg: create new gluon radiators.
68401 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
68402 NEVOL=NEVOL+1
68403 IPOS(NEVOL)=INEW
68404 IREC(NEVOL)=IGNEW
68405 IFLG(NEVOL)=0
68406 ISCOL(NEVOL)=KCOL
68407 ISCHG(NEVOL)=0
68408 PTSCA(NEVOL)=SQRT(PT2)
68409 NEVOL=NEVOL+1
68410 IPOS(NEVOL)=IGNEW
68411 IREC(NEVOL)=INEW
68412 IFLG(NEVOL)=0
68413 ISCOL(NEVOL)=-KCOL
68414 ISCHG(NEVOL)=0
68415 PTSCA(NEVOL)=PTSCA(NEVOL-1)
68416 ENDIF
68417
68418C...Update matrix elements parton list and add new for g/gamma->qqbar.
68419 DO 470 IME=1,NMESYS
68420 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
68421 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
68422 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
68423 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
68424 470 CONTINUE
68425 IF(KFQ.NE.0) THEN
68426 NMESYS=NMESYS+1
68427 MESYS(NMESYS,0)=66
68428 MESYS(NMESYS,1)=INEW
68429 MESYS(NMESYS,2)=IGNEW
68430 NMESYS=NMESYS+1
68431 MESYS(NMESYS,0)=102
68432 MESYS(NMESYS,1)=INEW
68433 MESYS(NMESYS,2)=IGNEW
68434 ENDIF
68435
68436C...Global statistics.
68437 MINT(353)=MINT(353)+1
68438 VINT(353)=VINT(353)+PTCOR
68439 IF (MINT(353).EQ.1) VINT(358)=PTCOR
68440
68441C...Loopback for more emissions if enough space.
68442 PT2CMX=PT2
68443 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
68444 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
68445 GOTO 280
68446 ELSE
68447 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
68448 ENDIF
68449
68450C...Done.
68451 480 CONTINUE
68452
68453 RETURN
68454 END
68455
68456C*********************************************************************
68457
68458C...PYMAEL
68459C...Auxiliary to PYSHOW and PYPTFS.
68460C...Matrix elements for gluon (or photon) emission from
68461C...a two-body state; to be used by the parton shower routine.
68462C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
68463C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
68464C... = (alpha-strong/2 pi) * CF * PYMAEL,
68465C...i.e. normalization is such that one recovers the familiar
68466C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
68467C...Coupling structure:
68468C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
68469C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
68470C... = 16-19 : q -> q V
68471C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
68472C... = 26-29 : q -> q S
68473C... = 31-34 : V -> ~q ~qbar (~q = squark)
68474C... = 36-39 : ~q -> ~q V
68475C... = 41-44 : S -> ~q ~qbar
68476C... = 46-49 : ~q -> ~q S
68477C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
68478C... = 56-59 : ~q -> q chi
68479C... = 61-64 : q -> ~q chi
68480C... = 66-69 : ~g -> q ~qbar
68481C... = 71-74 : ~q -> q ~g
68482C... = 76-79 : q -> ~q ~g
68483C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
68484C...Note that the order of the decay products is important.
68485C...In each set of four, the variants are ordered as:
68486C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
68487C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
68488C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
68489C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
68490
68491 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
68492
68493C...Double precision and integer declarations.
68494 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68495 IMPLICIT INTEGER(I-N)
68496
68497C...Check input values. Return zero outside allowed phase space.
68498 PYMAEL=0D0
68499 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
68500 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
68501 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
68502 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
68503 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
68504 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
68505
68506C...Initial values and flags.
68507 ICLASS=NI/5
68508 ICOMBI=NI-5*ICLASS
68509 ISSET1=0
68510 ISSET2=0
68511 ISSET4=0
68512
68513C... Phase space.
68514 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
68515
68516C...Eikonal expression; also acts as default.
68517 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
68518 RLO=PS
68519 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
68520 ANUM=0D0
68521 ELSEIF(ICOMBI.EQ.2) THEN
68522 ANUM=(2D0-X1-X2)**2
68523 ELSEIF(ICOMBI.EQ.3) THEN
68524 ANUM=ALPCOR*(2D0-X1-X2)**2
68525 ELSE
68526 ANUM=0.5D0*(2D0-X1-X2)**2
68527 ENDIF
68528 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
68529 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
68530 & R1**2/(1D0+R2**2-R1**2-X2)**2-
68531 & R2**2/(1D0+R1**2-R2**2-X1)**2)
68532 ICOMBI=0
68533
68534C...V -> q qbar (V = gamma*/Z0/W+-/...).
68535 ELSEIF(ICLASS.EQ.2) THEN
68536 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68537 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68538 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
68539 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
68540 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
68541 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
68542 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68543 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
68544 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
68545 & (-1+R1**2-R2**2+X2)**2
68546 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68547 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68548 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
68549 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68550 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
68551 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68552 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68553 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
68554 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
68555 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
68556 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
68557 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
68558 RFO1=RFO1/2.D0
68559 ISSET1=1
68560 ENDIF
68561 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68562 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
68563 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
68564 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
68565 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
68566 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
68567 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
68568 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
68569 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
68570 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
68571 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
68572 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
68573 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
68574 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
68575 & -X1-X2)**2+X1*(2-X1-X2)**2)/
68576 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68577 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
68578 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
68579 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
68580 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
68581 & +X2)/(-1-R1**2+R2**2+X1)**2
68582 RFO2=RFO2/2.D0
68583 ISSET2=1
68584 ENDIF
68585 IF(ICOMBI.EQ.4) THEN
68586 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
68587 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
68588 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
68589 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
68590 & (-1-R1**2+R2**2+X1)**2
68591 RFO4=RFO4
68592 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
68593 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
68594 & -R1**2*X2**2+X1*X2**2)/
68595 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68596 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
68597 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
68598 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
68599 & (-1+R1**2-R2**2+X2)**2
68600 RFO4=RFO4/2.D0
68601 ISSET4=1
68602 ENDIF
68603
68604C...q -> q V.
68605 ELSEIF(ICLASS.EQ.3) THEN
68606 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68607 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
68608 & +R1**2*R2**2-2D0*R2**4)
68609 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
68610 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
68611 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
68612 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
68613 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
68614 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
68615 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68616 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
68617 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68618 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
68619 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68620 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68621 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
68622 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
68623 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68624 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
68625 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68626 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
68627 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
68628 ISSET1=1
68629 ENDIF
68630 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68631 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
68632 & +R1**2*R2**2-2D0*R2**4)
68633 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
68634 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
68635 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
68636 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
68637 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
68638 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
68639 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68640 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
68641 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
68642 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
68643 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68644 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68645 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68646 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
68647 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
68648 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
68649 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68650 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68651 & +X1*X2**2)/(-2+X1+X2)**2
68652 ISSET2=1
68653 ENDIF
68654 IF(ICOMBI.EQ.4) THEN
68655 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
68656 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
68657 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
68658 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
68659 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
68660 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68661 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
68662 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
68663 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
68664 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
68665 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
68666 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
68667 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
68668 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
68669 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
68670 & +X1*X2**2)/(2-X1-X2)**2
68671 ISSET4=1
68672 ENDIF
68673
68674C...S -> q qbar (S = h0/H0/A0/H+-/...).
68675 ELSEIF(ICLASS.EQ.4) THEN
68676 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68677 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
68678 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68679 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68680 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68681 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
68682 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
68683 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68684 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68685 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68686 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68687 ISSET1=1
68688 ENDIF
68689 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68690 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
68691 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68692 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68693 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68694 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68695 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68696 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68697 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
68698 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
68699 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
68700 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68701 ISSET2=1
68702 ENDIF
68703 IF(ICOMBI.EQ.4) THEN
68704 RLO4=PS*(1D0-R1**2-R2**2)
68705 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
68706 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
68707 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
68708 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
68709 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68710 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
68711 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68712 ISSET4=1
68713 ENDIF
68714
68715C...q -> q S.
68716 ELSEIF(ICLASS.EQ.5) THEN
68717 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68718 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68719 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68720 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68721 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
68722 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68723 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68724 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68725 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68726 & (-1+R1**2-R2**2+X2)**2
68727 ISSET1=1
68728 ENDIF
68729 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68730 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68731 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
68732 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68733 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
68734 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68735 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
68736 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68737 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68738 & (-1+R1**2-R2**2+X2)**2
68739 ISSET2=1
68740 ENDIF
68741 IF(ICOMBI.EQ.4) THEN
68742 RLO4=PS*(1D0+R1**2-R2**2)
68743 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
68744 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
68745 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
68746 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
68747 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68748 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68749 ISSET4=1
68750 ENDIF
68751
68752C...V -> ~q ~qbar (~q = squark).
68753 ELSEIF(ICLASS.EQ.6) THEN
68754 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68755 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
68756 & (-1-R1**2+R2**2+X1)**2
68757 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
68758 & (-1-R1**2+R2**2+X1)
68759 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
68760 & /(-1+R1**2-R2**2+X2)**2
68761 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
68762 & (-1+R1**2-R2**2+X2)
68763 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
68764 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
68765 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
68766 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68767 ISSET1=1
68768
68769C...~q -> ~q V.
68770 ELSEIF(ICLASS.EQ.7) THEN
68771 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
68772 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
68773 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
68774 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
68775 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68776 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
68777 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
68778 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
68779 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
68780 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
68781 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
68782 & (3*(-2+X1+X2))
68783 RFO1=3D0*RFO1/8D0
68784 ISSET1=1
68785
68786C...S -> ~q ~qbar.
68787 ELSEIF(ICLASS.EQ.8) THEN
68788 RLO1=PS
68789 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
68790 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
68791 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
68792 & -R1**2*X2**2+X1*X2**2)/
68793 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
68794 RFO1=2D0*RFO1
68795 ISSET1=1
68796
68797C...~q -> ~q S.
68798 ELSEIF(ICLASS.EQ.9) THEN
68799 RLO1=PS
68800 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68801 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68802 & -(X1+X2)/(-2+X1+X2)**2
68803 ISSET1=1
68804
68805C...chi -> q ~qbar (chi = neutralino/chargino).
68806 ELSEIF(ICLASS.EQ.10) THEN
68807 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68808 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68809 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68810 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
68811 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68812 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68813 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
68814 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68815 & (-1+R1**2-R2**2+X2)**2
68816 ISSET1=1
68817 ENDIF
68818 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68819 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
68820 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
68821 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
68822 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
68823 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68824 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
68825 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68826 & (-1+R1**2-R2**2+X2)**2
68827 ISSET2=1
68828 ENDIF
68829 IF(ICOMBI.EQ.4) THEN
68830 RLO4=PS*(1+R1**2-R2**2)
68831 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
68832 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
68833 & +X2+R1**2*X2-X1*X2/2)/
68834 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
68835 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
68836 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
68837 ISSET4=1
68838 ENDIF
68839
68840C...~q -> q chi.
68841 ELSEIF(ICLASS.EQ.11) THEN
68842 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68843 RLO1=PS*(1D0-(R1+R2)**2)
68844 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68845 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68846 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68847 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68848 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68849 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68850 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68851 ISSET1=1
68852 ENDIF
68853 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68854 RLO2=PS*(1D0-(R1-R2)**2)
68855 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
68856 & (-2+X1+X2)**2
68857 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68858 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
68859 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
68860 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
68861 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68862 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
68863 ISSET2=1
68864 ENDIF
68865 IF(ICOMBI.EQ.4) THEN
68866 RLO4=PS*(1D0-R1**2-R2**2)
68867 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
68868 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
68869 & +3*R1**2*X2-R2**2*X2-X1*X2)/
68870 & (-1+R1**2-R2**2+X2)**2
68871 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
68872 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
68873 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68874 ISSET4=1
68875 ENDIF
68876
68877C...q -> ~q chi.
68878 ELSEIF(ICLASS.EQ.12) THEN
68879 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68880 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
68881 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68882 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
68883 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
68884 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
68885 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68886 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68887 ISSET1=1
68888 END IF
68889 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68890 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
68891 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
68892 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
68893 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
68894 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
68895 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
68896 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68897 ISSET2=1
68898 END IF
68899 IF(ICOMBI.EQ.4) THEN
68900 RLO4=PS*(1D0-R1**2+R2**2)
68901 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
68902 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
68903 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
68904 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
68905 & +R1**2*X2-X1*X2/2-X2**2/2)/
68906 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
68907 ISSET4=1
68908 END IF
68909
68910C...~g -> q ~qbar.
68911 ELSEIF(ICLASS.EQ.13) THEN
68912 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68913 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
68914 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
68915 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
68916 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
68917 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
68918 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
68919 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
68920 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
68921 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
68922 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
68923 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
68924 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
68925 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68926 & (3*(-1+R1**2-R2**2+X2)**2)
68927 RFO1=3D0*RFO1/4D0
68928 ISSET1=1
68929 ENDIF
68930 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68931 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
68932 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
68933 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
68934 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
68935 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
68936 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
68937 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
68938 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
68939 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
68940 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
68941 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68942 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
68943 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
68944 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68945 & (3*(-1+R1**2-R2**2+X2)**2)
68946 RFO2=3D0*RFO2/4D0
68947 ISSET2=1
68948 ENDIF
68949 IF(ICOMBI.EQ.4) THEN
68950 RLO4=PS*(1D0+R1**2-R2**2)
68951 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
68952 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
68953 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
68954 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
68955 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
68956 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68957 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
68958 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68959 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
68960 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
68961 & (3*(-1+R1**2-R2**2+X2)**2)
68962 RFO4=3D0*RFO4/8D0
68963 ISSET4=1
68964 ENDIF
68965
68966C...~q -> q ~g.
68967 ELSEIF(ICLASS.EQ.14) THEN
68968 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
68969 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
68970 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68971 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68972 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68973 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
68974 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
68975 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
68976 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
68977 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
68978 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
68979 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
68980 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
68981 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
68982 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
68983 RFO1=RFO1
68984 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
68985 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
68986 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
68987 RFO1=9D0*RFO1/64D0
68988 ISSET1=1
68989 ENDIF
68990 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
68991 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
68992 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
68993 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
68994 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
68995 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
68996 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
68997 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
68998 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
68999 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
69000 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
69001 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
69002 RFO2=RFO2
69003 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
69004 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
69005 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
69006 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
69007 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
69008 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69009 RFO2=9D0*RFO2/64D0
69010 ISSET2=1
69011 ENDIF
69012 IF(ICOMBI.EQ.4) THEN
69013 RLO4=PS*(1-R1**2-R2**2)
69014 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
69015 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
69016 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
69017 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
69018 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
69019 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
69020 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
69021 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
69022 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
69023 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
69024 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
69025 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
69026 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
69027 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
69028 RFO4=9D0*RFO4/128D0
69029 ISSET4=1
69030 ENDIF
69031
69032C...q -> ~q ~g.
69033 ELSEIF(ICLASS.EQ.15) THEN
69034 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
69035 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
69036 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69037 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
69038 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
69039 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
69040 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
69041 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69042 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
69043 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
69044 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69045 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
69046 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
69047 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
69048 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69049 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69050 RFO1=9D0*RFO1/32D0
69051 ISSET1=1
69052 END IF
69053 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
69054 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
69055 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
69056 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
69057 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
69058 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
69059 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
69060 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
69061 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
69062 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
69063 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69064 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
69065 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
69066 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
69067 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
69068 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69069 RFO2=9D0*RFO2/32D0
69070 ISSET2=1
69071 END IF
69072 IF(ICOMBI.EQ.4) THEN
69073 RLO4=PS*(1D0-R1**2+R2**2)
69074 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
69075 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
69076 & -R2**2*X2/2-X1*X2/2)/
69077 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
69078 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
69079 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
69080 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
69081 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
69082 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
69083 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
69084 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
69085 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
69086 RFO4=9D0*RFO4/64D0
69087 ISSET4=1
69088 END IF
69089
69090C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
69091 ELSEIF(ICLASS.EQ.16) THEN
69092 RLO=PS
69093 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
69094 ANUM=0D0
69095 ELSEIF(ICOMBI.EQ.2) THEN
69096 ANUM=(2D0-X1-X2)**2
69097 ELSEIF(ICOMBI.EQ.3) THEN
69098 ANUM=ALPCOR*(2D0-X1-X2)**2
69099 ELSE
69100 ANUM=0.5D0*(2D0-X1-X2)**2
69101 ENDIF
69102 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
69103 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
69104 & R1**2/(1D0+R2**2-R1**2-X2)**2-
69105 & R2**2/(1D0+R1**2-R2**2-X1)**2)
69106 RFO=9D0*RFO/4D0
69107 ICOMBI=0
69108 ENDIF
69109
69110C...Find relevant LO and FO expression.
69111 IF(ICOMBI.EQ.0) THEN
69112 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
69113 RLO=RLO1
69114 RFO=RFO1
69115 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
69116 RLO=RLO2
69117 RFO=RFO2
69118 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69119 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
69120 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
69121 ELSEIF(ISSET4.EQ.1) THEN
69122 RLO=RLO4
69123 RFO=RFO4
69124 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
69125 RLO=0.5D0*(RLO1+RLO2)
69126 RFO=0.5D0*(RFO1+RFO2)
69127 ELSEIF(ISSET1.EQ.1) THEN
69128 RLO=RLO1
69129 RFO=RFO1
69130 ELSE
69131 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
69132 RLO=1D0
69133 RFO=0D0
69134 ENDIF
69135
69136C...Output.
69137 PYMAEL=RFO/RLO
69138
69139 RETURN
69140 END
69141
69142C*********************************************************************
69143
69144C...PYBOEI
69145C...Modifies an event so as to approximately take into account
69146C...Bose-Einstein effects according to a simple phenomenological
69147C...parametrization.
69148
69149 SUBROUTINE PYBOEI(NSAV)
69150
69151C...Double precision and integer declarations.
69152 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69153 IMPLICIT INTEGER(I-N)
69154 INTEGER PYK,PYCHGE,PYCOMP
69155C...Parameter statement to help give large particle numbers.
69156 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69157 &KEXCIT=4000000,KDIMEN=5000000)
69158C...Commonblocks.
69159 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69160 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69161 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69162 COMMON/PYINT1/MINT(400),VINT(400)
69163 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
69164C...Local arrays and data.
69165 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
69166 &BEIW(100),BEI3W(100)
69167 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
69168C...Statement function: squared invariant mass.
69169 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
69170 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
69171
69172C...Boost event to overall CM frame. Calculate CM energy.
69173 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
69174 DO 100 J=1,4
69175 DPS(J)=0D0
69176 100 CONTINUE
69177 DO 120 I=1,N
69178 KFA=IABS(K(I,2))
69179 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
69180 & .AND.K(I,3).GT.0) THEN
69181 KFMA=IABS(K(K(I,3),2))
69182 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
69183 ENDIF
69184 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
69185 DO 110 J=1,4
69186 DPS(J)=DPS(J)+P(I,J)
69187 110 CONTINUE
69188 120 CONTINUE
69189 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
69190 &-DPS(3)/DPS(4))
69191 PECM=0D0
69192 DO 130 I=1,N
69193 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
69194 130 CONTINUE
69195
69196C...Check if we have separated strings
69197
69198C...Reserve copy of particles by species at end of record.
69199 IWP=0
69200 IWN=0
69201 NBE(0)=N+MSTU(3)
69202 NMAX=NBE(0)
69203 SMMIN=PECM
69204 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
69205 NBE(IBE)=NBE(IBE-1)
69206 DO 180 I=NSAV+1,N
69207 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
69208 DO 140 IIBE=1,IBE-1
69209 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
69210 140 CONTINUE
69211 ELSE
69212 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
69213 ENDIF
69214 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
69215 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
69216 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
69217 RETURN
69218 ENDIF
69219 NBE(IBE)=NBE(IBE)+1
69220 NMAX=NBE(IBE)
69221 K(NBE(IBE),1)=I
69222 K(NBE(IBE),2)=0
69223 K(NBE(IBE),3)=0
69224 K(NBE(IBE),4)=0
69225 K(NBE(IBE),5)=0
69226 P(NBE(IBE),1)=0.0D0
69227 P(NBE(IBE),2)=0.0D0
69228 P(NBE(IBE),3)=0.0D0
69229 P(NBE(IBE),4)=0.0D0
69230 P(NBE(IBE),5)=0.0D0
69231 SMMIN=MIN(SMMIN,P(I,5))
69232C...Check if particles comes from different W's or Z's
69233 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
69234 IM=I
69235 150 IF(K(IM,3).GT.0) THEN
69236 IM=K(IM,3)
69237 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
69238 K(NBE(IBE),5)=IM
69239 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
69240 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
69241 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
69242 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
69243 ENDIF
69244 ENDIF
69245C...Check if particles comes from different strings.
69246 IF(PARJ(94).GT.0.0D0) THEN
69247 IM=I
69248 160 IF(K(IM,3).GT.0) THEN
69249 IM=K(IM,3)
69250 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
69251 K(NBE(IBE),5)=IM
69252 ENDIF
69253 ENDIF
69254 DO 170 J=1,3
69255 P(NBE(IBE),J)=0D0
69256 V(NBE(IBE),J)=0D0
69257 170 CONTINUE
69258 P(NBE(IBE),5)=-1.0D0
69259 180 CONTINUE
69260 190 CONTINUE
69261 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
69262
69263C...Calculate separation between W+ and W- or between two Z0's.
69264C...No separation if there has been re-connections.
69265 SIGW=PARJ(93)
69266 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
69267 IF(K(IWP,2).EQ.23) THEN
69268 DMW=PMAS(23,1)
69269 DGW=PMAS(23,2)
69270 ELSE
69271 DMW=PMAS(24,1)
69272 DGW=PMAS(24,2)
69273 ENDIF
69274 DMP=P(IWP,5)
69275 DMN=P(IWN,5)
69276 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
69277 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
69278 TAUP=-TAUPD*LOG(PYR(IDUM))
69279 TAUN=-TAUND*LOG(PYR(IDUM))
69280 DXP=TAUP*PYP(IWP,8)/DMP
69281 DXN=TAUN*PYP(IWN,8)/DMN
69282 DX=DXP+DXN
69283 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
69284 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
69285 ENDIF
69286
69287C...Add separation between strings.
69288 IF(PARJ(94).GT.0.0D0) THEN
69289 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
69290 IWP=-1
69291 IWN=-1
69292 ENDIF
69293
69294 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
69295 DO 220 IBE=1,MIN(9,MSTJ(52))
69296 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
69297 Q2MIN=PECM**2
69298 I1=K(I1M,1)
69299 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
69300 IF(I2M.EQ.I1M) GOTO 200
69301 I2=K(I2M,1)
69302 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
69303 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
69304 & (P(I1,5)+P(I2,5))**2
69305 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
69306 Q2MIN=Q2
69307 ENDIF
69308 200 CONTINUE
69309 P(I1M,5)=Q2MIN
69310 210 CONTINUE
69311 220 CONTINUE
69312 ENDIF
69313
69314C...Tabulate integral for subsequent momentum shift.
69315 DO 400 IBE=1,MIN(9,MSTJ(52))
69316 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
69317 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
69318 & .LE.1) GOTO 270
69319 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
69320 & NBE(7)-NBE(6)).LE.1) GOTO 270
69321 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
69322 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
69323 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
69324 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
69325 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
69326 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
69327 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
69328 QDELW=0.1D0*MIN(PMHQ,SIGW)
69329 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
69330 IF(MSTJ(51).EQ.1) THEN
69331 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
69332 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
69333 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
69334 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
69335 BEEX=EXP(0.5D0*QDEL/PARJ(93))
69336 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
69337 BEEXW=EXP(0.5D0*QDELW/SIGW)
69338 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
69339 BERT=EXP(-QDEL/PARJ(93))
69340 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
69341 BERTW=EXP(-QDELW/SIGW)
69342 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
69343 ELSE
69344 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
69345 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
69346 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
69347 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
69348 ENDIF
69349 DO 230 IBIN=1,NBIN
69350 QBIN=QDEL*(IBIN-0.5D0)
69351 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69352 IF(MSTJ(51).EQ.1) THEN
69353 BEEX=BEEX*BERT
69354 BEI(IBIN)=BEI(IBIN)*BEEX
69355 ELSE
69356 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
69357 ENDIF
69358 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
69359 230 CONTINUE
69360 DO 240 IBIN=1,NBIN3
69361 QBIN=QDEL3*(IBIN-0.5D0)
69362 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69363 IF(MSTJ(51).EQ.1) THEN
69364 BEEX3=BEEX3*BERT3
69365 BEI3(IBIN)=BEI3(IBIN)*BEEX3
69366 ELSE
69367 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
69368 ENDIF
69369 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
69370 240 CONTINUE
69371 DO 250 IBIN=1,NBINW
69372 QBIN=QDELW*(IBIN-0.5D0)
69373 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
69374 IF(MSTJ(51).EQ.1) THEN
69375 BEEXW=BEEXW*BERTW
69376 BEIW(IBIN)=BEIW(IBIN)*BEEXW
69377 ELSE
69378 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
69379 ENDIF
69380 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
69381 250 CONTINUE
69382 DO 260 IBIN=1,NBIN3W
69383 QBIN=QDEL3W*(IBIN-0.5D0)
69384 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
69385 & SQRT(QBIN**2+PMHQ**2)
69386 IF(MSTJ(51).EQ.1) THEN
69387 BEEX3W=BEEX3W*BERT3W
69388 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
69389 ELSE
69390 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
69391 ENDIF
69392 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
69393 260 CONTINUE
69394
69395C...Loop through particle pairs and find old relative momentum.
69396 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
69397 I1=K(I1M,1)
69398 DO 380 I2M=I1M+1,NBE(IBE)
69399 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
69400 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
69401 I2=K(I2M,1)
69402 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
69403 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
69404 IF(Q2OLD.LE.0.0D0) GOTO 380
69405 QOLD=SQRT(Q2OLD)
69406
69407C...Calculate new relative momentum.
69408 QMOV=0.0D0
69409 QMOV3=0.0D0
69410 QMOVW=0.0D0
69411 QMOV3W=0.0D0
69412 IF(QOLD.LT.1D-3*QDEL) THEN
69413 GOTO 280
69414 ELSEIF(QOLD.LE.QDEL) THEN
69415 QMOV=QOLD/3D0
69416 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
69417 RBIN=QOLD/QDEL
69418 IBIN=RBIN
69419 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
69420 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
69421 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69422 ELSE
69423 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69424 ENDIF
69425 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
69426 IF(QOLD.LT.1D-3*QDEL3) THEN
69427 GOTO 290
69428 ELSEIF(QOLD.LE.QDEL3) THEN
69429 QMOV3=QOLD/3D0
69430 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
69431 RBIN3=QOLD/QDEL3
69432 IBIN3=RBIN3
69433 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
69434 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
69435 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69436 ELSE
69437 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69438 ENDIF
69439 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
69440 RSCALE=1.0D0
69441 IF(MSTJ(54).EQ.2)
69442 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
69443 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
69444 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
69445
69446 IF(QOLD.LT.1D-3*QDELW) THEN
69447 GOTO 300
69448 ELSEIF(QOLD.LE.QDELW) THEN
69449 QMOVW=QOLD/3D0
69450 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
69451 RBINW=QOLD/QDELW
69452 IBINW=RBINW
69453 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
69454 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
69455 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
69456 ELSE
69457 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69458 ENDIF
69459 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
69460 IF(QOLD.LT.1D-3*QDEL3W) THEN
69461 GOTO 310
69462 ELSEIF(QOLD.LE.QDEL3W) THEN
69463 QMOV3W=QOLD/3D0
69464 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
69465 RBIN3W=QOLD/QDEL3W
69466 IBIN3W=RBIN3W
69467 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
69468 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
69469 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69470 ELSE
69471 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
69472 ENDIF
69473 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
69474 IF(MSTJ(54).EQ.2)
69475 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
69476
69477 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
69478 DO 330 J=1,3
69479 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
69480 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
69481 330 CONTINUE
69482 IF(MSTJ(54).GE.1) THEN
69483 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
69484 DO 340 J=1,3
69485 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
69486 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
69487 340 CONTINUE
69488 ELSEIF(MSTJ(54).LE.-1) THEN
69489 EDEL=P(I1,4)+P(I2,4)-
69490 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
69491 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69492 & (P(I1,3)-P(I2,3))**2
69493 WMAX=-1.0D20
69494 MI3=0
69495 MI4=0
69496 S12=SDIP(I1,I2)
69497 SM1=(P(I1,5)+SMMIN)**2
69498 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69499 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
69500 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
69501 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69502 & K(I3M,5).NE.K(I1M,5)) GOTO 360
69503 I3=K(I3M,1)
69504 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
69505 S13=SDIP(I1,I3)
69506 S23=SDIP(I2,I3)
69507 SM3=(P(I3,5)+SMMIN)**2
69508 IF(MSTJ(54).EQ.-2) THEN
69509 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
69510 & S23*MIN(SM1,SM3))*SM1)
69511 ELSE
69512 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
69513 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
69514 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
69515 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
69516 ENDIF
69517 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
69518 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
69519 & GOTO 360
69520 ELSE
69521 IF(WMAX*WI.GE.1.0) GOTO 360
69522 ENDIF
69523 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
69524 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
69525 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
69526 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
69527 & K(I4M,5).NE.K(I1M,5)) GOTO 350
69528 I4=K(I4M,1)
69529 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
69530 & GOTO 350
69531 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
69532 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69533 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
69534 & GOTO 350
69535 IF(MSTJ(54).EQ.-2) THEN
69536 S14=SDIP(I1,I4)
69537 S24=SDIP(I2,I4)
69538 S34=SDIP(I3,I4)
69539 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
69540 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
69541 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
69542 W=MIN(W,MIN(S23,S24)*S13*S14)
69543 W=1.0D0/W
69544 ELSE
69545C...weight=1-cos(theta)/mtot2
69546 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
69547 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
69548 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
69549 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
69550 W=1.0D0/S1234
69551 IF(W.LE.WMAX) GOTO 350
69552 ENDIF
69553 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
69554 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
69555 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
69556 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
69557 IF(W.LE.WMAX) GOTO 350
69558 MI3=I3M
69559 MI4=I4M
69560 WMAX=W
69561 350 CONTINUE
69562 360 CONTINUE
69563 IF(MI4.EQ.0) GOTO 380
69564 I3=K(MI3,1)
69565 I4=K(MI4,1)
69566 EOLD=P(I3,4)+P(I4,4)
69567 ENEW=EOLD+EDEL
69568 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
69569 & (P(I3,3)+P(I4,3))**2
69570 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
69571 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
69572 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
69573 DO 370 J=1,3
69574 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
69575 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
69576 370 CONTINUE
69577 ENDIF
69578 380 CONTINUE
69579 390 CONTINUE
69580 400 CONTINUE
69581
69582C...Shift momenta and recalculate energies.
69583 ESUMP=0.0D0
69584 ESUM=0.0D0
69585 PROD=0.0D0
69586 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69587 I=K(IM,1)
69588 ESUMP=ESUMP+P(I,4)
69589 DO 410 J=1,3
69590 P(I,J)=P(I,J)+P(IM,J)
69591 410 CONTINUE
69592 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69593 ESUM=ESUM+P(I,4)
69594 DO 420 J=1,3
69595 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69596 420 CONTINUE
69597 430 CONTINUE
69598
69599 PARJ(96)=0.0D0
69600 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
69601 440 ALPHA=(ESUMP-ESUM)/PROD
69602 PARJ(96)=PARJ(96)+ALPHA
69603 PROD=0.0D0
69604 ESUM=0.0D0
69605 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
69606 I=K(IM,1)
69607 DO 450 J=1,3
69608 P(I,J)=P(I,J)+ALPHA*V(IM,J)
69609 450 CONTINUE
69610 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69611 ESUM=ESUM+P(I,4)
69612 DO 460 J=1,3
69613 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
69614 460 CONTINUE
69615 470 CONTINUE
69616 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
69617 & GOTO 440
69618 ENDIF
69619
69620C...Rescale all momenta for energy conservation.
69621 PES=0D0
69622 PQS=0D0
69623 DO 480 I=1,N
69624 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
69625 PES=PES+P(I,4)
69626 PQS=PQS+P(I,5)**2/P(I,4)
69627 480 CONTINUE
69628 PARJ(95)=PES-PECM
69629 FAC=(PECM-PQS)/(PES-PQS)
69630 DO 500 I=1,N
69631 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
69632 DO 490 J=1,3
69633 P(I,J)=FAC*P(I,J)
69634 490 CONTINUE
69635 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
69636 500 CONTINUE
69637
69638C...Boost back to correct reference frame.
69639 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
69640 DO 520 I=1,N
69641 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
69642 520 CONTINUE
69643
69644 RETURN
69645 END
69646
69647C*********************************************************************
69648
69649C...PYBESQ
69650C...Calculates the momentum shift in a system of two particles assuming
69651C...the relative momentum squared should be shifted to Q2NEW. NI is the
69652C...last position occupied in /PYJETS/.
69653
69654 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
69655
69656C...Double precision and integer declarations.
69657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69658 IMPLICIT INTEGER(I-N)
69659 INTEGER PYK,PYCHGE,PYCOMP
69660C...Parameter statement to help give large particle numbers.
69661 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69662 &KEXCIT=4000000,KDIMEN=5000000)
69663C...Commonblocks.
69664 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69665 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69666 SAVE /PYJETS/,/PYDAT1/
69667C...Local arrays and data.
69668 DIMENSION DP(5)
69669 SAVE HC1
69670
69671 IF(MSTJ(55).EQ.0) THEN
69672 DQ2=Q2NEW-Q2OLD
69673 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
69674 & (P(I1,3)-P(I2,3))**2
69675 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
69676 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
69677 SE=P(I1,4)+P(I2,4)
69678 DE=P(I1,4)-P(I2,4)
69679 DQ2SE=DQ2+SE**2
69680 DA=SE*DE*DP12-DP2*DQ2SE
69681 DB=DP2*DQ2SE-DP12**2
69682 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
69683 DO 100 J=1,3
69684 PD=HA*(P(I1,J)-P(I2,J))
69685 P(NI+1,J)=PD
69686 P(NI+2,J)=-PD
69687 100 CONTINUE
69688 RETURN
69689 ENDIF
69690
69691 K(NI+1,1)=1
69692 K(NI+2,1)=1
69693 DO 110 J=1,5
69694 P(NI+1,J)=P(I1,J)
69695 P(NI+2,J)=P(I2,J)
69696 DP(J)=P(I1,J)+P(I2,J)
69697 110 CONTINUE
69698
69699C...Boost to cms and rotate first particle to z-axis
69700 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
69701 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
69702 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
69703 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
69704 S=Q2NEW+(P(I1,5)+P(I2,5))**2
69705 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
69706 P(NI+1,1)=0.0D0
69707 P(NI+1,2)=0.0D0
69708 P(NI+1,3)=PZ
69709 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
69710 P(NI+2,1)=0.0D0
69711 P(NI+2,2)=0.0D0
69712 P(NI+2,3)=-PZ
69713 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
69714 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
69715 CALL PYROBO(NI+1,NI+2,THE,PHI,
69716 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
69717
69718 DO 120 J=1,3
69719 P(NI+1,J)=P(NI+1,J)-P(I1,J)
69720 P(NI+2,J)=P(NI+2,J)-P(I2,J)
69721 120 CONTINUE
69722
69723 RETURN
69724 END
69725
69726C*********************************************************************
69727
69728C...PYMASS
69729C...Gives the mass of a particle/parton.
69730
69731 FUNCTION PYMASS(KF)
69732
69733C...Double precision and integer declarations.
69734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69735 IMPLICIT INTEGER(I-N)
69736 INTEGER PYK,PYCHGE,PYCOMP
69737C...Commonblocks.
69738 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69739 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69740 SAVE /PYDAT1/,/PYDAT2/
69741
69742C...Reset variables. Compressed code. Special case for popcorn diquarks.
69743 PYMASS=0D0
69744 KFA=IABS(KF)
69745 KC=PYCOMP(KF)
69746 IF(KC.EQ.0) THEN
69747 MSTJ(93)=0
69748 RETURN
69749 ENDIF
69750
69751C...Guarantee use of constituent masses for internal checks.
69752 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
69753 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
69754 IF(KFA.LE.5) THEN
69755 PYMASS=PARF(100+KFA)
69756 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
69757 ELSEIF(KFA.LE.10) THEN
69758 PYMASS=PMAS(KFA,1)
69759 ELSEIF(MSTJ(93).EQ.1) THEN
69760 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
69761 ELSE
69762 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
69763 ENDIF
69764
69765C...Other masses can be read directly off table.
69766 ELSE
69767 PYMASS=PMAS(KC,1)
69768 ENDIF
69769
69770C...Optional mass broadening according to truncated Breit-Wigner
69771C...(either in m or in m^2).
69772 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
69773 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
69774 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
69775 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
69776 ELSE
69777 PM0=PYMASS
69778 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
69779 & (PM0*PMAS(KC,2)))
69780 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
69781 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
69782 & (PMUPP-PMLOW)*PYR(0))))
69783 ENDIF
69784 ENDIF
69785 MSTJ(93)=0
69786
69787 RETURN
69788 END
69789
69790C*********************************************************************
69791
69792C...PYMRUN
69793C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
69794C...for Higgs couplings. Everything else sent on to PYMASS.
69795
69796 FUNCTION PYMRUN(KF,Q2)
69797
69798C...Double precision and integer declarations.
69799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69800 IMPLICIT INTEGER(I-N)
69801 INTEGER PYK,PYCHGE,PYCOMP
69802C...Commonblocks.
69803 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69804 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69805 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69806 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
69807
69808C...Most masses not handled here.
69809 KFA=IABS(KF)
69810 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
69811 PYMRUN=PYMASS(KF)
69812
69813C...Current-algebra masses, but no Q2 dependence.
69814 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
69815 PYMRUN=PARF(90+KFA)
69816
69817C...Running current-algebra masses.
69818 ELSE
69819 AS=PYALPS(Q2)
69820 PYMRUN=PARF(90+KFA)*
69821 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
69822 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
69823 ENDIF
69824
69825 RETURN
69826 END
69827
69828C*********************************************************************
69829
69830C...PYNAME
69831C...Gives the particle/parton name as a character string.
69832
69833 SUBROUTINE PYNAME(KF,CHAU)
69834
69835C...Double precision and integer declarations.
69836 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69837 IMPLICIT INTEGER(I-N)
69838 INTEGER PYK,PYCHGE,PYCOMP
69839C...Commonblocks.
69840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69842 COMMON/PYDAT4/CHAF(500,2)
69843 CHARACTER CHAF*16
69844 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
69845C...Local character variable.
69846 CHARACTER CHAU*16
69847
69848C...Read out code with distinction particle/antiparticle.
69849 CHAU=' '
69850 KC=PYCOMP(KF)
69851 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
69852
69853
69854 RETURN
69855 END
69856
69857C*********************************************************************
69858
69859C...PYCHGE
69860C...Gives three times the charge for a particle/parton.
69861
69862 FUNCTION PYCHGE(KF)
69863
69864C...Double precision and integer declarations.
69865 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69866 IMPLICIT INTEGER(I-N)
69867 INTEGER PYK,PYCHGE,PYCOMP
69868C...Commonblocks.
69869 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69870 SAVE /PYDAT2/
69871
69872C...Read out charge and change sign for antiparticle.
69873 PYCHGE=0
69874 KC=PYCOMP(KF)
69875 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
69876
69877 RETURN
69878 END
69879
69880C*********************************************************************
69881
69882C...PYCOMP
69883C...Compress the standard KF codes for use in mass and decay arrays;
69884C...also checks whether a given code actually is defined.
69885
69886 FUNCTION PYCOMP(KF)
69887
69888C...Double precision and integer declarations.
69889 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69890 IMPLICIT INTEGER(I-N)
69891 INTEGER PYK,PYCHGE,PYCOMP
69892C...Commonblocks.
69893 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69894 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69895 SAVE /PYDAT1/,/PYDAT2/
69896C...Local arrays and saved data.
69897 DIMENSION KFORD(100:500),KCORD(101:500)
69898 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
69899
69900C...Whenever necessary reorder codes for faster search.
69901 IF(MSTU(20).EQ.0) THEN
69902 NFORD=100
69903 KFORD(100)=0
69904 DO 120 I=101,500
69905 KFA=KCHG(I,4)
69906 IF(KFA.LE.100) GOTO 120
69907 NFORD=NFORD+1
69908 DO 100 I1=NFORD-1,0,-1
69909 IF(KFA.GE.KFORD(I1)) GOTO 110
69910 KFORD(I1+1)=KFORD(I1)
69911 KCORD(I1+1)=KCORD(I1)
69912 100 CONTINUE
69913 110 KFORD(I1+1)=KFA
69914 KCORD(I1+1)=I
69915 120 CONTINUE
69916 MSTU(20)=1
69917 KFLAST=0
69918 KCLAST=0
69919 ENDIF
69920
69921C...Fast action if same code as in latest call.
69922 IF(KF.EQ.KFLAST) THEN
69923 PYCOMP=KCLAST
69924 RETURN
69925 ENDIF
69926
69927C...Starting values. Remove internal diquark flags.
69928 PYCOMP=0
69929 KFA=IABS(KF)
69930 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
69931 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
69932
69933C...Simple cases: direct translation.
69934 IF(KFA.GT.KFORD(NFORD)) THEN
69935 ELSEIF(KFA.LE.100) THEN
69936 PYCOMP=KFA
69937
69938C...Else binary search.
69939 ELSE
69940 IMIN=100
69941 IMAX=NFORD+1
69942 130 IAVG=(IMIN+IMAX)/2
69943 IF(KFORD(IAVG).GT.KFA) THEN
69944 IMAX=IAVG
69945 IF(IMAX.GT.IMIN+1) GOTO 130
69946 ELSEIF(KFORD(IAVG).LT.KFA) THEN
69947 IMIN=IAVG
69948 IF(IMAX.GT.IMIN+1) GOTO 130
69949 ELSE
69950 PYCOMP=KCORD(IAVG)
69951 ENDIF
69952 ENDIF
69953
69954C...Check if antiparticle allowed.
69955 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
69956 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
69957 ENDIF
69958
69959C...Save codes for possible future fast action.
69960 KFLAST=KF
69961 KCLAST=PYCOMP
69962
69963 RETURN
69964 END
69965
69966C*********************************************************************
69967
69968C...PYERRM
69969C...Informs user of errors in program execution.
69970
69971 SUBROUTINE PYERRM(MERR,CHMESS)
69972
69973C...Double precision and integer declarations.
69974 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69975 IMPLICIT INTEGER(I-N)
69976 INTEGER PYK,PYCHGE,PYCOMP
69977C...Commonblocks.
69978 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69980 SAVE /PYJETS/,/PYDAT1/
69981C...Local character variable.
69982 CHARACTER CHMESS*(*)
69983
69984C...Write first few warnings, then be silent.
69985 IF(MERR.LE.10) THEN
69986 MSTU(27)=MSTU(27)+1
69987 MSTU(28)=MERR
69988 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
69989 & MERR,MSTU(31),CHMESS
69990
69991C...Write first few errors, then be silent or stop program.
69992 ELSEIF(MERR.LE.20) THEN
69993 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
69994 MSTU(30)=MSTU(30)+1
69995 MSTU(24)=MERR-10
69996 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
69997 & MERR-10,MSTU(31),CHMESS
69998 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
69999 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
70000 WRITE(MSTU(11),5200)
70001 IF(MERR.NE.17) CALL PYLIST(2)
70002 CALL PYSTOP(3)
70003 ENDIF
70004
70005C...Stop program in case of irreparable error.
70006 ELSE
70007 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
70008 CALL PYSTOP(3)
70009 ENDIF
70010
70011C...Formats for output.
70012 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
70013 &' PYEXEC calls:'/5X,A)
70014 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
70015 &' PYEXEC calls:'/5X,A)
70016 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
70017 &'event!')
70018 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
70019 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
70020
70021 RETURN
70022 END
70023
70024C*********************************************************************
70025
70026C...PYALEM
70027C...Calculates the running alpha_electromagnetic.
70028
70029 FUNCTION PYALEM(Q2)
70030
70031C...Double precision and integer declarations.
70032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70033 IMPLICIT INTEGER(I-N)
70034 INTEGER PYK,PYCHGE,PYCOMP
70035C...Commonblocks.
70036 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70037 SAVE /PYDAT1/
70038
70039C...Calculate real part of photon vacuum polarization.
70040C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
70041C...For hadrons use parametrization of H. Burkhardt et al.
70042C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
70043 AEMPI=PARU(101)/(3D0*PARU(1))
70044 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
70045 RPIGG=0D0
70046 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
70047 RPIGG=0D0
70048 ELSEIF(MSTU(101).EQ.2) THEN
70049 RPIGG=1D0-PARU(101)/PARU(103)
70050 ELSEIF(Q2.LT.0.09D0) THEN
70051 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
70052 ELSEIF(Q2.LT.9D0) THEN
70053 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
70054 & 0.00238D0*LOG(1D0+3.927D0*Q2)
70055 ELSEIF(Q2.LT.1D4) THEN
70056 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
70057 & 0.00299D0*LOG(1D0+Q2)
70058 ELSE
70059 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
70060 & 0.00293D0*LOG(1D0+Q2)
70061 ENDIF
70062
70063C...Calculate running alpha_em.
70064 PYALEM=PARU(101)/(1D0-RPIGG)
70065 PARU(108)=PYALEM
70066
70067 RETURN
70068 END
70069
70070C*********************************************************************
70071
70072C...PYALPS
70073C...Gives the value of alpha_strong.
70074
70075 FUNCTION PYALPS(Q2)
70076
70077C...Double precision and integer declarations.
70078 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70079 IMPLICIT INTEGER(I-N)
70080 INTEGER PYK,PYCHGE,PYCOMP
70081C...Commonblocks.
70082 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70083 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70084 SAVE /PYDAT1/,/PYDAT2/
70085C...Coefficients for second-order threshold matching.
70086C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
70087 DIMENSION STEPDN(6),STEPUP(6)
70088c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
70089c &(2D0*321D0/3703D0),0D0/
70090c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
70091c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
70092 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
70093 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
70094
70095C...Constant alpha_strong trivial. Pick artificial Lambda.
70096 IF(MSTU(111).LE.0) THEN
70097 PYALPS=PARU(111)
70098 MSTU(118)=MSTU(112)
70099 PARU(117)=0.2D0
70100 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
70101 & ((33D0-2D0*MSTU(112))*PARU(111)))
70102 PARU(118)=PARU(111)
70103 RETURN
70104 ENDIF
70105
70106C...Find effective Q2, number of flavours and Lambda.
70107 Q2EFF=Q2
70108 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
70109 NF=MSTU(112)
70110 ALAM2=PARU(112)**2
70111 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
70112 Q2THR=PARU(113)*PMAS(NF,1)**2
70113 IF(Q2EFF.LT.Q2THR) THEN
70114 NF=NF-1
70115 Q2RAT=Q2THR/ALAM2
70116 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
70117 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
70118 GOTO 100
70119 ENDIF
70120 ENDIF
70121 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
70122 Q2THR=PARU(113)*PMAS(NF+1,1)**2
70123 IF(Q2EFF.GT.Q2THR) THEN
70124 NF=NF+1
70125 Q2RAT=Q2THR/ALAM2
70126 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
70127 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
70128 GOTO 110
70129 ENDIF
70130 ENDIF
70131 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
70132 PARU(117)=SQRT(ALAM2)
70133
70134C...Evaluate first or second order alpha_strong.
70135 B0=(33D0-2D0*NF)/6D0
70136 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
70137 IF(MSTU(111).EQ.1) THEN
70138 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
70139 ELSE
70140 B1=(153D0-19D0*NF)/6D0
70141 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
70142 & (B0**2*ALGQ)))
70143 ENDIF
70144 MSTU(118)=NF
70145 PARU(118)=PYALPS
70146
70147 RETURN
70148 END
70149
70150C*********************************************************************
70151
70152C...PYANGL
70153C...Reconstructs an angle from given x and y coordinates.
70154
70155 FUNCTION PYANGL(X,Y)
70156
70157C...Double precision and integer declarations.
70158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70159 IMPLICIT INTEGER(I-N)
70160 INTEGER PYK,PYCHGE,PYCOMP
70161C...Commonblocks.
70162 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70163 SAVE /PYDAT1/
70164
70165 PYANGL=0D0
70166 R=SQRT(X**2+Y**2)
70167 IF(R.LT.1D-20) RETURN
70168 IF(ABS(X)/R.LT.0.8D0) THEN
70169 PYANGL=SIGN(ACOS(X/R),Y)
70170 ELSE
70171 PYANGL=ASIN(Y/R)
70172 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
70173 PYANGL=PARU(1)-PYANGL
70174 ELSEIF(X.LT.0D0) THEN
70175 PYANGL=-PARU(1)-PYANGL
70176 ENDIF
70177 ENDIF
70178
70179 RETURN
70180 END
70181
70182C*********************************************************************
70183
70184C...PYROBO
70185C...Performs rotations and boosts.
70186
70187 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
70188
70189C...Double precision and integer declarations.
70190 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70191 IMPLICIT INTEGER(I-N)
70192 INTEGER PYK,PYCHGE,PYCOMP
70193C...Commonblocks.
70194 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70195 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70196 SAVE /PYJETS/,/PYDAT1/
70197C...Local arrays.
70198 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
70199
70200C...Find and check range of rotation/boost.
70201 IMIN=IMI
70202 IF(IMIN.LE.0) IMIN=1
70203 IF(MSTU(1).GT.0) IMIN=MSTU(1)
70204 IMAX=IMA
70205 IF(IMAX.LE.0) IMAX=N
70206 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70207 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
70208 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
70209 RETURN
70210 ENDIF
70211
70212C...Optional resetting of V (when not set before.)
70213 IF(MSTU(33).NE.0) THEN
70214 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
70215 DO 100 J=1,5
70216 V(I,J)=0D0
70217 100 CONTINUE
70218 110 CONTINUE
70219 MSTU(33)=0
70220 ENDIF
70221
70222C...Rotate, typically from z axis to direction (theta,phi).
70223 IF(THE**2+PHI**2.GT.1D-20) THEN
70224 ROT(1,1)=COS(THE)*COS(PHI)
70225 ROT(1,2)=-SIN(PHI)
70226 ROT(1,3)=SIN(THE)*COS(PHI)
70227 ROT(2,1)=COS(THE)*SIN(PHI)
70228 ROT(2,2)=COS(PHI)
70229 ROT(2,3)=SIN(THE)*SIN(PHI)
70230 ROT(3,1)=-SIN(THE)
70231 ROT(3,2)=0D0
70232 ROT(3,3)=COS(THE)
70233 DO 140 I=IMIN,IMAX
70234 IF(K(I,1).LE.0) GOTO 140
70235 DO 120 J=1,3
70236 PR(J)=P(I,J)
70237 VR(J)=V(I,J)
70238 120 CONTINUE
70239 DO 130 J=1,3
70240 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
70241 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
70242 130 CONTINUE
70243 140 CONTINUE
70244 ENDIF
70245
70246C...Boost, typically from rest to momentum/energy=beta.
70247 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
70248 DBX=BEX
70249 DBY=BEY
70250 DBZ=BEZ
70251 DB=SQRT(DBX**2+DBY**2+DBZ**2)
70252 EPS1=1D0-1D-12
70253 IF(DB.GT.EPS1) THEN
70254C...Rescale boost vector if too close to unity.
70255 CALL PYERRM(3,'(PYROBO:) boost vector too large')
70256 DBX=DBX*(EPS1/DB)
70257 DBY=DBY*(EPS1/DB)
70258 DBZ=DBZ*(EPS1/DB)
70259 DB=EPS1
70260 ENDIF
70261 DGA=1D0/SQRT(1D0-DB**2)
70262 DO 160 I=IMIN,IMAX
70263 IF(K(I,1).LE.0) GOTO 160
70264 DO 150 J=1,4
70265 DP(J)=P(I,J)
70266 DV(J)=V(I,J)
70267 150 CONTINUE
70268 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
70269 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
70270 P(I,1)=DP(1)+DGABP*DBX
70271 P(I,2)=DP(2)+DGABP*DBY
70272 P(I,3)=DP(3)+DGABP*DBZ
70273 P(I,4)=DGA*(DP(4)+DBP)
70274 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
70275 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
70276 V(I,1)=DV(1)+DGABV*DBX
70277 V(I,2)=DV(2)+DGABV*DBY
70278 V(I,3)=DV(3)+DGABV*DBZ
70279 V(I,4)=DGA*(DV(4)+DBV)
70280 160 CONTINUE
70281 ENDIF
70282
70283 RETURN
70284 END
70285
70286C*********************************************************************
70287
70288C...PYEDIT
70289C...Performs global manipulations on the event record, in particular
70290C...to exclude unstable or undetectable partons/particles.
70291
70292 SUBROUTINE PYEDIT(MEDIT)
70293
70294C...Double precision and integer declarations.
70295 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70296 IMPLICIT INTEGER(I-N)
70297 INTEGER PYK,PYCHGE,PYCOMP
70298C...Parameter statement to help give large particle numbers.
70299 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70300 &KEXCIT=4000000,KDIMEN=5000000)
70301C...Commonblocks.
70302 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70305 COMMON/PYCTAG/NCT,MCT(4000,2)
70306 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
70307C...Local arrays.
70308 DIMENSION NS(2),PTS(2),PLS(2)
70309
70310C...Remove unwanted partons/particles.
70311 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
70312 IMAX=N
70313 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70314 I1=MAX(1,MSTU(1))-1
70315 DO 110 I=MAX(1,MSTU(1)),IMAX
70316 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
70317 IF(MEDIT.EQ.1) THEN
70318 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70319 ELSEIF(MEDIT.EQ.2) THEN
70320 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70321 KC=PYCOMP(K(I,2))
70322 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70323 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70324 & K(I,2).EQ.KSUSY1+39) GOTO 110
70325 ELSEIF(MEDIT.EQ.3) THEN
70326 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
70327 KC=PYCOMP(K(I,2))
70328 IF(KC.EQ.0) GOTO 110
70329 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
70330 ELSEIF(MEDIT.EQ.5) THEN
70331 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
70332 KC=PYCOMP(K(I,2))
70333 IF(KC.EQ.0) GOTO 110
70334 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
70335 & KCHG(KC,2).EQ.0) GOTO 110
70336 ENDIF
70337
70338C...Pack remaining partons/particles. Origin no longer known.
70339 I1=I1+1
70340 DO 100 J=1,5
70341 K(I1,J)=K(I,J)
70342 P(I1,J)=P(I,J)
70343 V(I1,J)=V(I,J)
70344 100 CONTINUE
70345 K(I1,3)=0
70346 110 CONTINUE
70347 IF(I1.LT.N) MSTU(3)=0
70348 IF(I1.LT.N) MSTU(70)=0
70349 N=I1
70350
70351C...Selective removal of class of entries. New position of retained.
70352 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
70353 I1=0
70354 DO 120 I=1,N
70355 K(I,3)=MOD(K(I,3),MSTU(5))
70356 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
70357 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
70358 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
70359 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
70360 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
70361 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
70362 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
70363 I1=I1+1
70364 K(I,3)=K(I,3)+MSTU(5)*I1
70365 120 CONTINUE
70366
70367C...Find new event history information and replace old.
70368 DO 140 I=1,N
70369 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
70370 & K(I,3)/MSTU(5).EQ.0) GOTO 140
70371 ID=I
70372 130 IM=MOD(K(ID,3),MSTU(5))
70373 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
70374 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
70375 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
70376 ID=IM
70377 GOTO 130
70378 ENDIF
70379 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
70380 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
70381 & K(IM,2).EQ.94) THEN
70382 ID=IM
70383 GOTO 130
70384 ENDIF
70385 ENDIF
70386 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
70387 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
70388 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
70389 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
70390 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
70391 & K(K(I,4),3)/MSTU(5)
70392 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
70393 & K(K(I,5),3)/MSTU(5)
70394 ELSE
70395 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
70396 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
70397 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
70398 KCD=MOD(K(I,4),MSTU(5))
70399 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70400 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70401 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
70402 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
70403 KCD=MOD(K(I,5),MSTU(5))
70404 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
70405 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
70406 ENDIF
70407 140 CONTINUE
70408
70409C...Pack remaining entries.
70410 I1=0
70411 MSTU90=MSTU(90)
70412 MSTU(90)=0
70413 DO 170 I=1,N
70414 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
70415 I1=I1+1
70416 DO 150 J=1,5
70417 K(I1,J)=K(I,J)
70418 P(I1,J)=P(I,J)
70419 V(I1,J)=V(I,J)
70420 150 CONTINUE
70421C...Also update LHA1 colour tags
70422 MCT(I1,1)=MCT(I,1)
70423 MCT(I1,2)=MCT(I,2)
70424 K(I1,3)=MOD(K(I1,3),MSTU(5))
70425 DO 160 IZ=1,MSTU90
70426 IF(I.EQ.MSTU(90+IZ)) THEN
70427 MSTU(90)=MSTU(90)+1
70428 MSTU(90+MSTU(90))=I1
70429 PARU(90+MSTU(90))=PARU(90+IZ)
70430 ENDIF
70431 160 CONTINUE
70432 170 CONTINUE
70433 IF(I1.LT.N) MSTU(3)=0
70434 IF(I1.LT.N) MSTU(70)=0
70435 N=I1
70436
70437C...Fill in some missing daughter pointers (lost in colour flow).
70438 ELSEIF(MEDIT.EQ.16) THEN
70439 DO 220 I=1,N
70440 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
70441 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
70442C...Find daughters who point to mother.
70443 DO 180 I1=I+1,N
70444 IF(K(I1,3).NE.I) THEN
70445 ELSEIF(K(I,4).EQ.0) THEN
70446 K(I,4)=I1
70447 ELSE
70448 K(I,5)=I1
70449 ENDIF
70450 180 CONTINUE
70451 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70452 IF(K(I,4).NE.0) GOTO 220
70453C...Find daughters who point to documentation version of mother.
70454 IM=K(I,3)
70455 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
70456 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
70457 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
70458 DO 190 I1=I+1,N
70459 IF(K(I1,3).NE.IM) THEN
70460 ELSEIF(K(I,4).EQ.0) THEN
70461 K(I,4)=I1
70462 ELSE
70463 K(I,5)=I1
70464 ENDIF
70465 190 CONTINUE
70466 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70467 IF(K(I,4).NE.0) GOTO 220
70468C...Find daughters who point to documentation daughters who,
70469C...in their turn, point to documentation mother.
70470 ID1=IM
70471 ID2=IM
70472 DO 200 I1=IM+1,I-1
70473 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
70474 ID2=I1
70475 IF(ID1.EQ.IM) ID1=I1
70476 ENDIF
70477 200 CONTINUE
70478 DO 210 I1=I+1,N
70479 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
70480 ELSEIF(K(I,4).EQ.0) THEN
70481 K(I,4)=I1
70482 ELSE
70483 K(I,5)=I1
70484 ENDIF
70485 210 CONTINUE
70486 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
70487 220 CONTINUE
70488
70489C...Save top entries at bottom of PYJETS commonblock.
70490 ELSEIF(MEDIT.EQ.21) THEN
70491 IF(2*N.GE.MSTU(4)) THEN
70492 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
70493 RETURN
70494 ENDIF
70495 DO 240 I=1,N
70496 DO 230 J=1,5
70497 K(MSTU(4)-I,J)=K(I,J)
70498 P(MSTU(4)-I,J)=P(I,J)
70499 V(MSTU(4)-I,J)=V(I,J)
70500 230 CONTINUE
70501 240 CONTINUE
70502 MSTU(32)=N
70503
70504C...Restore bottom entries of commonblock PYJETS to top.
70505 ELSEIF(MEDIT.EQ.22) THEN
70506 DO 260 I=1,MSTU(32)
70507 DO 250 J=1,5
70508 K(I,J)=K(MSTU(4)-I,J)
70509 P(I,J)=P(MSTU(4)-I,J)
70510 V(I,J)=V(MSTU(4)-I,J)
70511 250 CONTINUE
70512 260 CONTINUE
70513 N=MSTU(32)
70514
70515C...Mark primary entries at top of commonblock PYJETS as untreated.
70516 ELSEIF(MEDIT.EQ.23) THEN
70517 I1=0
70518 DO 270 I=1,N
70519 KH=K(I,3)
70520 IF(KH.GE.1) THEN
70521 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
70522 ENDIF
70523 IF(KH.NE.0) GOTO 280
70524 I1=I1+1
70525 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
70526 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
70527 270 CONTINUE
70528 280 N=I1
70529
70530C...Place largest axis along z axis and second largest in xy plane.
70531 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
70532 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
70533 & P(MSTU(61),2)),0D0,0D0,0D0)
70534 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
70535 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
70536 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
70537 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
70538 IF(MEDIT.EQ.31) RETURN
70539
70540C...Rotate to put slim jet along +z axis.
70541 DO 290 IS=1,2
70542 NS(IS)=0
70543 PTS(IS)=0D0
70544 PLS(IS)=0D0
70545 290 CONTINUE
70546 DO 300 I=1,N
70547 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
70548 IF(MSTU(41).GE.2) THEN
70549 KC=PYCOMP(K(I,2))
70550 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70551 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70552 & K(I,2).EQ.KSUSY1+39) GOTO 300
70553 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70554 & .EQ.0) GOTO 300
70555 ENDIF
70556 IS=2D0-SIGN(0.5D0,P(I,3))
70557 NS(IS)=NS(IS)+1
70558 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
70559 300 CONTINUE
70560 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
70561 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
70562
70563C...Rotate to put second largest jet into -z,+x quadrant.
70564 DO 310 I=1,N
70565 IF(P(I,3).GE.0D0) GOTO 310
70566 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
70567 IF(MSTU(41).GE.2) THEN
70568 KC=PYCOMP(K(I,2))
70569 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
70570 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
70571 & K(I,2).EQ.KSUSY1+39) GOTO 310
70572 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
70573 & .EQ.0) GOTO 310
70574 ENDIF
70575 IS=2D0-SIGN(0.5D0,P(I,1))
70576 PLS(IS)=PLS(IS)-P(I,3)
70577 310 CONTINUE
70578 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
70579 & 0D0,0D0,0D0)
70580 ENDIF
70581
70582 RETURN
70583 END
70584
70585C*********************************************************************
70586
70587C...PYLIST
70588C...Gives program heading, or lists an event, or particle
70589C...data, or current parameter values.
70590
70591 SUBROUTINE PYLIST(MLIST)
70592
70593C...Double precision and integer declarations.
70594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70595 IMPLICIT INTEGER(I-N)
70596 INTEGER PYK,PYCHGE,PYCOMP
70597C...Parameter statement to help give large particle numbers.
70598 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
70599 &KEXCIT=4000000,KDIMEN=5000000)
70600
70601C...HEPEVT commonblock.
70602 PARAMETER (NMXHEP=4000)
70603 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
70604 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
70605 DOUBLE PRECISION PHEP,VHEP
70606 SAVE /HEPEVT/
70607
70608C...User process event common block.
70609 INTEGER MAXNUP
70610 PARAMETER (MAXNUP=500)
70611 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
70612 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
70613 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
70614 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
70615 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
70616 SAVE /HEPEUP/
70617
70618C...Commonblocks.
70619 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
70620 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70621 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
70622 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
70623 COMMON/PYCTAG/NCT,MCT(4000,2)
70624 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
70625C...Local arrays, character variables and data.
70626 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
70627 DIMENSION PS(6)
70628 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
70629
70630C...Initialization printout: version number and date of last change.
70631 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
70632 CALL PYLOGO
70633 MSTU(12)=12345
70634 IF(MLIST.EQ.0) RETURN
70635 ENDIF
70636
70637C...List event data, including additional lines after N.
70638 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
70639 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
70640 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
70641 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
70642 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
70643 LMX=12
70644 IF(MLIST.GE.2) LMX=16
70645 ISTR=0
70646 IMAX=N
70647 IF(MSTU(2).GT.0) IMAX=MSTU(2)
70648 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
70649 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
70650 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
70651 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
70652
70653C...Get particle name, pad it and check it is not too long.
70654 CALL PYNAME(K(I,2),CHAP)
70655 LEN=0
70656 DO 100 LEM=1,16
70657 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
70658 100 CONTINUE
70659 MDL=(K(I,1)+19)/10
70660 LDL=0
70661 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
70662 CHAC=CHAP
70663 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
70664 ELSE
70665 LDL=1
70666 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
70667 IF(LEN.EQ.0) THEN
70668 CHAC=CHDL(MDL)(1:2*LDL)//' '
70669 ELSE
70670 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
70671 & CHDL(MDL)(LDL+1:2*LDL)//' '
70672 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
70673 ENDIF
70674 ENDIF
70675
70676C...Add information on string connection.
70677 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
70678 & THEN
70679 KC=PYCOMP(K(I,2))
70680 KCC=0
70681 IF(KC.NE.0) KCC=KCHG(KC,2)
70682 IF(IABS(K(I,2)).EQ.39) THEN
70683 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
70684 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
70685 ISTR=1
70686 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
70687 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
70688 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
70689 ELSEIF(KCC.NE.0) THEN
70690 ISTR=0
70691 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
70692 ENDIF
70693 ENDIF
70694 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
70695 & CHAC(LMX-1:LMX-1)='I'
70696
70697C...Write data for particle/jet.
70698 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
70699 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
70700 & (P(I,J2),J2=1,5)
70701 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
70702 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
70703 & (P(I,J2),J2=1,5)
70704 ELSEIF(MLIST.EQ.1) THEN
70705 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
70706 & (P(I,J2),J2=1,5)
70707 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
70708 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
70709 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
70710 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70711 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
70712 & (P(I,J2),J2=1,5)
70713 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
70714 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
70715 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
70716 & ,10000),MCT(I,1),MCT(I,2)
70717 ELSE
70718 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
70719 & (P(I,J2),J2=1,5)
70720 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
70721 & ,MCT(I,1),MCT(I,2)
70722 ENDIF
70723 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
70724
70725C...Insert extra separator lines specified by user.
70726 IF(MSTU(70).GE.1) THEN
70727 ISEP=0
70728 DO 110 J=1,MIN(10,MSTU(70))
70729 IF(I.EQ.MSTU(70+J)) ISEP=1
70730 110 CONTINUE
70731 IF(ISEP.EQ.1) THEN
70732 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
70733 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
70734 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
70735 ENDIF
70736 ENDIF
70737 120 CONTINUE
70738
70739C...Sum of charges and momenta.
70740 DO 130 J=1,6
70741 PS(J)=PYP(0,J)
70742 130 CONTINUE
70743 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
70744 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
70745 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
70746 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
70747 ELSEIF(MLIST.EQ.1) THEN
70748 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
70749 ELSEIF(MLIST.LE.3) THEN
70750 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
70751 ELSE
70752 WRITE(MSTU(11),7000) PS(6)
70753 ENDIF
70754
70755C...Simple listing of HEPEVT entries (mainly for test purposes).
70756 ELSEIF(MLIST.EQ.5) THEN
70757 WRITE(MSTU(11),7100)
70758 DO 140 I=1,NHEP
70759 IF(ISTHEP(I).EQ.0) GOTO 140
70760 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
70761 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
70762 140 CONTINUE
70763
70764
70765C...Simple listing of user-process entries (mainly for test purposes).
70766 ELSEIF(MLIST.EQ.7) THEN
70767 WRITE(MSTU(11),7300)
70768 DO 150 I=1,NUP
70769 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
70770 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
70771 150 CONTINUE
70772
70773C...Give simple list of KF codes defined in program.
70774 ELSEIF(MLIST.EQ.11) THEN
70775 WRITE(MSTU(11),7500)
70776 DO 160 KF=1,80
70777 CALL PYNAME(KF,CHAP)
70778 CALL PYNAME(-KF,CHAN)
70779 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70780 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70781 160 CONTINUE
70782 DO 190 KFLS=1,3,2
70783 DO 180 KFLA=1,5
70784 DO 170 KFLB=1,KFLA-(3-KFLS)/2
70785 KF=1000*KFLA+100*KFLB+KFLS
70786 CALL PYNAME(KF,CHAP)
70787 CALL PYNAME(-KF,CHAN)
70788 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70789 170 CONTINUE
70790 180 CONTINUE
70791 190 CONTINUE
70792 DO 220 KMUL=0,5
70793 KFLS=3
70794 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
70795 IF(KMUL.EQ.5) KFLS=5
70796 KFLR=0
70797 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
70798 IF(KMUL.EQ.4) KFLR=2
70799 DO 210 KFLB=1,5
70800 DO 200 KFLC=1,KFLB-1
70801 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
70802 CALL PYNAME(KF,CHAP)
70803 CALL PYNAME(-KF,CHAN)
70804 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70805 IF(KF.EQ.311) THEN
70806 KFK=130
70807 CALL PYNAME(KFK,CHAP)
70808 WRITE(MSTU(11),7600) KFK,CHAP
70809 KFK=310
70810 CALL PYNAME(KFK,CHAP)
70811 WRITE(MSTU(11),7600) KFK,CHAP
70812 ENDIF
70813 200 CONTINUE
70814 KF=10000*KFLR+110*KFLB+KFLS
70815 CALL PYNAME(KF,CHAP)
70816 WRITE(MSTU(11),7600) KF,CHAP
70817 210 CONTINUE
70818 220 CONTINUE
70819 KF=100443
70820 CALL PYNAME(KF,CHAP)
70821 WRITE(MSTU(11),7600) KF,CHAP
70822 KF=100553
70823 CALL PYNAME(KF,CHAP)
70824 WRITE(MSTU(11),7600) KF,CHAP
70825 DO 260 KFLSP=1,3
70826 KFLS=2+2*(KFLSP/3)
70827 DO 250 KFLA=1,5
70828 DO 240 KFLB=1,KFLA
70829 DO 230 KFLC=1,KFLB
70830 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
70831 & GOTO 230
70832 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
70833 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
70834 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
70835 CALL PYNAME(KF,CHAP)
70836 CALL PYNAME(-KF,CHAN)
70837 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70838 230 CONTINUE
70839 240 CONTINUE
70840 250 CONTINUE
70841 260 CONTINUE
70842 DO 270 KC=1,500
70843 KF=KCHG(KC,4)
70844 IF(KF.LT.1000000) GOTO 270
70845 CALL PYNAME(KF,CHAP)
70846 CALL PYNAME(-KF,CHAN)
70847 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
70848 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
70849 270 CONTINUE
70850
70851C...List parton/particle data table. Check whether to be listed.
70852 ELSEIF(MLIST.EQ.12) THEN
70853 WRITE(MSTU(11),7700)
70854 DO 300 KC=1,MSTU(6)
70855 KF=KCHG(KC,4)
70856 IF(KF.EQ.0) GOTO 300
70857 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
70858 & GOTO 300
70859
70860C...Find particle name and mass. Print information.
70861 CALL PYNAME(KF,CHAP)
70862 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
70863 CALL PYNAME(-KF,CHAN)
70864 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
70865 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
70866
70867C...Particle decay: channel number, branching ratios, matrix element,
70868C...decay products.
70869 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
70870 DO 280 J=1,5
70871 CALL PYNAME(KFDP(IDC,J),CHAD(J))
70872 280 CONTINUE
70873 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
70874 & (CHAD(J),J=1,5)
70875 290 CONTINUE
70876 300 CONTINUE
70877
70878C...List parameter value table.
70879 ELSEIF(MLIST.EQ.13) THEN
70880 WRITE(MSTU(11),8000)
70881 DO 310 I=1,200
70882 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
70883 310 CONTINUE
70884 ENDIF
70885
70886C...Format statements for output on unit MSTU(11) (by default 6).
70887 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
70888 &5X,'KF orig p_x p_y p_z E m'/)
70889 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
70890 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70891 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
70892 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
70893 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
70894 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
70895 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
70896 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
70897 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
70898 & ,' C tag AC tag'/)
70899 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
70900 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
70901 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
70902 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
70903 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
70904 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
70905 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
70906 6200 FORMAT(66X,5(1X,F12.3))
70907 6300 FORMAT(1X,78('='))
70908 6400 FORMAT(1X,130('='))
70909 6500 FORMAT(1X,65('='))
70910 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
70911 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
70912 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
70913 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
70914 &5F13.5)
70915 7000 FORMAT(19X,'sum charge:',F6.2)
70916 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
70917 &//' I IST ID Mothers Daughters p_x p_y p_z',
70918 &' E m')
70919 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
70920 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
70921 &//' I IST ID Mothers Colours p_x p_y p_z',
70922 &' E m')
70923 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
70924 7500 FORMAT(///20X,'List of KF codes in program'/)
70925 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
70926 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
70927 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
70928 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
70929 &1X,'ME',3X,'Br.rat.',4X,'decay products')
70930 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
70931 &1X,1P,E13.5,3X,I2)
70932 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
70933 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
70934 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
70935 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
70936
70937 RETURN
70938 END
70939
70940C*********************************************************************
70941
70942C...PYLOGO
70943C...Writes a logo for the program.
70944
70945 SUBROUTINE PYLOGO
70946
70947C...Double precision and integer declarations.
70948 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
70949 IMPLICIT INTEGER(I-N)
70950 INTEGER PYK,PYCHGE,PYCOMP
70951C...Parameter for length of information block.
70952 PARAMETER (IREFER=21)
70953C...Commonblocks.
70954 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
70955 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
70956 SAVE /PYDAT1/,/PYPARS/
70957C...Local arrays and character variables.
70958 INTEGER IDATI(6)
70959 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
70960 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
70961
70962C...Data on months, logo, titles, and references.
70963 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
70964 &'Oct','Nov','Dec'/
70965 DATA (LOGO(J),J=1,19)/
70966 &' *......* ',
70967 &' *:::!!:::::::::::* ',
70968 &' *::::::!!::::::::::::::* ',
70969 &' *::::::::!!::::::::::::::::* ',
70970 &' *:::::::::!!:::::::::::::::::* ',
70971 &' *:::::::::!!:::::::::::::::::* ',
70972 &' *::::::::!!::::::::::::::::*! ',
70973 &' *::::::!!::::::::::::::* !! ',
70974 &' !! *:::!!:::::::::::* !! ',
70975 &' !! !* -><- * !! ',
70976 &' !! !! !! ',
70977 &' !! !! !! ',
70978 &' !! !! ',
70979 &' !! lh !! ',
70980 &' !! !! ',
70981 &' !! hh !! ',
70982 &' !! ll !! ',
70983 &' !! !! ',
70984 &' !! '/
70985 DATA (LOGO(J),J=20,38)/
70986 &'Welcome to the Lund Monte Carlo!',
70987 &' ',
70988 &'PPP Y Y TTTTT H H III A ',
70989 &'P P Y Y T H H I A A ',
70990 &'PPP Y T HHHHH I AAAAA',
70991 &'P Y T H H I A A',
70992 &'P Y T H H III A A',
70993 &' ',
70994 &'This is PYTHIA version x.xxx ',
70995 &'Last date of change: xx xxx 200x',
70996 &' ',
70997 &'Now is xx xxx 200x at xx:xx:xx ',
70998 &' ',
70999 &'Disclaimer: this program comes ',
71000 &'without any guarantees. Beware ',
71001 &'of errors and use common sense ',
71002 &'when interpreting results. ',
71003 &' ',
71004 &'Copyright T. Sjostrand (2007) '/
71005 DATA (REFER(J),J=1,14)/
71006 &'An archive of program versions and d',
71007 &'ocumentation is found on the web: ',
71008 &'http://www.thep.lu.se/~torbjorn/Pyth',
71009 &'ia.html ',
71010 &' ',
71011 &' ',
71012 &'When you cite this program, the offi',
71013 &'cial reference is to the 6.4 manual:',
71014 &'T. Sjostrand, S. Mrenna and P. Skand',
71015 &'s, JHEP05 (2006) 026 ',
71016 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
71017 &'-T) [hep-ph/0603175]. ',
71018 &' ',
71019 &' '/
71020 DATA (REFER(J),J=15,32)/
71021 &'Also remember that the program, to a',
71022 &' large extent, represents original ',
71023 &'physics research. Other publications',
71024 &' of special relevance to your ',
71025 &'studies may therefore deserve separa',
71026 &'te mention. ',
71027 &' ',
71028 &' ',
71029 &'Main author: Torbjorn Sjostrand; CER',
71030 &'N/PH, CH-1211 Geneva, Switzerland, ',
71031 &' and Department of Theoretical Phys',
71032 &'ics, Lund University, Lund, Sweden; ',
71033 &' phone: + 41 - 22 - 767 82 27; e-ma',
71034 &'il: torbjorn@thep.lu.se ',
71035 &'Author: Stephen Mrenna; Computing Di',
71036 &'vision, GDS Group, ',
71037 &' Fermi National Accelerator Laborat',
71038 &'ory, MS 234, Batavia, IL 60510, USA;'/
71039 DATA (REFER(J),J=33,2*IREFER)/
71040 &' phone: + 1 - 630 - 840 - 2556; e-m',
71041 &'ail: mrenna@fnal.gov ',
71042 &'Author: Peter Skands; Theoretical Ph',
71043 &'ysics Department, ',
71044 &' Fermi National Accelerator Laborat',
71045 &'ory, MS 106, Batavia, IL 60510, USA;',
71046 &' and CERN/PH, CH-1211 Geneva, Switz',
71047 &'erland; ',
71048 &' phone: + 41 - 22 - 767 24 59; e-ma',
71049 &'il: skands@fnal.gov '/
71050
71051C...Check that PYDATA linked.
71052 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
71053 WRITE(*,'(1X,A)')
71054 & 'Error: PYDATA has not been linked.'
71055 WRITE(*,'(1X,A)') 'Execution stopped!'
71056 CALL PYSTOP(8)
71057
71058C...Write current version number and current date+time.
71059 ELSE
71060 WRITE(VERS,'(I1)') MSTP(181)
71061 LOGO(28)(24:24)=VERS
71062 WRITE(SUBV,'(I3)') MSTP(182)
71063 LOGO(28)(26:28)=SUBV
71064 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
71065 WRITE(DATE,'(I2)') MSTP(185)
71066 LOGO(29)(22:23)=DATE
71067 LOGO(29)(25:27)=MONTH(MSTP(184))
71068 WRITE(YEAR,'(I4)') MSTP(183)
71069 LOGO(29)(29:32)=YEAR
71070 CALL PYTIME(IDATI)
71071 IF(IDATI(1).LE.0) THEN
71072 LOGO(31)=' '
71073 ELSE
71074 WRITE(DATE,'(I2)') IDATI(3)
71075 LOGO(31)(8:9)=DATE
71076 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
71077 WRITE(YEAR,'(I4)') IDATI(1)
71078 LOGO(31)(15:18)=YEAR
71079 WRITE(HOUR,'(I2)') IDATI(4)
71080 LOGO(31)(23:24)=HOUR
71081 WRITE(MINU,'(I2)') IDATI(5)
71082 LOGO(31)(26:27)=MINU
71083 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
71084 WRITE(SECO,'(I2)') IDATI(6)
71085 LOGO(31)(29:30)=SECO
71086 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
71087 ENDIF
71088 ENDIF
71089
71090C...Loop over lines in header. Define page feed and side borders.
71091 DO 100 ILIN=1,29+IREFER
71092 LINE=' '
71093 IF(ILIN.EQ.1) THEN
71094 LINE(1:1)='1'
71095 ELSE
71096 LINE(2:3)='**'
71097 LINE(78:79)='**'
71098 ENDIF
71099
71100C...Separator lines and logos.
71101 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
71102 LINE(4:77)='***********************************************'//
71103 & '***************************'
71104 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
71105 LINE(6:37)=LOGO(ILIN-5)
71106 LINE(44:75)=LOGO(ILIN+14)
71107 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
71108 LINE(5:40)=REFER(2*ILIN-51)
71109 LINE(41:76)=REFER(2*ILIN-50)
71110 ENDIF
71111
71112C...Write lines to appropriate unit.
71113 WRITE(MSTU(11),'(A79)') LINE
71114 100 CONTINUE
71115
71116 RETURN
71117 END
71118
71119C*********************************************************************
71120
71121C...PYUPDA
71122C...Facilitates the updating of particle and decay data
71123C...by allowing it to be done in an external file.
71124
71125 SUBROUTINE PYUPDA(MUPDA,LFN)
71126
71127C...Double precision and integer declarations.
71128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71129 IMPLICIT INTEGER(I-N)
71130 INTEGER PYK,PYCHGE,PYCOMP
71131C...Commonblocks.
71132 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71133 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71134 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
71135 COMMON/PYDAT4/CHAF(500,2)
71136 CHARACTER CHAF*16
71137 COMMON/PYINT4/MWID(500),WIDS(500,5)
71138 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
71139C...Local arrays, character variables and data.
71140 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
71141 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
71142 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
71143 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
71144 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
71145 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
71146 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
71147
71148C...Write header if not yet done.
71149 IF(MSTU(12).NE.12345) CALL PYLIST(0)
71150
71151C...Write information on file for editing.
71152 IF(MUPDA.EQ.1) THEN
71153 DO 110 KC=1,500
71154 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71155 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71156 & MWID(KC),MDCY(KC,1)
71157 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71158 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
71159 & (KFDP(IDC,J),J=1,5)
71160 100 CONTINUE
71161 110 CONTINUE
71162
71163C...Read complete set of information from edited file or
71164C...read partial set of new or updated information from edited file.
71165 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
71166
71167C...Reset counters.
71168 KCC=100
71169 NDC=0
71170 CHKF=' '
71171 IF(MUPDA.EQ.2) THEN
71172 DO 120 I=1,MSTU(6)
71173 KCHG(I,4)=0
71174 120 CONTINUE
71175 ELSE
71176 DO 130 KC=1,MSTU(6)
71177 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
71178 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
71179 130 CONTINUE
71180 ENDIF
71181
71182C...Begin of loop: read new line; unknown whether particle or
71183C...decay data.
71184 140 READ(LFN,5200,END=190) CHINL
71185
71186C...Identify particle code and whether already defined (for MUPDA=3).
71187 IF(CHINL(2:10).NE.' ') THEN
71188 CHKF=CHINL(2:10)
71189 READ(CHKF,5300) KF
71190 IF(MUPDA.EQ.2) THEN
71191 IF(KF.LE.100) THEN
71192 KC=KF
71193 ELSE
71194 KCC=KCC+1
71195 KC=KCC
71196 ENDIF
71197 ELSE
71198 KCREP=0
71199 IF(KF.LE.100) THEN
71200 KCREP=KF
71201 ELSE
71202 DO 150 KCR=101,KCC
71203 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
71204 150 CONTINUE
71205 ENDIF
71206C...Remove duplicate old decay data.
71207 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
71208 IDCREP=MDCY(KCREP,2)
71209 NDCREP=MDCY(KCREP,3)
71210 DO 160 I=1,KCC
71211 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
71212 160 CONTINUE
71213 DO 180 I=IDCREP,NDC-NDCREP
71214 MDME(I,1)=MDME(I+NDCREP,1)
71215 MDME(I,2)=MDME(I+NDCREP,2)
71216 BRAT(I)=BRAT(I+NDCREP)
71217 DO 170 J=1,5
71218 KFDP(I,J)=KFDP(I+NDCREP,J)
71219 170 CONTINUE
71220 180 CONTINUE
71221 NDC=NDC-NDCREP
71222 KC=KCREP
71223 ELSEIF(KCREP.NE.0) THEN
71224 KC=KCREP
71225 ELSE
71226 KCC=KCC+1
71227 KC=KCC
71228 ENDIF
71229 ENDIF
71230
71231C...Study line with particle data.
71232 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
71233 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
71234 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
71235 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
71236 & MWID(KC),MDCY(KC,1)
71237 MDCY(KC,2)=0
71238 MDCY(KC,3)=0
71239
71240C...Study line with decay data.
71241 ELSE
71242 NDC=NDC+1
71243 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
71244 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
71245 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
71246 MDCY(KC,3)=MDCY(KC,3)+1
71247 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
71248 & (KFDP(NDC,J),J=1,5)
71249 ENDIF
71250
71251C...End of loop; ensure that PYCOMP tables are updated.
71252 GOTO 140
71253 190 CONTINUE
71254 MSTU(20)=0
71255
71256C...Perform possible tests that new information is consistent.
71257 DO 220 KC=1,MSTU(6)
71258 KF=KCHG(KC,4)
71259 IF(KF.EQ.0) GOTO 220
71260 WRITE(CHKF,5300) KF
71261 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
71262 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
71263 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
71264 BRSUM=0D0
71265 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
71266 IF(MDME(IDC,2).GT.80) GOTO 210
71267 KQ=KCHG(KC,1)
71268 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
71269 MERR=0
71270 DO 200 J=1,5
71271 KP=KFDP(IDC,J)
71272 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
71273 IF(KP.EQ.81) KQ=0
71274 ELSEIF(PYCOMP(KP).EQ.0) THEN
71275 MERR=3
71276 ELSE
71277 KQ=KQ-PYCHGE(KP)
71278 KPC=PYCOMP(KP)
71279 PMS=PMS-PMAS(KPC,1)
71280 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
71281 & PMAS(KPC,3))
71282 ENDIF
71283 200 CONTINUE
71284 IF(KQ.NE.0) MERR=MAX(2,MERR)
71285 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
71286 & MERR=MAX(1,MERR)
71287 IF(MERR.EQ.3) CALL PYERRM(17,
71288 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
71289 IF(MERR.EQ.2) CALL PYERRM(17,
71290 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
71291 IF(MERR.EQ.1) CALL PYERRM(7,
71292 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
71293 BRSUM=BRSUM+BRAT(IDC)
71294 210 CONTINUE
71295 WRITE(CHTMP,5500) BRSUM
71296 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
71297 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
71298 & CHTMP(9:16)//' for KF ='//CHKF)
71299 220 CONTINUE
71300
71301C...Write DATA statements for inclusion in program.
71302 ELSEIF(MUPDA.EQ.4) THEN
71303
71304C...Find out how many codes and decay channels are actually used.
71305 KCC=0
71306 NDC=0
71307 DO 230 I=1,MSTU(6)
71308 IF(KCHG(I,4).NE.0) THEN
71309 KCC=I
71310 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
71311 ENDIF
71312 230 CONTINUE
71313
71314C...Initialize writing of DATA statements for inclusion in program.
71315 DO 300 IVAR=1,22
71316 NDIM=MSTU(6)
71317 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
71318 NLIN=1
71319 CHLIN=' '
71320 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
71321 LLIN=35
71322 CHOLD='START'
71323
71324C...Loop through variables for conversion to characters.
71325 DO 280 IDIM=1,NDIM
71326 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
71327 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
71328 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
71329 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
71330 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
71331 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
71332 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
71333 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
71334 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
71335 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
71336 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
71337 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
71338 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
71339 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
71340 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
71341 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
71342 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
71343 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
71344 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
71345 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
71346 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
71347 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
71348
71349C...Replace variables beyond what is properly defined.
71350 IF(IVAR.LE.4) THEN
71351 IF(IDIM.GT.KCC) CHTMP=' 0'
71352 ELSEIF(IVAR.LE.8) THEN
71353 IF(IDIM.GT.KCC) CHTMP=' 0.0'
71354 ELSEIF(IVAR.LE.11) THEN
71355 IF(IDIM.GT.KCC) CHTMP=' 0'
71356 ELSEIF(IVAR.LE.13) THEN
71357 IF(IDIM.GT.NDC) CHTMP=' 0'
71358 ELSEIF(IVAR.LE.14) THEN
71359 IF(IDIM.GT.NDC) CHTMP=' 0.0'
71360 ELSEIF(IVAR.LE.19) THEN
71361 IF(IDIM.GT.NDC) CHTMP=' 0'
71362 ELSEIF(IVAR.LE.21) THEN
71363 IF(IDIM.GT.KCC) CHTMP=' '
71364 ELSE
71365 IF(IDIM.GT.KCC) CHTMP=' 0'
71366 ENDIF
71367
71368C...Length of variable, trailing decimal zeros, quotation marks.
71369 LLOW=1
71370 LHIG=1
71371 DO 240 LL=1,16
71372 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
71373 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
71374 240 CONTINUE
71375 CHNEW=CHTMP(LLOW:LHIG)//' '
71376 LNEW=1+LHIG-LLOW
71377 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
71378 LNEW=LNEW+1
71379 250 LNEW=LNEW-1
71380 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
71381 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
71382 IF(LNEW.EQ.0) THEN
71383 CHNEW(1:3)='0D0'
71384 LNEW=3
71385 ELSE
71386 CHNEW(LNEW+1:LNEW+2)='D0'
71387 LNEW=LNEW+2
71388 ENDIF
71389 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
71390 DO 260 LL=LNEW,1,-1
71391 IF(CHNEW(LL:LL).EQ.'''') THEN
71392 CHTMP=CHNEW
71393 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
71394 LNEW=LNEW+1
71395 ENDIF
71396 260 CONTINUE
71397 LNEW=MIN(14,LNEW)
71398 CHTMP=CHNEW
71399 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
71400 LNEW=LNEW+2
71401 ENDIF
71402
71403C...Form composite character string, often including repetition counter.
71404 IF(CHNEW.NE.CHOLD) THEN
71405 NRPT=1
71406 CHOLD=CHNEW
71407 CHCOM=CHNEW
71408 LCOM=LNEW
71409 ELSE
71410 LRPT=LNEW+1
71411 IF(NRPT.GE.2) LRPT=LNEW+3
71412 IF(NRPT.GE.10) LRPT=LNEW+4
71413 IF(NRPT.GE.100) LRPT=LNEW+5
71414 IF(NRPT.GE.1000) LRPT=LNEW+6
71415 LLIN=LLIN-LRPT
71416 NRPT=NRPT+1
71417 WRITE(CHTMP,5400) NRPT
71418 LRPT=1
71419 IF(NRPT.GE.10) LRPT=2
71420 IF(NRPT.GE.100) LRPT=3
71421 IF(NRPT.GE.1000) LRPT=4
71422 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
71423 LCOM=LRPT+1+LNEW
71424 ENDIF
71425
71426C...Add characters to end of line, to new line (after storing old line),
71427C...or to new block of lines (after writing old block).
71428 IF(LLIN+LCOM.LE.70) THEN
71429 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
71430 LLIN=LLIN+LCOM+1
71431 ELSEIF(NLIN.LE.19) THEN
71432 CHLIN(LLIN+1:72)=' '
71433 CHBLK(NLIN)=CHLIN
71434 NLIN=NLIN+1
71435 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
71436 LLIN=6+LCOM+1
71437 ELSE
71438 CHLIN(LLIN:72)='/'//' '
71439 CHBLK(NLIN)=CHLIN
71440 WRITE(CHTMP,5400) IDIM-NRPT
71441 CHBLK(1)(30:33)=CHTMP(13:16)
71442 DO 270 ILIN=1,NLIN
71443 WRITE(LFN,5700) CHBLK(ILIN)
71444 270 CONTINUE
71445 NLIN=1
71446 CHLIN=' '
71447 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
71448 & ',I= , )/'//CHCOM(1:LCOM)//','
71449 WRITE(CHTMP,5400) IDIM-NRPT+1
71450 CHLIN(25:28)=CHTMP(13:16)
71451 LLIN=35+LCOM+1
71452 ENDIF
71453 280 CONTINUE
71454
71455C...Write final block of lines.
71456 CHLIN(LLIN:72)='/'//' '
71457 CHBLK(NLIN)=CHLIN
71458 WRITE(CHTMP,5400) NDIM
71459 CHBLK(1)(30:33)=CHTMP(13:16)
71460 DO 290 ILIN=1,NLIN
71461 WRITE(LFN,5700) CHBLK(ILIN)
71462 290 CONTINUE
71463 300 CONTINUE
71464 ENDIF
71465
71466C...Formats for reading and writing particle data.
71467 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
71468 5100 FORMAT(10X,2I5,F12.6,5I10)
71469 5200 FORMAT(A120)
71470 5300 FORMAT(I9)
71471 5400 FORMAT(I16)
71472 5500 FORMAT(F16.5)
71473 5600 FORMAT(F16.6)
71474 5700 FORMAT(A72)
71475
71476 RETURN
71477 END
71478
71479C*********************************************************************
71480
71481C...PYK
71482C...Provides various integer-valued event related data.
71483
71484 FUNCTION PYK(I,J)
71485
71486C...Double precision and integer declarations.
71487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71488 IMPLICIT INTEGER(I-N)
71489 INTEGER PYK,PYCHGE,PYCOMP
71490C...Commonblocks.
71491 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71494 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71495
71496C...Default value. For I=0 number of entries, number of stable entries
71497C...or 3 times total charge.
71498 PYK=0
71499 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71500 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
71501 PYK=N
71502 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
71503 DO 100 I1=1,N
71504 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
71505 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
71506 & PYCHGE(K(I1,2))
71507 100 CONTINUE
71508 ELSEIF(I.EQ.0) THEN
71509
71510C...For I > 0 direct readout of K matrix or charge.
71511 ELSEIF(J.LE.5) THEN
71512 PYK=K(I,J)
71513 ELSEIF(J.EQ.6) THEN
71514 PYK=PYCHGE(K(I,2))
71515
71516C...Status (existing/fragmented/decayed), parton/hadron separation.
71517 ELSEIF(J.LE.8) THEN
71518 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
71519 IF(J.EQ.8) PYK=PYK*K(I,2)
71520 ELSEIF(J.LE.12) THEN
71521 KFA=IABS(K(I,2))
71522 KC=PYCOMP(KFA)
71523 KQ=0
71524 IF(KC.NE.0) KQ=KCHG(KC,2)
71525 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
71526 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
71527 IF(J.EQ.11) PYK=KC
71528 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
71529
71530C...Heaviest flavour in hadron/diquark.
71531 ELSEIF(J.EQ.13) THEN
71532 KFA=IABS(K(I,2))
71533 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
71534 IF(KFA.LT.10) PYK=KFA
71535 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
71536 PYK=PYK*ISIGN(1,K(I,2))
71537
71538C...Particle history: generation, ancestor, rank.
71539 ELSEIF(J.LE.15) THEN
71540 I2=I
71541 I1=I
71542 110 PYK=PYK+1
71543 I2=I1
71544 I1=K(I1,3)
71545 IF(I1.GT.0) THEN
71546 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
71547 ENDIF
71548 IF(J.EQ.15) PYK=I2
71549 ELSEIF(J.EQ.16) THEN
71550 KFA=IABS(K(I,2))
71551 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
71552 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
71553 I1=I
71554 120 I2=I1
71555 I1=K(I1,3)
71556 IF(I1.GT.0) THEN
71557 KFAM=IABS(K(I1,2))
71558 ILP=1
71559 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
71560 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
71561 & ILP=0
71562 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
71563 IF(ILP.EQ.1) GOTO 120
71564 ENDIF
71565 IF(K(I1,1).EQ.12) THEN
71566 DO 130 I3=I1+1,I2
71567 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
71568 & .AND.K(I3,2).NE.93) PYK=PYK+1
71569 130 CONTINUE
71570 ELSE
71571 I3=I2
71572 140 PYK=PYK+1
71573 I3=I3+1
71574 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
71575 ENDIF
71576 ENDIF
71577
71578C...Particle coming from collapsing jet system or not.
71579 ELSEIF(J.EQ.17) THEN
71580 I1=I
71581 150 PYK=PYK+1
71582 I3=I1
71583 I1=K(I1,3)
71584 I0=MAX(1,I1)
71585 KC=PYCOMP(K(I0,2))
71586 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
71587 IF(PYK.EQ.1) PYK=-1
71588 IF(PYK.GT.1) PYK=0
71589 RETURN
71590 ENDIF
71591 IF(KCHG(KC,2).EQ.0) GOTO 150
71592 IF(K(I1,1).NE.12) PYK=0
71593 IF(K(I1,1).NE.12) RETURN
71594 I2=I1
71595 160 I2=I2+1
71596 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
71597 K3M=K(I3-1,3)
71598 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
71599 K3P=K(I3+1,3)
71600 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
71601
71602C...Number of decay products. Colour flow.
71603 ELSEIF(J.EQ.18) THEN
71604 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
71605 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
71606 ELSEIF(J.LE.22) THEN
71607 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
71608 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
71609 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
71610 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
71611 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
71612 ELSE
71613 ENDIF
71614
71615 RETURN
71616 END
71617
71618C*********************************************************************
71619
71620C...PYP
71621C...Provides various real-valued event related data.
71622
71623 FUNCTION PYP(I,J)
71624
71625C...Double precision and integer declarations.
71626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71627 IMPLICIT INTEGER(I-N)
71628 INTEGER PYK,PYCHGE,PYCOMP
71629C...Commonblocks.
71630 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71632 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71633 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71634C...Local array.
71635 DIMENSION PSUM(4)
71636
71637C...Set default value. For I = 0 sum of momenta or charges,
71638C...or invariant mass of system.
71639 PYP=0D0
71640 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
71641 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
71642 DO 100 I1=1,N
71643 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
71644 100 CONTINUE
71645 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
71646 DO 120 J1=1,4
71647 PSUM(J1)=0D0
71648 DO 110 I1=1,N
71649 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
71650 & P(I1,J1)
71651 110 CONTINUE
71652 120 CONTINUE
71653 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71654 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
71655 DO 130 I1=1,N
71656 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
71657 130 CONTINUE
71658 ELSEIF(I.EQ.0) THEN
71659
71660C...Direct readout of P matrix.
71661 ELSEIF(J.LE.5) THEN
71662 PYP=P(I,J)
71663
71664C...Charge, total momentum, transverse momentum, transverse mass.
71665 ELSEIF(J.LE.12) THEN
71666 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
71667 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
71668 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
71669 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
71670 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
71671
71672C...Theta and phi angle in radians or degrees.
71673 ELSEIF(J.LE.16) THEN
71674 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
71675 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
71676 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
71677
71678C...True rapidity, rapidity with pion mass, pseudorapidity.
71679 ELSEIF(J.LE.19) THEN
71680 PMR=0D0
71681 IF(J.EQ.17) PMR=P(I,5)
71682 IF(J.EQ.18) PMR=PYMASS(211)
71683 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
71684 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
71685 & 1D20)),P(I,3))
71686
71687C...Energy and momentum fractions (only to be used in CM frame).
71688 ELSEIF(J.LE.25) THEN
71689 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
71690 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
71691 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
71692 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
71693 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
71694 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
71695 ENDIF
71696
71697 RETURN
71698 END
71699
71700C*********************************************************************
71701
71702C...PYSPHE
71703C...Performs sphericity tensor analysis to give sphericity,
71704C...aplanarity and the related event axes.
71705
71706 SUBROUTINE PYSPHE(SPH,APL)
71707
71708C...Double precision and integer declarations.
71709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71710 IMPLICIT INTEGER(I-N)
71711 INTEGER PYK,PYCHGE,PYCOMP
71712C...Parameter statement to help give large particle numbers.
71713 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71714 &KEXCIT=4000000,KDIMEN=5000000)
71715C...Commonblocks.
71716 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71718 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71719 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71720C...Local arrays.
71721 DIMENSION SM(3,3),SV(3,3)
71722
71723C...Calculate matrix to be diagonalized.
71724 NP=0
71725 DO 110 J1=1,3
71726 DO 100 J2=J1,3
71727 SM(J1,J2)=0D0
71728 100 CONTINUE
71729 110 CONTINUE
71730 PS=0D0
71731 DO 140 I=1,N
71732 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
71733 IF(MSTU(41).GE.2) THEN
71734 KC=PYCOMP(K(I,2))
71735 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71736 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71737 & K(I,2).EQ.KSUSY1+39) GOTO 140
71738 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71739 & GOTO 140
71740 ENDIF
71741 NP=NP+1
71742 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71743 PWT=1D0
71744 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
71745 & MAX(1D-10,PA)**(PARU(41)-2D0)
71746 DO 130 J1=1,3
71747 DO 120 J2=J1,3
71748 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
71749 120 CONTINUE
71750 130 CONTINUE
71751 PS=PS+PWT*PA**2
71752 140 CONTINUE
71753
71754C...Very low multiplicities (0 or 1) not considered.
71755 IF(NP.LE.1) THEN
71756 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
71757 SPH=-1D0
71758 APL=-1D0
71759 RETURN
71760 ENDIF
71761 DO 160 J1=1,3
71762 DO 150 J2=J1,3
71763 SM(J1,J2)=SM(J1,J2)/PS
71764 150 CONTINUE
71765 160 CONTINUE
71766
71767C...Find eigenvalues to matrix (third degree equation).
71768 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
71769 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
71770 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
71771 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
71772 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
71773 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
71774 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
71775 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
71776 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
71777 IF(P(N+2,4).LT.1D-5) THEN
71778 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
71779 SPH=-1D0
71780 APL=-1D0
71781 RETURN
71782 ENDIF
71783
71784C...Find first and last eigenvector by solving equation system.
71785 DO 240 I=1,3,2
71786 DO 180 J1=1,3
71787 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
71788 DO 170 J2=J1+1,3
71789 SV(J1,J2)=SM(J1,J2)
71790 SV(J2,J1)=SM(J1,J2)
71791 170 CONTINUE
71792 180 CONTINUE
71793 SMAX=0D0
71794 DO 200 J1=1,3
71795 DO 190 J2=1,3
71796 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
71797 JA=J1
71798 JB=J2
71799 SMAX=ABS(SV(J1,J2))
71800 190 CONTINUE
71801 200 CONTINUE
71802 SMAX=0D0
71803 DO 220 J3=JA+1,JA+2
71804 J1=J3-3*((J3-1)/3)
71805 RL=SV(J1,JB)/SV(JA,JB)
71806 DO 210 J2=1,3
71807 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
71808 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
71809 JC=J1
71810 SMAX=ABS(SV(J1,J2))
71811 210 CONTINUE
71812 220 CONTINUE
71813 JB1=JB+1-3*(JB/3)
71814 JB2=JB+2-3*((JB+1)/3)
71815 P(N+I,JB1)=-SV(JC,JB2)
71816 P(N+I,JB2)=SV(JC,JB1)
71817 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
71818 & SV(JA,JB)
71819 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
71820 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71821 DO 230 J=1,3
71822 P(N+I,J)=SGN*P(N+I,J)/PA
71823 230 CONTINUE
71824 240 CONTINUE
71825
71826C...Middle axis orthogonal to other two. Fill other codes.
71827 SGN=(-1D0)**INT(PYR(0)+0.5D0)
71828 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
71829 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
71830 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
71831 DO 260 I=1,3
71832 K(N+I,1)=31
71833 K(N+I,2)=95
71834 K(N+I,3)=I
71835 K(N+I,4)=0
71836 K(N+I,5)=0
71837 P(N+I,5)=0D0
71838 DO 250 J=1,5
71839 V(I,J)=0D0
71840 250 CONTINUE
71841 260 CONTINUE
71842
71843C...Calculate sphericity and aplanarity. Select storing option.
71844 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
71845 APL=1.5D0*P(N+3,4)
71846 MSTU(61)=N+1
71847 MSTU(62)=NP
71848 IF(MSTU(43).LE.1) MSTU(3)=3
71849 IF(MSTU(43).GE.2) N=N+3
71850
71851 RETURN
71852 END
71853
71854C*********************************************************************
71855
71856C...PYTHRU
71857C...Performs thrust analysis to give thrust, oblateness
71858C...and the related event axes.
71859
71860 SUBROUTINE PYTHRU(THR,OBL)
71861
71862C...Double precision and integer declarations.
71863 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71864 IMPLICIT INTEGER(I-N)
71865 INTEGER PYK,PYCHGE,PYCOMP
71866C...Parameter statement to help give large particle numbers.
71867 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71868 &KEXCIT=4000000,KDIMEN=5000000)
71869C...Commonblocks.
71870 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71871 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71872 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71873 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
71874C...Local arrays.
71875 DIMENSION TDI(3),TPR(3)
71876
71877C...Take copy of particles that are to be considered in thrust analysis.
71878 NP=0
71879 PS=0D0
71880 DO 100 I=1,N
71881 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
71882 IF(MSTU(41).GE.2) THEN
71883 KC=PYCOMP(K(I,2))
71884 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
71885 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
71886 & K(I,2).EQ.KSUSY1+39) GOTO 100
71887 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
71888 & GOTO 100
71889 ENDIF
71890 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
71891 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
71892 THR=-2D0
71893 OBL=-2D0
71894 RETURN
71895 ENDIF
71896 NP=NP+1
71897 K(N+NP,1)=23
71898 P(N+NP,1)=P(I,1)
71899 P(N+NP,2)=P(I,2)
71900 P(N+NP,3)=P(I,3)
71901 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
71902 P(N+NP,5)=1D0
71903 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
71904 & P(N+NP,4)**(PARU(42)-1D0)
71905 PS=PS+P(N+NP,4)*P(N+NP,5)
71906 100 CONTINUE
71907
71908C...Very low multiplicities (0 or 1) not considered.
71909 IF(NP.LE.1) THEN
71910 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
71911 THR=-1D0
71912 OBL=-1D0
71913 RETURN
71914 ENDIF
71915
71916C...Loop over thrust and major. T axis along z direction in latter case.
71917 DO 320 ILD=1,2
71918 IF(ILD.EQ.2) THEN
71919 K(N+NP+1,1)=31
71920 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
71921 MSTU(33)=1
71922 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
71923 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
71924 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
71925 ENDIF
71926
71927C...Find and order particles with highest p (pT for major).
71928 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
71929 P(ILF,4)=0D0
71930 110 CONTINUE
71931 DO 160 I=N+1,N+NP
71932 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
71933 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
71934 IF(P(I,4).LE.P(ILF,4)) GOTO 140
71935 DO 120 J=1,5
71936 P(ILF+1,J)=P(ILF,J)
71937 120 CONTINUE
71938 130 CONTINUE
71939 ILF=N+NP+3
71940 140 DO 150 J=1,5
71941 P(ILF+1,J)=P(I,J)
71942 150 CONTINUE
71943 160 CONTINUE
71944
71945C...Find and order initial axes with highest thrust (major).
71946 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
71947 P(ILG,4)=0D0
71948 170 CONTINUE
71949 NC=2**(MIN(MSTU(44),NP)-1)
71950 DO 250 ILC=1,NC
71951 DO 180 J=1,3
71952 TDI(J)=0D0
71953 180 CONTINUE
71954 DO 200 ILF=1,MIN(MSTU(44),NP)
71955 SGN=P(N+NP+ILF+3,5)
71956 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
71957 DO 190 J=1,4-ILD
71958 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
71959 190 CONTINUE
71960 200 CONTINUE
71961 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
71962 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
71963 IF(TDS.LE.P(ILG,4)) GOTO 230
71964 DO 210 J=1,4
71965 P(ILG+1,J)=P(ILG,J)
71966 210 CONTINUE
71967 220 CONTINUE
71968 ILG=N+NP+MSTU(44)+4
71969 230 DO 240 J=1,3
71970 P(ILG+1,J)=TDI(J)
71971 240 CONTINUE
71972 P(ILG+1,4)=TDS
71973 250 CONTINUE
71974
71975C...Iterate direction of axis until stable maximum.
71976 P(N+NP+ILD,4)=0D0
71977 ILG=0
71978 260 ILG=ILG+1
71979 THP=0D0
71980 270 THPS=THP
71981 DO 280 J=1,3
71982 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
71983 IF(THP.GT.1D-10) TDI(J)=TPR(J)
71984 TPR(J)=0D0
71985 280 CONTINUE
71986 DO 300 I=N+1,N+NP
71987 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
71988 DO 290 J=1,4-ILD
71989 TPR(J)=TPR(J)+SGN*P(I,J)
71990 290 CONTINUE
71991 300 CONTINUE
71992 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
71993 IF(THP.GE.THPS+PARU(48)) GOTO 270
71994
71995C...Save good axis. Try new initial axis until a number of tries agree.
71996 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
71997 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
71998 IAGR=0
71999 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72000 DO 310 J=1,3
72001 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
72002 310 CONTINUE
72003 P(N+NP+ILD,4)=THP
72004 P(N+NP+ILD,5)=0D0
72005 ENDIF
72006 IAGR=IAGR+1
72007 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
72008 320 CONTINUE
72009
72010C...Find minor axis and value by orthogonality.
72011 SGN=(-1D0)**INT(PYR(0)+0.5D0)
72012 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
72013 P(N+NP+3,2)=SGN*P(N+NP+2,1)
72014 P(N+NP+3,3)=0D0
72015 THP=0D0
72016 DO 330 I=N+1,N+NP
72017 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
72018 330 CONTINUE
72019 P(N+NP+3,4)=THP/PS
72020 P(N+NP+3,5)=0D0
72021
72022C...Fill axis information. Rotate back to original coordinate system.
72023 DO 350 ILD=1,3
72024 K(N+ILD,1)=31
72025 K(N+ILD,2)=96
72026 K(N+ILD,3)=ILD
72027 K(N+ILD,4)=0
72028 K(N+ILD,5)=0
72029 DO 340 J=1,5
72030 P(N+ILD,J)=P(N+NP+ILD,J)
72031 V(N+ILD,J)=0D0
72032 340 CONTINUE
72033 350 CONTINUE
72034 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
72035
72036C...Calculate thrust and oblateness. Select storing option.
72037 THR=P(N+1,4)
72038 OBL=P(N+2,4)-P(N+3,4)
72039 MSTU(61)=N+1
72040 MSTU(62)=NP
72041 IF(MSTU(43).LE.1) MSTU(3)=3
72042 IF(MSTU(43).GE.2) N=N+3
72043
72044 RETURN
72045 END
72046
72047C*********************************************************************
72048
72049C...PYCLUS
72050C...Subdivides the particle content of an event into jets/clusters.
72051
72052 SUBROUTINE PYCLUS(NJET)
72053
72054C...Double precision and integer declarations.
72055 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72056 IMPLICIT INTEGER(I-N)
72057 INTEGER PYK,PYCHGE,PYCOMP
72058C...Parameter statement to help give large particle numbers.
72059 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72060 &KEXCIT=4000000,KDIMEN=5000000)
72061C...Commonblocks.
72062 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72063 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72064 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72065 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72066C...Local arrays and saved variables.
72067 DIMENSION PS(5)
72068 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
72069
72070C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
72071 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
72072 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
72073 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
72074 &P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72075 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
72076 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/(P(I1,5)*P(I2,5)))
72077
72078C...If first time, reset. If reentering, skip preliminaries.
72079 IF(MSTU(48).LE.0) THEN
72080 NP=0
72081 DO 100 J=1,5
72082 PS(J)=0D0
72083 100 CONTINUE
72084 PSS=0D0
72085 PIMASS=PMAS(PYCOMP(211),1)
72086 ELSE
72087 NJET=NSAV
72088 IF(MSTU(43).GE.2) N=N-NJET
72089 DO 110 I=N+1,N+NJET
72090 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72091 110 CONTINUE
72092 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72093 R2ACC=PARU(44)**2
72094 ELSE
72095 R2ACC=PARU(45)*PS(5)**2
72096 ENDIF
72097 NLOOP=0
72098 GOTO 300
72099 ENDIF
72100
72101C...Find which particles are to be considered in cluster search.
72102 DO 140 I=1,N
72103 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
72104 IF(MSTU(41).GE.2) THEN
72105 KC=PYCOMP(K(I,2))
72106 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72107 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72108 & K(I,2).EQ.KSUSY1+39) GOTO 140
72109 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72110 & GOTO 140
72111 ENDIF
72112 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
72113 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
72114 NJET=-1
72115 RETURN
72116 ENDIF
72117
72118C...Take copy of these particles, with space left for jets later on.
72119 NP=NP+1
72120 K(N+NP,3)=I
72121 DO 120 J=1,5
72122 P(N+NP,J)=P(I,J)
72123 120 CONTINUE
72124 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72125 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72126 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72127 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72128 DO 130 J=1,4
72129 PS(J)=PS(J)+P(N+NP,J)
72130 130 CONTINUE
72131 PSS=PSS+P(N+NP,5)
72132 140 CONTINUE
72133 DO 160 I=N+1,N+NP
72134 K(I+NP,3)=K(I,3)
72135 DO 150 J=1,5
72136 P(I+NP,J)=P(I,J)
72137 150 CONTINUE
72138 160 CONTINUE
72139 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
72140
72141C...Very low multiplicities not considered.
72142 IF(NP.LT.MSTU(47)) THEN
72143 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
72144 NJET=-1
72145 RETURN
72146 ENDIF
72147
72148C...Find precluster configuration. If too few jets, make harder cuts.
72149 NLOOP=0
72150 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
72151 R2ACC=PARU(44)**2
72152 ELSE
72153 R2ACC=PARU(45)*PS(5)**2
72154 ENDIF
72155 RINIT=1.25D0*PARU(43)
72156 IF(NP.LE.MSTU(47)+2) RINIT=0D0
72157 170 RINIT=0.8D0*RINIT
72158 NPRE=0
72159 NREM=NP
72160 DO 180 I=N+NP+1,N+2*NP
72161 K(I,4)=0
72162 180 CONTINUE
72163
72164C...Sum up small momentum region. Jet if enough absolute momentum.
72165 IF(MSTU(46).LE.2) THEN
72166 DO 190 J=1,4
72167 P(N+1,J)=0D0
72168 190 CONTINUE
72169 DO 210 I=N+NP+1,N+2*NP
72170 IF(P(I,5).GT.2D0*RINIT) GOTO 210
72171 NREM=NREM-1
72172 K(I,4)=1
72173 DO 200 J=1,4
72174 P(N+1,J)=P(N+1,J)+P(I,J)
72175 200 CONTINUE
72176 210 CONTINUE
72177 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
72178 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
72179 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72180 IF(NREM.EQ.0) GOTO 170
72181 ENDIF
72182
72183C...Find fastest remaining particle.
72184 220 NPRE=NPRE+1
72185 PMAX=0D0
72186 DO 230 I=N+NP+1,N+2*NP
72187 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
72188 IMAX=I
72189 PMAX=P(I,5)
72190 230 CONTINUE
72191 DO 240 J=1,5
72192 P(N+NPRE,J)=P(IMAX,J)
72193 240 CONTINUE
72194 NREM=NREM-1
72195 K(IMAX,4)=NPRE
72196
72197C...Sum up precluster around it according to pT separation.
72198 IF(MSTU(46).LE.2) THEN
72199 DO 260 I=N+NP+1,N+2*NP
72200 IF(K(I,4).NE.0) GOTO 260
72201 R2=R2T(I,IMAX)
72202 IF(R2.GT.RINIT**2) GOTO 260
72203 NREM=NREM-1
72204 K(I,4)=NPRE
72205 DO 250 J=1,4
72206 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
72207 250 CONTINUE
72208 260 CONTINUE
72209 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72210
72211C...Sum up precluster around it according to mass or
72212C...Durham pT separation.
72213 ELSE
72214 270 IMIN=0
72215 R2MIN=RINIT**2
72216 DO 280 I=N+NP+1,N+2*NP
72217 IF(K(I,4).NE.0) GOTO 280
72218 IF(MSTU(46).LE.4) THEN
72219 R2=R2M(I,N+NPRE)
72220 ELSE
72221 R2=R2D(I,N+NPRE)
72222 ENDIF
72223 IF(R2.GE.R2MIN) GOTO 280
72224 IMIN=I
72225 R2MIN=R2
72226 280 CONTINUE
72227 IF(IMIN.NE.0) THEN
72228 DO 290 J=1,4
72229 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
72230 290 CONTINUE
72231 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
72232 NREM=NREM-1
72233 K(IMIN,4)=NPRE
72234 GOTO 270
72235 ENDIF
72236 ENDIF
72237
72238C...Check if more preclusters to be found. Start over if too few.
72239 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
72240 IF(NREM.GT.0) GOTO 220
72241 NJET=NPRE
72242
72243C...Reassign all particles to nearest jet. Sum up new jet momenta.
72244 300 TSAV=0D0
72245 PSJT=0D0
72246 310 IF(MSTU(46).LE.1) THEN
72247 DO 330 I=N+1,N+NJET
72248 DO 320 J=1,4
72249 V(I,J)=0D0
72250 320 CONTINUE
72251 330 CONTINUE
72252 DO 360 I=N+NP+1,N+2*NP
72253 R2MIN=PSS**2
72254 DO 340 IJET=N+1,N+NJET
72255 IF(P(IJET,5).LT.RINIT) GOTO 340
72256 R2=R2T(I,IJET)
72257 IF(R2.GE.R2MIN) GOTO 340
72258 IMIN=IJET
72259 R2MIN=R2
72260 340 CONTINUE
72261 K(I,4)=IMIN-N
72262 DO 350 J=1,4
72263 V(IMIN,J)=V(IMIN,J)+P(I,J)
72264 350 CONTINUE
72265 360 CONTINUE
72266 PSJT=0D0
72267 DO 380 I=N+1,N+NJET
72268 DO 370 J=1,4
72269 P(I,J)=V(I,J)
72270 370 CONTINUE
72271 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72272 PSJT=PSJT+P(I,5)
72273 380 CONTINUE
72274 ENDIF
72275
72276C...Find two closest jets.
72277 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
72278 DO 400 ITRY1=N+1,N+NJET-1
72279 DO 390 ITRY2=ITRY1+1,N+NJET
72280 IF(MSTU(46).LE.2) THEN
72281 R2=R2T(ITRY1,ITRY2)
72282 ELSEIF(MSTU(46).LE.4) THEN
72283 R2=R2M(ITRY1,ITRY2)
72284 ELSE
72285 R2=R2D(ITRY1,ITRY2)
72286 ENDIF
72287 IF(R2.GE.R2MIN) GOTO 390
72288 IMIN1=ITRY1
72289 IMIN2=ITRY2
72290 R2MIN=R2
72291 390 CONTINUE
72292 400 CONTINUE
72293
72294C...If allowed, join two closest jets and start over.
72295 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
72296 IREC=MIN(IMIN1,IMIN2)
72297 IDEL=MAX(IMIN1,IMIN2)
72298 DO 410 J=1,4
72299 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
72300 410 CONTINUE
72301 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
72302 DO 430 I=IDEL+1,N+NJET
72303 DO 420 J=1,5
72304 P(I-1,J)=P(I,J)
72305 420 CONTINUE
72306 430 CONTINUE
72307 IF(MSTU(46).GE.2) THEN
72308 DO 440 I=N+NP+1,N+2*NP
72309 IORI=N+K(I,4)
72310 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
72311 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
72312 440 CONTINUE
72313 ENDIF
72314 NJET=NJET-1
72315 GOTO 300
72316
72317C...Divide up broad jet if empty cluster in list of final ones.
72318 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
72319 DO 450 I=N+1,N+NJET
72320 K(I,5)=0
72321 450 CONTINUE
72322 DO 460 I=N+NP+1,N+2*NP
72323 K(N+K(I,4),5)=K(N+K(I,4),5)+1
72324 460 CONTINUE
72325 IEMP=0
72326 DO 470 I=N+1,N+NJET
72327 IF(K(I,5).EQ.0) IEMP=I
72328 470 CONTINUE
72329 IF(IEMP.NE.0) THEN
72330 NLOOP=NLOOP+1
72331 ISPL=0
72332 R2MAX=0D0
72333 DO 480 I=N+NP+1,N+2*NP
72334 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
72335 IJET=N+K(I,4)
72336 R2=R2T(I,IJET)
72337 IF(R2.LE.R2MAX) GOTO 480
72338 ISPL=I
72339 R2MAX=R2
72340 480 CONTINUE
72341 IF(ISPL.NE.0) THEN
72342 IJET=N+K(ISPL,4)
72343 DO 490 J=1,4
72344 P(IEMP,J)=P(ISPL,J)
72345 P(IJET,J)=P(IJET,J)-P(ISPL,J)
72346 490 CONTINUE
72347 P(IEMP,5)=P(ISPL,5)
72348 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
72349 IF(NLOOP.LE.2) GOTO 300
72350 ENDIF
72351 ENDIF
72352 ENDIF
72353
72354C...If generalized thrust has not yet converged, continue iteration.
72355 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
72356 &THEN
72357 TSAV=PSJT/PSS
72358 GOTO 310
72359 ENDIF
72360
72361C...Reorder jets according to energy.
72362 DO 510 I=N+1,N+NJET
72363 DO 500 J=1,5
72364 V(I,J)=P(I,J)
72365 500 CONTINUE
72366 510 CONTINUE
72367 DO 540 INEW=N+1,N+NJET
72368 PEMAX=0D0
72369 DO 520 ITRY=N+1,N+NJET
72370 IF(V(ITRY,4).LE.PEMAX) GOTO 520
72371 IMAX=ITRY
72372 PEMAX=V(ITRY,4)
72373 520 CONTINUE
72374 K(INEW,1)=31
72375 K(INEW,2)=97
72376 K(INEW,3)=INEW-N
72377 K(INEW,4)=0
72378 DO 530 J=1,5
72379 P(INEW,J)=V(IMAX,J)
72380 530 CONTINUE
72381 V(IMAX,4)=-1D0
72382 K(IMAX,5)=INEW
72383 540 CONTINUE
72384
72385C...Clean up particle-jet assignments and jet information.
72386 DO 550 I=N+NP+1,N+2*NP
72387 IORI=K(N+K(I,4),5)
72388 K(I,4)=IORI-N
72389 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
72390 K(IORI,4)=K(IORI,4)+1
72391 550 CONTINUE
72392 IEMP=0
72393 PSJT=0D0
72394 DO 570 I=N+1,N+NJET
72395 K(I,5)=0
72396 PSJT=PSJT+P(I,5)
72397 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
72398 DO 560 J=1,5
72399 V(I,J)=0D0
72400 560 CONTINUE
72401 IF(K(I,4).EQ.0) IEMP=I
72402 570 CONTINUE
72403
72404C...Select storing option. Output variables. Check for failure.
72405 MSTU(61)=N+1
72406 MSTU(62)=NP
72407 MSTU(63)=NPRE
72408 PARU(61)=PS(5)
72409 PARU(62)=PSJT/PSS
72410 PARU(63)=SQRT(R2MIN)
72411 IF(NJET.LE.1) PARU(63)=0D0
72412 IF(IEMP.NE.0) THEN
72413 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
72414 NJET=-1
72415 RETURN
72416 ENDIF
72417 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72418 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72419 NSAV=NJET
72420
72421 RETURN
72422 END
72423
72424C*********************************************************************
72425
72426C...PYCELL
72427C...Provides a simple way of jet finding in eta-phi-ET coordinates,
72428C...as used for calorimeters at hadron colliders.
72429
72430 SUBROUTINE PYCELL(NJET)
72431
72432C...Double precision and integer declarations.
72433 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72434 IMPLICIT INTEGER(I-N)
72435 INTEGER PYK,PYCHGE,PYCOMP
72436C...Parameter statement to help give large particle numbers.
72437 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72438 &KEXCIT=4000000,KDIMEN=5000000)
72439C...Commonblocks.
72440 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72441 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72442 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72443 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72444
72445C...Loop over all particles. Find cell that was hit by given particle.
72446 PTLRAT=1D0/SINH(PARU(51))**2
72447 NP=0
72448 NC=N
72449 DO 110 I=1,N
72450 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72451 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
72452 IF(MSTU(41).GE.2) THEN
72453 KC=PYCOMP(K(I,2))
72454 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72455 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72456 & K(I,2).EQ.KSUSY1+39) GOTO 110
72457 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72458 & GOTO 110
72459 ENDIF
72460 NP=NP+1
72461 PT=SQRT(P(I,1)**2+P(I,2)**2)
72462 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
72463 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
72464 & (ETA/PARU(51)+1D0))))
72465 PHI=PYANGL(P(I,1),P(I,2))
72466 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
72467 & (PHI/PARU(1)+1D0))))
72468 IETPH=MSTU(52)*IETA+IPHI
72469
72470C...Add to cell already hit, or book new cell.
72471 DO 100 IC=N+1,NC
72472 IF(IETPH.EQ.K(IC,3)) THEN
72473 K(IC,4)=K(IC,4)+1
72474 P(IC,5)=P(IC,5)+PT
72475 GOTO 110
72476 ENDIF
72477 100 CONTINUE
72478 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
72479 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72480 NJET=-2
72481 RETURN
72482 ENDIF
72483 NC=NC+1
72484 K(NC,3)=IETPH
72485 K(NC,4)=1
72486 K(NC,5)=2
72487 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
72488 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
72489 P(NC,5)=PT
72490 110 CONTINUE
72491
72492C...Smear true bin content by calorimeter resolution.
72493 IF(MSTU(53).GE.1) THEN
72494 DO 130 IC=N+1,NC
72495 PEI=P(IC,5)
72496 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
72497 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
72498 & COS(PARU(2)*PYR(0))
72499 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
72500 P(IC,5)=PEF
72501 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
72502 130 CONTINUE
72503 ENDIF
72504
72505C...Remove cells below threshold.
72506 IF(PARU(58).GT.0D0) THEN
72507 NCC=NC
72508 NC=N
72509 DO 140 IC=N+1,NCC
72510 IF(P(IC,5).GT.PARU(58)) THEN
72511 NC=NC+1
72512 K(NC,3)=K(IC,3)
72513 K(NC,4)=K(IC,4)
72514 K(NC,5)=K(IC,5)
72515 P(NC,1)=P(IC,1)
72516 P(NC,2)=P(IC,2)
72517 P(NC,5)=P(IC,5)
72518 ENDIF
72519 140 CONTINUE
72520 ENDIF
72521
72522C...Find initiator cell: the one with highest pT of not yet used ones.
72523 NJ=NC
72524 150 ETMAX=0D0
72525 DO 160 IC=N+1,NC
72526 IF(K(IC,5).NE.2) GOTO 160
72527 IF(P(IC,5).LE.ETMAX) GOTO 160
72528 ICMAX=IC
72529 ETA=P(IC,1)
72530 PHI=P(IC,2)
72531 ETMAX=P(IC,5)
72532 160 CONTINUE
72533 IF(ETMAX.LT.PARU(52)) GOTO 220
72534 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
72535 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
72536 NJET=-2
72537 RETURN
72538 ENDIF
72539 K(ICMAX,5)=1
72540 NJ=NJ+1
72541 K(NJ,4)=0
72542 K(NJ,5)=1
72543 P(NJ,1)=ETA
72544 P(NJ,2)=PHI
72545 P(NJ,3)=0D0
72546 P(NJ,4)=0D0
72547 P(NJ,5)=0D0
72548
72549C...Sum up unused cells within required distance of initiator.
72550 DO 170 IC=N+1,NC
72551 IF(K(IC,5).EQ.0) GOTO 170
72552 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
72553 DPHIA=ABS(P(IC,2)-PHI)
72554 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
72555 PHIC=P(IC,2)
72556 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
72557 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
72558 K(IC,5)=-K(IC,5)
72559 K(NJ,4)=K(NJ,4)+K(IC,4)
72560 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
72561 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
72562 P(NJ,5)=P(NJ,5)+P(IC,5)
72563 170 CONTINUE
72564
72565C...Reject cluster below minimum ET, else accept.
72566 IF(P(NJ,5).LT.PARU(53)) THEN
72567 NJ=NJ-1
72568 DO 180 IC=N+1,NC
72569 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
72570 180 CONTINUE
72571 ELSEIF(MSTU(54).LE.2) THEN
72572 P(NJ,3)=P(NJ,3)/P(NJ,5)
72573 P(NJ,4)=P(NJ,4)/P(NJ,5)
72574 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
72575 & P(NJ,4))
72576 DO 190 IC=N+1,NC
72577 IF(K(IC,5).LT.0) K(IC,5)=0
72578 190 CONTINUE
72579 ELSE
72580 DO 200 J=1,4
72581 P(NJ,J)=0D0
72582 200 CONTINUE
72583 DO 210 IC=N+1,NC
72584 IF(K(IC,5).GE.0) GOTO 210
72585 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
72586 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
72587 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
72588 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
72589 K(IC,5)=0
72590 210 CONTINUE
72591 ENDIF
72592 GOTO 150
72593
72594C...Arrange clusters in falling ET sequence.
72595 220 DO 250 I=1,NJ-NC
72596 ETMAX=0D0
72597 DO 230 IJ=NC+1,NJ
72598 IF(K(IJ,5).EQ.0) GOTO 230
72599 IF(P(IJ,5).LT.ETMAX) GOTO 230
72600 IJMAX=IJ
72601 ETMAX=P(IJ,5)
72602 230 CONTINUE
72603 K(IJMAX,5)=0
72604 K(N+I,1)=31
72605 K(N+I,2)=98
72606 K(N+I,3)=I
72607 K(N+I,4)=K(IJMAX,4)
72608 K(N+I,5)=0
72609 DO 240 J=1,5
72610 P(N+I,J)=P(IJMAX,J)
72611 V(N+I,J)=0D0
72612 240 CONTINUE
72613 250 CONTINUE
72614 NJET=NJ-NC
72615
72616C...Convert to massless or massive four-vectors.
72617 IF(MSTU(54).EQ.2) THEN
72618 DO 260 I=N+1,N+NJET
72619 ETA=P(I,3)
72620 P(I,1)=P(I,5)*COS(P(I,4))
72621 P(I,2)=P(I,5)*SIN(P(I,4))
72622 P(I,3)=P(I,5)*SINH(ETA)
72623 P(I,4)=P(I,5)*COSH(ETA)
72624 P(I,5)=0D0
72625 260 CONTINUE
72626 ELSEIF(MSTU(54).GE.3) THEN
72627 DO 270 I=N+1,N+NJET
72628 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
72629 270 CONTINUE
72630 ENDIF
72631
72632C...Information about storage.
72633 MSTU(61)=N+1
72634 MSTU(62)=NP
72635 MSTU(63)=NC-N
72636 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
72637 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
72638
72639 RETURN
72640 END
72641
72642C*********************************************************************
72643
72644C...PYJMAS
72645C...Determines, approximately, the two jet masses that minimize
72646C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
72647
72648 SUBROUTINE PYJMAS(PMH,PML)
72649
72650C...Double precision and integer declarations.
72651 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72652 IMPLICIT INTEGER(I-N)
72653 INTEGER PYK,PYCHGE,PYCOMP
72654C...Parameter statement to help give large particle numbers.
72655 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72656 &KEXCIT=4000000,KDIMEN=5000000)
72657C...Commonblocks.
72658 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72659 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72660 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72661 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72662C...Local arrays.
72663 DIMENSION SM(3,3),SAX(3),PS(3,5)
72664
72665C...Reset.
72666 NP=0
72667 DO 120 J1=1,3
72668 DO 100 J2=J1,3
72669 SM(J1,J2)=0D0
72670 100 CONTINUE
72671 DO 110 J2=1,4
72672 PS(J1,J2)=0D0
72673 110 CONTINUE
72674 120 CONTINUE
72675 PSS=0D0
72676 PIMASS=PMAS(PYCOMP(211),1)
72677
72678C...Take copy of particles that are to be considered in mass analysis.
72679 DO 170 I=1,N
72680 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
72681 IF(MSTU(41).GE.2) THEN
72682 KC=PYCOMP(K(I,2))
72683 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72684 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72685 & K(I,2).EQ.KSUSY1+39) GOTO 170
72686 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72687 & GOTO 170
72688 ENDIF
72689 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
72690 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
72691 PMH=-2D0
72692 PML=-2D0
72693 RETURN
72694 ENDIF
72695 NP=NP+1
72696 DO 130 J=1,5
72697 P(N+NP,J)=P(I,J)
72698 130 CONTINUE
72699 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
72700 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
72701 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72702
72703C...Fill information in sphericity tensor and total momentum vector.
72704 DO 150 J1=1,3
72705 DO 140 J2=J1,3
72706 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
72707 140 CONTINUE
72708 150 CONTINUE
72709 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72710 DO 160 J=1,4
72711 PS(3,J)=PS(3,J)+P(N+NP,J)
72712 160 CONTINUE
72713 170 CONTINUE
72714
72715C...Very low multiplicities (0 or 1) not considered.
72716 IF(NP.LE.1) THEN
72717 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
72718 PMH=-1D0
72719 PML=-1D0
72720 RETURN
72721 ENDIF
72722 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
72723 &PS(3,3)**2))
72724
72725C...Find largest eigenvalue to matrix (third degree equation).
72726 DO 190 J1=1,3
72727 DO 180 J2=J1,3
72728 SM(J1,J2)=SM(J1,J2)/PSS
72729 180 CONTINUE
72730 190 CONTINUE
72731 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
72732 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
72733 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
72734 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
72735 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
72736 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
72737 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
72738
72739C...Find largest eigenvector by solving equation system.
72740 DO 210 J1=1,3
72741 SM(J1,J1)=SM(J1,J1)-SMA
72742 DO 200 J2=J1+1,3
72743 SM(J2,J1)=SM(J1,J2)
72744 200 CONTINUE
72745 210 CONTINUE
72746 SMAX=0D0
72747 DO 230 J1=1,3
72748 DO 220 J2=1,3
72749 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
72750 JA=J1
72751 JB=J2
72752 SMAX=ABS(SM(J1,J2))
72753 220 CONTINUE
72754 230 CONTINUE
72755 SMAX=0D0
72756 DO 250 J3=JA+1,JA+2
72757 J1=J3-3*((J3-1)/3)
72758 RL=SM(J1,JB)/SM(JA,JB)
72759 DO 240 J2=1,3
72760 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
72761 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
72762 JC=J1
72763 SMAX=ABS(SM(J1,J2))
72764 240 CONTINUE
72765 250 CONTINUE
72766 JB1=JB+1-3*(JB/3)
72767 JB2=JB+2-3*((JB+1)/3)
72768 SAX(JB1)=-SM(JC,JB2)
72769 SAX(JB2)=SM(JC,JB1)
72770 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
72771
72772C...Divide particles into two initial clusters by hemisphere.
72773 DO 270 I=N+1,N+NP
72774 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
72775 IS=1
72776 IF(PSAX.LT.0D0) IS=2
72777 K(I,3)=IS
72778 DO 260 J=1,4
72779 PS(IS,J)=PS(IS,J)+P(I,J)
72780 260 CONTINUE
72781 270 CONTINUE
72782 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
72783 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
72784
72785C...Reassign one particle at a time; find maximum decrease of m^2 sum.
72786 280 PMD=0D0
72787 IM=0
72788 DO 290 J=1,4
72789 PS(3,J)=PS(1,J)-PS(2,J)
72790 290 CONTINUE
72791 DO 300 I=N+1,N+NP
72792 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)
72793 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
72794 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
72795 IF(PMDI.LT.PMD) THEN
72796 PMD=PMDI
72797 IM=I
72798 ENDIF
72799 300 CONTINUE
72800
72801C...Loop back if significant reduction in sum of m^2.
72802 IF(PMD.LT.-PARU(48)*PMS) THEN
72803 PMS=PMS+PMD
72804 IS=K(IM,3)
72805 DO 310 J=1,4
72806 PS(IS,J)=PS(IS,J)-P(IM,J)
72807 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
72808 310 CONTINUE
72809 K(IM,3)=3-IS
72810 GOTO 280
72811 ENDIF
72812
72813C...Final masses and output.
72814 MSTU(61)=N+1
72815 MSTU(62)=NP
72816 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
72817 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
72818 PMH=MAX(PS(1,5),PS(2,5))
72819 PML=MIN(PS(1,5),PS(2,5))
72820
72821 RETURN
72822 END
72823
72824C*********************************************************************
72825
72826C...PYFOWO
72827C...Calculates the first few Fox-Wolfram moments.
72828
72829 SUBROUTINE PYFOWO(H10,H20,H30,H40)
72830
72831C...Double precision and integer declarations.
72832 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72833 IMPLICIT INTEGER(I-N)
72834 INTEGER PYK,PYCHGE,PYCOMP
72835C...Parameter statement to help give large particle numbers.
72836 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72837 &KEXCIT=4000000,KDIMEN=5000000)
72838C...Commonblocks.
72839 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72842 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
72843
72844C...Copy momenta for particles and calculate H0.
72845 NP=0
72846 H0=0D0
72847 HD=0D0
72848 DO 110 I=1,N
72849 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
72850 IF(MSTU(41).GE.2) THEN
72851 KC=PYCOMP(K(I,2))
72852 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72853 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72854 & K(I,2).EQ.KSUSY1+39) GOTO 110
72855 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
72856 & GOTO 110
72857 ENDIF
72858 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
72859 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
72860 H10=-1D0
72861 H20=-1D0
72862 H30=-1D0
72863 H40=-1D0
72864 RETURN
72865 ENDIF
72866 NP=NP+1
72867 DO 100 J=1,3
72868 P(N+NP,J)=P(I,J)
72869 100 CONTINUE
72870 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
72871 H0=H0+P(N+NP,4)
72872 HD=HD+P(N+NP,4)**2
72873 110 CONTINUE
72874 H0=H0**2
72875
72876C...Very low multiplicities (0 or 1) not considered.
72877 IF(NP.LE.1) THEN
72878 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
72879 H10=-1D0
72880 H20=-1D0
72881 H30=-1D0
72882 H40=-1D0
72883 RETURN
72884 ENDIF
72885
72886C...Calculate H1 - H4.
72887 H10=0D0
72888 H20=0D0
72889 H30=0D0
72890 H40=0D0
72891 DO 130 I1=N+1,N+NP
72892 DO 120 I2=I1+1,N+NP
72893 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
72894 & (P(I1,4)*P(I2,4))
72895 H10=H10+P(I1,4)*P(I2,4)*CTHE
72896 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
72897 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
72898 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
72899 & 0.375D0)
72900 120 CONTINUE
72901 130 CONTINUE
72902
72903C...Calculate H1/H0 - H4/H0. Output.
72904 MSTU(61)=N+1
72905 MSTU(62)=NP
72906 H10=(HD+2D0*H10)/H0
72907 H20=(HD+2D0*H20)/H0
72908 H30=(HD+2D0*H30)/H0
72909 H40=(HD+2D0*H40)/H0
72910
72911 RETURN
72912 END
72913
72914C*********************************************************************
72915
72916C...PYTABU
72917C...Evaluates various properties of an event, with statistics
72918C...accumulated during the course of the run and
72919C...printed at the end.
72920
72921 SUBROUTINE PYTABU(MTABU)
72922
72923C...Double precision and integer declarations.
72924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72925 IMPLICIT INTEGER(I-N)
72926 INTEGER PYK,PYCHGE,PYCOMP
72927C...Parameter statement to help give large particle numbers.
72928 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72929 &KEXCIT=4000000,KDIMEN=5000000)
72930C...Commonblocks.
72931 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72932 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72933 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72934 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
72935 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
72936C...Local arrays, character variables, saved variables and data.
72937 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
72938 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
72939 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
72940 &KFDM(8),KFDC(200,0:8),NPDC(200)
72941 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
72942 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
72943 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
72944 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
72945 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
72946 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
72947 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
72948 &NEVDC/0/,NKFDC/0/,NREDC/0/
72949
72950C...Reset statistics on initial parton state.
72951 IF(MTABU.EQ.10) THEN
72952 NEVIS=0
72953 NKFIS=0
72954
72955C...Identify and order flavour content of initial state.
72956 ELSEIF(MTABU.EQ.11) THEN
72957 NEVIS=NEVIS+1
72958 KFM1=2*IABS(MSTU(161))
72959 IF(MSTU(161).GT.0) KFM1=KFM1-1
72960 KFM2=2*IABS(MSTU(162))
72961 IF(MSTU(162).GT.0) KFM2=KFM2-1
72962 KFMN=MIN(KFM1,KFM2)
72963 KFMX=MAX(KFM1,KFM2)
72964 DO 100 I=1,NKFIS
72965 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
72966 IKFIS=-I
72967 GOTO 110
72968 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
72969 & KFMX.LT.KFIS(I,2))) THEN
72970 IKFIS=I
72971 GOTO 110
72972 ENDIF
72973 100 CONTINUE
72974 IKFIS=NKFIS+1
72975 110 IF(IKFIS.LT.0) THEN
72976 IKFIS=-IKFIS
72977 ELSE
72978 IF(NKFIS.GE.100) RETURN
72979 DO 130 I=NKFIS,IKFIS,-1
72980 KFIS(I+1,1)=KFIS(I,1)
72981 KFIS(I+1,2)=KFIS(I,2)
72982 DO 120 J=0,10
72983 NPIS(I+1,J)=NPIS(I,J)
72984 120 CONTINUE
72985 130 CONTINUE
72986 NKFIS=NKFIS+1
72987 KFIS(IKFIS,1)=KFMN
72988 KFIS(IKFIS,2)=KFMX
72989 DO 140 J=0,10
72990 NPIS(IKFIS,J)=0
72991 140 CONTINUE
72992 ENDIF
72993 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
72994
72995C...Count number of partons in initial state.
72996 NP=0
72997 DO 160 I=1,N
72998 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
72999 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
73000 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
73001 & THEN
73002 ELSE
73003 IM=I
73004 150 IM=K(IM,3)
73005 IF(IM.LE.0.OR.IM.GT.N) THEN
73006 NP=NP+1
73007 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73008 NP=NP+1
73009 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
73010 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
73011 & .NE.0) THEN
73012 ELSE
73013 GOTO 150
73014 ENDIF
73015 ENDIF
73016 160 CONTINUE
73017 NPCO=MAX(NP,1)
73018 IF(NP.GE.6) NPCO=6
73019 IF(NP.GE.8) NPCO=7
73020 IF(NP.GE.11) NPCO=8
73021 IF(NP.GE.16) NPCO=9
73022 IF(NP.GE.26) NPCO=10
73023 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
73024 MSTU(62)=NP
73025
73026C...Write statistics on initial parton state.
73027 ELSEIF(MTABU.EQ.12) THEN
73028 FAC=1D0/MAX(1,NEVIS)
73029 WRITE(MSTU(11),5000) NEVIS
73030 DO 170 I=1,NKFIS
73031 KFMN=KFIS(I,1)
73032 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73033 KFM1=(KFMN+1)/2
73034 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73035 CALL PYNAME(KFM1,CHAU)
73036 CHIS(1)=CHAU(1:12)
73037 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
73038 KFMX=KFIS(I,2)
73039 IF(KFIS(I,1).EQ.0) KFMX=0
73040 KFM2=(KFMX+1)/2
73041 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73042 CALL PYNAME(KFM2,CHAU)
73043 CHIS(2)=CHAU(1:12)
73044 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
73045 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
73046 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
73047 170 CONTINUE
73048
73049C...Copy statistics on initial parton state into /PYJETS/.
73050 ELSEIF(MTABU.EQ.13) THEN
73051 FAC=1D0/MAX(1,NEVIS)
73052 DO 190 I=1,NKFIS
73053 KFMN=KFIS(I,1)
73054 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
73055 KFM1=(KFMN+1)/2
73056 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
73057 KFMX=KFIS(I,2)
73058 IF(KFIS(I,1).EQ.0) KFMX=0
73059 KFM2=(KFMX+1)/2
73060 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
73061 K(I,1)=32
73062 K(I,2)=99
73063 K(I,3)=KFM1
73064 K(I,4)=KFM2
73065 K(I,5)=NPIS(I,0)
73066 DO 180 J=1,5
73067 P(I,J)=FAC*NPIS(I,J)
73068 V(I,J)=FAC*NPIS(I,J+5)
73069 180 CONTINUE
73070 190 CONTINUE
73071 N=NKFIS
73072 DO 200 J=1,5
73073 K(N+1,J)=0
73074 P(N+1,J)=0D0
73075 V(N+1,J)=0D0
73076 200 CONTINUE
73077 K(N+1,1)=32
73078 K(N+1,2)=99
73079 K(N+1,5)=NEVIS
73080 MSTU(3)=1
73081
73082C...Reset statistics on number of particles/partons.
73083 ELSEIF(MTABU.EQ.20) THEN
73084 NEVFS=0
73085 NPRFS=0
73086 NFIFS=0
73087 NCHFS=0
73088 NKFFS=0
73089
73090C...Identify whether particle/parton is primary or not.
73091 ELSEIF(MTABU.EQ.21) THEN
73092 NEVFS=NEVFS+1
73093 MSTU(62)=0
73094 DO 260 I=1,N
73095 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
73096 MSTU(62)=MSTU(62)+1
73097 KC=PYCOMP(K(I,2))
73098 MPRI=0
73099 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
73100 MPRI=1
73101 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
73102 MPRI=1
73103 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
73104 MPRI=1
73105 ELSEIF(KC.EQ.0) THEN
73106 ELSEIF(K(K(I,3),1).EQ.13) THEN
73107 IM=K(K(I,3),3)
73108 IF(IM.LE.0.OR.IM.GT.N) THEN
73109 MPRI=1
73110 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
73111 MPRI=1
73112 ENDIF
73113 ELSEIF(KCHG(KC,2).EQ.0) THEN
73114 KCM=PYCOMP(K(K(I,3),2))
73115 IF(KCM.NE.0) THEN
73116 IF(KCHG(KCM,2).NE.0) MPRI=1
73117 ENDIF
73118 ENDIF
73119 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
73120 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
73121 ENDIF
73122 IF(K(I,1).LE.10) THEN
73123 NFIFS=NFIFS+1
73124 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
73125 ENDIF
73126
73127C...Fill statistics on number of particles/partons in event.
73128 KFA=IABS(K(I,2))
73129 KFS=3-ISIGN(1,K(I,2))-MPRI
73130 DO 210 IP=1,NKFFS
73131 IF(KFA.EQ.KFFS(IP)) THEN
73132 IKFFS=-IP
73133 GOTO 220
73134 ELSEIF(KFA.LT.KFFS(IP)) THEN
73135 IKFFS=IP
73136 GOTO 220
73137 ENDIF
73138 210 CONTINUE
73139 IKFFS=NKFFS+1
73140 220 IF(IKFFS.LT.0) THEN
73141 IKFFS=-IKFFS
73142 ELSE
73143 IF(NKFFS.GE.400) RETURN
73144 DO 240 IP=NKFFS,IKFFS,-1
73145 KFFS(IP+1)=KFFS(IP)
73146 DO 230 J=1,4
73147 NPFS(IP+1,J)=NPFS(IP,J)
73148 230 CONTINUE
73149 240 CONTINUE
73150 NKFFS=NKFFS+1
73151 KFFS(IKFFS)=KFA
73152 DO 250 J=1,4
73153 NPFS(IKFFS,J)=0
73154 250 CONTINUE
73155 ENDIF
73156 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
73157 260 CONTINUE
73158
73159C...Write statistics on particle/parton composition of events.
73160 ELSEIF(MTABU.EQ.22) THEN
73161 FAC=1D0/MAX(1,NEVFS)
73162 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
73163 DO 270 I=1,NKFFS
73164 CALL PYNAME(KFFS(I),CHAU)
73165 KC=PYCOMP(KFFS(I))
73166 MDCYF=0
73167 IF(KC.NE.0) MDCYF=MDCY(KC,1)
73168 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
73169 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
73170 270 CONTINUE
73171
73172C...Copy particle/parton composition information into /PYJETS/.
73173 ELSEIF(MTABU.EQ.23) THEN
73174 FAC=1D0/MAX(1,NEVFS)
73175 DO 290 I=1,NKFFS
73176 K(I,1)=32
73177 K(I,2)=99
73178 K(I,3)=KFFS(I)
73179 K(I,4)=0
73180 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
73181 DO 280 J=1,4
73182 P(I,J)=FAC*NPFS(I,J)
73183 V(I,J)=0D0
73184 280 CONTINUE
73185 P(I,5)=FAC*K(I,5)
73186 V(I,5)=0D0
73187 290 CONTINUE
73188 N=NKFFS
73189 DO 300 J=1,5
73190 K(N+1,J)=0
73191 P(N+1,J)=0D0
73192 V(N+1,J)=0D0
73193 300 CONTINUE
73194 K(N+1,1)=32
73195 K(N+1,2)=99
73196 K(N+1,5)=NEVFS
73197 P(N+1,1)=FAC*NPRFS
73198 P(N+1,2)=FAC*NFIFS
73199 P(N+1,3)=FAC*NCHFS
73200 MSTU(3)=1
73201
73202C...Reset factorial moments statistics.
73203 ELSEIF(MTABU.EQ.30) THEN
73204 NEVFM=0
73205 NMUFM=0
73206 DO 330 IM=1,3
73207 DO 320 IB=1,10
73208 DO 310 IP=1,4
73209 FM1FM(IM,IB,IP)=0D0
73210 FM2FM(IM,IB,IP)=0D0
73211 310 CONTINUE
73212 320 CONTINUE
73213 330 CONTINUE
73214
73215C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
73216 ELSEIF(MTABU.EQ.31) THEN
73217 NEVFM=NEVFM+1
73218 NLOW=N+MSTU(3)
73219 NUPP=NLOW
73220 DO 410 I=1,N
73221 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
73222 IF(MSTU(41).GE.2) THEN
73223 KC=PYCOMP(K(I,2))
73224 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73225 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73226 & K(I,2).EQ.KSUSY1+39) GOTO 410
73227 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73228 & PYCHGE(K(I,2)).EQ.0) GOTO 410
73229 ENDIF
73230 PMR=0D0
73231 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73232 IF(MSTU(42).GE.2) PMR=P(I,5)
73233 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
73234 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
73235 & 1D20)),P(I,3))
73236 IF(ABS(YETA).GT.PARU(57)) GOTO 410
73237 PHI=PYANGL(P(I,1),P(I,2))
73238 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
73239 IYETA=MAX(0,MIN(511,IYETA))
73240 IPHI=512D0*(PHI+PARU(1))/PARU(2)
73241 IPHI=MAX(0,MIN(511,IPHI))
73242 IYEP=0
73243 DO 340 IB=0,9
73244 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
73245 340 CONTINUE
73246
73247C...Order particles in (pseudo)rapidity and/or azimuth.
73248 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73249 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73250 RETURN
73251 ENDIF
73252 NUPP=NUPP+1
73253 IF(NUPP.EQ.NLOW+1) THEN
73254 K(NUPP,1)=IYETA
73255 K(NUPP,2)=IPHI
73256 K(NUPP,3)=IYEP
73257 ELSE
73258 DO 350 I1=NUPP-1,NLOW+1,-1
73259 IF(IYETA.GE.K(I1,1)) GOTO 360
73260 K(I1+1,1)=K(I1,1)
73261 350 CONTINUE
73262 360 K(I1+1,1)=IYETA
73263 DO 370 I1=NUPP-1,NLOW+1,-1
73264 IF(IPHI.GE.K(I1,2)) GOTO 380
73265 K(I1+1,2)=K(I1,2)
73266 370 CONTINUE
73267 380 K(I1+1,2)=IPHI
73268 DO 390 I1=NUPP-1,NLOW+1,-1
73269 IF(IYEP.GE.K(I1,3)) GOTO 400
73270 K(I1+1,3)=K(I1,3)
73271 390 CONTINUE
73272 400 K(I1+1,3)=IYEP
73273 ENDIF
73274 410 CONTINUE
73275 K(NUPP+1,1)=2**10
73276 K(NUPP+1,2)=2**10
73277 K(NUPP+1,3)=4**10
73278
73279C...Calculate sum of factorial moments in event.
73280 DO 480 IM=1,3
73281 DO 430 IB=1,10
73282 DO 420 IP=1,4
73283 FEVFM(IB,IP)=0D0
73284 420 CONTINUE
73285 430 CONTINUE
73286 DO 450 IB=1,10
73287 IF(IM.LE.2) IBIN=2**(10-IB)
73288 IF(IM.EQ.3) IBIN=4**(10-IB)
73289 IAGR=K(NLOW+1,IM)/IBIN
73290 NAGR=1
73291 DO 440 I=NLOW+2,NUPP+1
73292 ICUT=K(I,IM)/IBIN
73293 IF(ICUT.EQ.IAGR) THEN
73294 NAGR=NAGR+1
73295 ELSE
73296 IF(NAGR.EQ.1) THEN
73297 ELSEIF(NAGR.EQ.2) THEN
73298 FEVFM(IB,1)=FEVFM(IB,1)+2D0
73299 ELSEIF(NAGR.EQ.3) THEN
73300 FEVFM(IB,1)=FEVFM(IB,1)+6D0
73301 FEVFM(IB,2)=FEVFM(IB,2)+6D0
73302 ELSEIF(NAGR.EQ.4) THEN
73303 FEVFM(IB,1)=FEVFM(IB,1)+12D0
73304 FEVFM(IB,2)=FEVFM(IB,2)+24D0
73305 FEVFM(IB,3)=FEVFM(IB,3)+24D0
73306 ELSE
73307 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
73308 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
73309 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73310 & (NAGR-3D0)
73311 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
73312 & (NAGR-3D0)*(NAGR-4D0)
73313 ENDIF
73314 IAGR=ICUT
73315 NAGR=1
73316 ENDIF
73317 440 CONTINUE
73318 450 CONTINUE
73319
73320C...Add results to total statistics.
73321 DO 470 IB=10,1,-1
73322 DO 460 IP=1,4
73323 IF(FEVFM(1,IP).LT.0.5D0) THEN
73324 FEVFM(IB,IP)=0D0
73325 ELSEIF(IM.LE.2) THEN
73326 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73327 ELSE
73328 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
73329 ENDIF
73330 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
73331 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
73332 460 CONTINUE
73333 470 CONTINUE
73334 480 CONTINUE
73335 NMUFM=NMUFM+(NUPP-NLOW)
73336 MSTU(62)=NUPP-NLOW
73337
73338C...Write accumulated statistics on factorial moments.
73339 ELSEIF(MTABU.EQ.32) THEN
73340 FAC=1D0/MAX(1,NEVFM)
73341 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
73342 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
73343 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
73344 DO 510 IM=1,3
73345 WRITE(MSTU(11),5500)
73346 DO 500 IB=1,10
73347 BYETA=2D0*PARU(57)
73348 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
73349 BPHI=PARU(2)
73350 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
73351 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
73352 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
73353 DO 490 IP=1,4
73354 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
73355 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73356 & FMOMA(IP)**2)))
73357 490 CONTINUE
73358 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
73359 & IP=1,4)
73360 500 CONTINUE
73361 510 CONTINUE
73362
73363C...Copy statistics on factorial moments into /PYJETS/.
73364 ELSEIF(MTABU.EQ.33) THEN
73365 FAC=1D0/MAX(1,NEVFM)
73366 DO 540 IM=1,3
73367 DO 530 IB=1,10
73368 I=10*(IM-1)+IB
73369 K(I,1)=32
73370 K(I,2)=99
73371 K(I,3)=1
73372 IF(IM.NE.2) K(I,3)=2**(IB-1)
73373 K(I,4)=1
73374 IF(IM.NE.1) K(I,4)=2**(IB-1)
73375 K(I,5)=0
73376 P(I,1)=2D0*PARU(57)/K(I,3)
73377 V(I,1)=PARU(2)/K(I,4)
73378 DO 520 IP=1,4
73379 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
73380 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
73381 & P(I,IP+1)**2)))
73382 520 CONTINUE
73383 530 CONTINUE
73384 540 CONTINUE
73385 N=30
73386 DO 550 J=1,5
73387 K(N+1,J)=0
73388 P(N+1,J)=0D0
73389 V(N+1,J)=0D0
73390 550 CONTINUE
73391 K(N+1,1)=32
73392 K(N+1,2)=99
73393 K(N+1,5)=NEVFM
73394 MSTU(3)=1
73395
73396C...Reset statistics on Energy-Energy Correlation.
73397 ELSEIF(MTABU.EQ.40) THEN
73398 NEVEE=0
73399 DO 560 J=1,25
73400 FE1EC(J)=0D0
73401 FE2EC(J)=0D0
73402 FE1EC(51-J)=0D0
73403 FE2EC(51-J)=0D0
73404 FE1EA(J)=0D0
73405 FE2EA(J)=0D0
73406 560 CONTINUE
73407
73408C...Find particles to include, with proper assumed mass.
73409 ELSEIF(MTABU.EQ.41) THEN
73410 NEVEE=NEVEE+1
73411 NLOW=N+MSTU(3)
73412 NUPP=NLOW
73413 ECM=0D0
73414 DO 570 I=1,N
73415 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
73416 IF(MSTU(41).GE.2) THEN
73417 KC=PYCOMP(K(I,2))
73418 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73419 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73420 & K(I,2).EQ.KSUSY1+39) GOTO 570
73421 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
73422 & PYCHGE(K(I,2)).EQ.0) GOTO 570
73423 ENDIF
73424 PMR=0D0
73425 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
73426 IF(MSTU(42).GE.2) PMR=P(I,5)
73427 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
73428 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
73429 RETURN
73430 ENDIF
73431 NUPP=NUPP+1
73432 P(NUPP,1)=P(I,1)
73433 P(NUPP,2)=P(I,2)
73434 P(NUPP,3)=P(I,3)
73435 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73436 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
73437 ECM=ECM+P(NUPP,4)
73438 570 CONTINUE
73439 IF(NUPP.EQ.NLOW) RETURN
73440
73441C...Analyze Energy-Energy Correlation in event.
73442 FAC=(2D0/ECM**2)*50D0/PARU(1)
73443 DO 580 J=1,50
73444 FEVEE(J)=0D0
73445 580 CONTINUE
73446 DO 600 I1=NLOW+2,NUPP
73447 DO 590 I2=NLOW+1,I1-1
73448 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
73449 & (P(I1,5)*P(I2,5))
73450 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
73451 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
73452 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
73453 590 CONTINUE
73454 600 CONTINUE
73455 DO 610 J=1,25
73456 FE1EC(J)=FE1EC(J)+FEVEE(J)
73457 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
73458 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
73459 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
73460 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
73461 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
73462 610 CONTINUE
73463 MSTU(62)=NUPP-NLOW
73464
73465C...Write statistics on Energy-Energy Correlation.
73466 ELSEIF(MTABU.EQ.42) THEN
73467 FAC=1D0/MAX(1,NEVEE)
73468 WRITE(MSTU(11),5700) NEVEE
73469 DO 620 J=1,25
73470 FEEC1=FAC*FE1EC(J)
73471 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
73472 FEEC2=FAC*FE1EC(51-J)
73473 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
73474 FEECA=FAC*FE1EA(J)
73475 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
73476 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
73477 & FEEC2,FEES2,FEECA,FEESA
73478 620 CONTINUE
73479
73480C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
73481 ELSEIF(MTABU.EQ.43) THEN
73482 FAC=1D0/MAX(1,NEVEE)
73483 DO 630 I=1,25
73484 K(I,1)=32
73485 K(I,2)=99
73486 K(I,3)=0
73487 K(I,4)=0
73488 K(I,5)=0
73489 P(I,1)=FAC*FE1EC(I)
73490 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
73491 P(I,2)=FAC*FE1EC(51-I)
73492 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
73493 P(I,3)=FAC*FE1EA(I)
73494 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
73495 P(I,4)=PARU(1)*(I-1)/50D0
73496 P(I,5)=PARU(1)*I/50D0
73497 V(I,4)=3.6D0*(I-1)
73498 V(I,5)=3.6D0*I
73499 630 CONTINUE
73500 N=25
73501 DO 640 J=1,5
73502 K(N+1,J)=0
73503 P(N+1,J)=0D0
73504 V(N+1,J)=0D0
73505 640 CONTINUE
73506 K(N+1,1)=32
73507 K(N+1,2)=99
73508 K(N+1,5)=NEVEE
73509 MSTU(3)=1
73510
73511C...Reset statistics on decay channels.
73512 ELSEIF(MTABU.EQ.50) THEN
73513 NEVDC=0
73514 NKFDC=0
73515 NREDC=0
73516
73517C...Identify and order flavour content of final state.
73518 ELSEIF(MTABU.EQ.51) THEN
73519 NEVDC=NEVDC+1
73520 NDS=0
73521 DO 670 I=1,N
73522 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
73523 NDS=NDS+1
73524 IF(NDS.GT.8) THEN
73525 NREDC=NREDC+1
73526 RETURN
73527 ENDIF
73528 KFM=2*IABS(K(I,2))
73529 IF(K(I,2).LT.0) KFM=KFM-1
73530 DO 650 IDS=NDS-1,1,-1
73531 IIN=IDS+1
73532 IF(KFM.LT.KFDM(IDS)) GOTO 660
73533 KFDM(IDS+1)=KFDM(IDS)
73534 650 CONTINUE
73535 IIN=1
73536 660 KFDM(IIN)=KFM
73537 670 CONTINUE
73538
73539C...Find whether old or new final state.
73540 DO 690 IDC=1,NKFDC
73541 IF(NDS.LT.KFDC(IDC,0)) THEN
73542 IKFDC=IDC
73543 GOTO 700
73544 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
73545 DO 680 I=1,NDS
73546 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
73547 IKFDC=IDC
73548 GOTO 700
73549 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
73550 GOTO 690
73551 ENDIF
73552 680 CONTINUE
73553 IKFDC=-IDC
73554 GOTO 700
73555 ENDIF
73556 690 CONTINUE
73557 IKFDC=NKFDC+1
73558 700 IF(IKFDC.LT.0) THEN
73559 IKFDC=-IKFDC
73560 ELSEIF(NKFDC.GE.200) THEN
73561 NREDC=NREDC+1
73562 RETURN
73563 ELSE
73564 DO 720 IDC=NKFDC,IKFDC,-1
73565 NPDC(IDC+1)=NPDC(IDC)
73566 DO 710 I=0,8
73567 KFDC(IDC+1,I)=KFDC(IDC,I)
73568 710 CONTINUE
73569 720 CONTINUE
73570 NKFDC=NKFDC+1
73571 KFDC(IKFDC,0)=NDS
73572 DO 730 I=1,NDS
73573 KFDC(IKFDC,I)=KFDM(I)
73574 730 CONTINUE
73575 NPDC(IKFDC)=0
73576 ENDIF
73577 NPDC(IKFDC)=NPDC(IKFDC)+1
73578
73579C...Write statistics on decay channels.
73580 ELSEIF(MTABU.EQ.52) THEN
73581 FAC=1D0/MAX(1,NEVDC)
73582 WRITE(MSTU(11),5900) NEVDC
73583 DO 750 IDC=1,NKFDC
73584 DO 740 I=1,KFDC(IDC,0)
73585 KFM=KFDC(IDC,I)
73586 KF=(KFM+1)/2
73587 IF(2*KF.NE.KFM) KF=-KF
73588 CALL PYNAME(KF,CHAU)
73589 CHDC(I)=CHAU(1:12)
73590 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
73591 740 CONTINUE
73592 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
73593 750 CONTINUE
73594 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
73595
73596C...Copy statistics on decay channels into /PYJETS/.
73597 ELSEIF(MTABU.EQ.53) THEN
73598 FAC=1D0/MAX(1,NEVDC)
73599 DO 780 IDC=1,NKFDC
73600 K(IDC,1)=32
73601 K(IDC,2)=99
73602 K(IDC,3)=0
73603 K(IDC,4)=0
73604 K(IDC,5)=KFDC(IDC,0)
73605 DO 760 J=1,5
73606 P(IDC,J)=0D0
73607 V(IDC,J)=0D0
73608 760 CONTINUE
73609 DO 770 I=1,KFDC(IDC,0)
73610 KFM=KFDC(IDC,I)
73611 KF=(KFM+1)/2
73612 IF(2*KF.NE.KFM) KF=-KF
73613 IF(I.LE.5) P(IDC,I)=KF
73614 IF(I.GE.6) V(IDC,I-5)=KF
73615 770 CONTINUE
73616 V(IDC,5)=FAC*NPDC(IDC)
73617 780 CONTINUE
73618 N=NKFDC
73619 DO 790 J=1,5
73620 K(N+1,J)=0
73621 P(N+1,J)=0D0
73622 V(N+1,J)=0D0
73623 790 CONTINUE
73624 K(N+1,1)=32
73625 K(N+1,2)=99
73626 K(N+1,5)=NEVDC
73627 V(N+1,5)=FAC*NREDC
73628 MSTU(3)=1
73629 ENDIF
73630
73631C...Format statements for output on unit MSTU(11) (default 6).
73632 5000 FORMAT(///20X,'Event statistics - initial state'/
73633 &20X,'based on an analysis of ',I6,' events'//
73634 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
73635 &'according to fragmenting system multiplicity'/
73636 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
73637 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
73638 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
73639 5200 FORMAT(///20X,'Event statistics - final state'/
73640 &20X,'based on an analysis of ',I7,' events'//
73641 &5X,'Mean primary multiplicity =',F10.4/
73642 &5X,'Mean final multiplicity =',F10.4/
73643 &5X,'Mean charged multiplicity =',F10.4//
73644 &5X,'Number of particles produced per event (directly and via ',
73645 &'decays/branchings)'/
73646 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
73647 &8X,'Total'/35X,'prim seco prim seco'/)
73648 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
73649 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
73650 &20X,'based on an analysis of ',I6,' events'//
73651 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
73652 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
73653 5500 FORMAT(10X)
73654 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
73655 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
73656 &20X,'based on an analysis of ',I6,' events'//
73657 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
73658 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
73659 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
73660 5900 FORMAT(///20X,'Decay channel analysis - final state'/
73661 &20X,'based on an analysis of ',I6,' events'//
73662 &2X,'Probability',10X,'Complete final state'/)
73663 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
73664 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
73665 &'or table overflow)')
73666
73667 RETURN
73668 END
73669
73670C*********************************************************************
73671
73672C...PYEEVT
73673C...Handles the generation of an e+e- annihilation jet event.
73674
73675 SUBROUTINE PYEEVT(KFL,ECM)
73676
73677C...Double precision and integer declarations.
73678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73679 IMPLICIT INTEGER(I-N)
73680 INTEGER PYK,PYCHGE,PYCOMP
73681C...Commonblocks.
73682 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73683 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73684 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73685 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
73686
73687C...Check input parameters.
73688 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73689 IF(KFL.LT.0.OR.KFL.GT.8) THEN
73690 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
73691 IF(MSTU(21).GE.1) RETURN
73692 ENDIF
73693 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
73694 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
73695 IF(ECM.LT.ECMMIN) THEN
73696 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
73697 IF(MSTU(21).GE.1) RETURN
73698 ENDIF
73699
73700C...Check consistency of MSTJ options set.
73701 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
73702 CALL PYERRM(6,
73703 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
73704 MSTJ(110)=1
73705 ENDIF
73706 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
73707 CALL PYERRM(6,
73708 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
73709 MSTJ(111)=0
73710 ENDIF
73711
73712C...Initialize alpha_strong and total cross-section.
73713 MSTU(111)=MSTJ(108)
73714 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
73715 &MSTU(111)=1
73716 PARU(112)=PARJ(121)
73717 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
73718 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
73719 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
73720 &XTOT)
73721 IF(MSTJ(116).GE.3) MSTJ(116)=1
73722 PARJ(171)=0D0
73723
73724C...Add initial e+e- to event record (documentation only).
73725 NTRY=0
73726 100 NTRY=NTRY+1
73727 IF(NTRY.GT.100) THEN
73728 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
73729 RETURN
73730 ENDIF
73731 MSTU(24)=0
73732 NC=0
73733 IF(MSTJ(115).GE.2) THEN
73734 NC=NC+2
73735 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
73736 K(NC-1,1)=21
73737 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
73738 K(NC,1)=21
73739 ENDIF
73740
73741C...Radiative photon (in initial state).
73742 MK=0
73743 ECMC=ECM
73744 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
73745 &THEK,PHIK,ALPK)
73746 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
73747 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
73748 NC=NC+1
73749 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
73750 K(NC,3)=MIN(MSTJ(115)/2,1)
73751 ENDIF
73752
73753C...Virtual exchange boson (gamma or Z0).
73754 IF(MSTJ(115).GE.3) THEN
73755 NC=NC+1
73756 KF=22
73757 IF(MSTJ(102).EQ.2) KF=23
73758 MSTU10=MSTU(10)
73759 MSTU(10)=1
73760 P(NC,5)=ECMC
73761 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
73762 K(NC,1)=21
73763 K(NC,3)=1
73764 MSTU(10)=MSTU10
73765 ENDIF
73766
73767C...Choice of flavour and jet configuration.
73768 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
73769 IF(KFLC.EQ.0) GOTO 100
73770 CALL PYXJET(ECMC,NJET,CUT)
73771 KFLN=21
73772 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
73773 &X12,X14)
73774 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
73775 IF(NJET.EQ.2) MSTJ(120)=1
73776
73777C...Fill jet configuration and origin.
73778 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
73779 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
73780 &ECMC)
73781 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
73782 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
73783 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73784 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
73785 &-KFLC,ECMC,X1,X2,X4,X12,X14)
73786 IF(MSTU(24).NE.0) GOTO 100
73787 DO 110 IP=NC+1,N
73788 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
73789 110 CONTINUE
73790
73791C...Angular orientation according to matrix element.
73792 IF(MSTJ(106).EQ.1) THEN
73793 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
73794 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
73795 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
73796 ENDIF
73797
73798C...Rotation and boost from radiative photon.
73799 IF(MK.EQ.1) THEN
73800 DBEK=-PAK/(ECM-PAK)
73801 NMIN=NC+1-MSTJ(115)/3
73802 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
73803 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
73804 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
73805 ENDIF
73806
73807C...Generate parton shower. Rearrange along strings and check.
73808 IF(MSTJ(101).EQ.5) THEN
73809 CALL PYSHOW(N-1,N,ECMC)
73810 MSTJ14=MSTJ(14)
73811 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
73812 IF(MSTJ(105).GE.0) MSTU(28)=0
73813 CALL PYPREP(0)
73814 MSTJ(14)=MSTJ14
73815 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
73816 ENDIF
73817
73818C...Fragmentation/decay generation. Information for PYTABU.
73819 IF(MSTJ(105).EQ.1) CALL PYEXEC
73820 MSTU(161)=KFLC
73821 MSTU(162)=-KFLC
73822
73823 RETURN
73824 END
73825
73826C*********************************************************************
73827
73828C...PYXTEE
73829C...Calculates total cross-section, including initial state
73830C...radiation effects.
73831
73832 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
73833
73834C...Double precision and integer declarations.
73835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73836 IMPLICIT INTEGER(I-N)
73837 INTEGER PYK,PYCHGE,PYCOMP
73838C...Commonblocks.
73839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73841 SAVE /PYDAT1/,/PYDAT2/
73842
73843C...Status, (optimized) Q^2 scale, alpha_strong.
73844 PARJ(151)=ECM
73845 MSTJ(119)=10*MSTJ(102)+KFL
73846 IF(MSTJ(111).EQ.0) THEN
73847 Q2R=ECM**2
73848 ELSEIF(MSTU(111).EQ.0) THEN
73849 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
73850 & ((33D0-2D0*MSTU(112))*PARU(111)))))
73851 Q2R=PARJ(168)*ECM**2
73852 ELSE
73853 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
73854 & (2D0*PARU(112)/ECM)**2))
73855 Q2R=PARJ(168)*ECM**2
73856 ENDIF
73857 ALSPI=PYALPS(Q2R)/PARU(1)
73858
73859C...QCD corrections factor in R.
73860 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
73861 RQCD=1D0
73862 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
73863 RQCD=1D0+ALSPI
73864 ELSEIF(MSTJ(109).EQ.0) THEN
73865 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
73866 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
73867 & LOG(PARJ(168))*ALSPI**2)
73868 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
73869 RQCD=1D0+(3D0/4D0)*ALSPI
73870 ELSE
73871 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
73872 ENDIF
73873
73874C...Calculate Z0 width if default value not acceptable.
73875 IF(MSTJ(102).GE.3) THEN
73876 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
73877 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
73878 DO 100 KFLC=5,6
73879 VQ=1D0
73880 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
73881 & (2D0*PYMASS(KFLC)/ ECM)**2))
73882 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
73883 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
73884 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
73885 100 CONTINUE
73886 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
73887 & (1D0-PARU(102)))
73888 ENDIF
73889
73890C...Calculate propagator and related constants for QFD case.
73891 POLL=1D0-PARJ(131)*PARJ(132)
73892 IF(MSTJ(102).GE.2) THEN
73893 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
73894 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
73895 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
73896 VE=4D0*PARU(102)-1D0
73897 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
73898 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
73899 HF1I=SFI*SF1I
73900 HF1W=SFW*SF1W
73901 ENDIF
73902
73903C...Loop over different flavours: charge, velocity.
73904 RTOT=0D0
73905 RQQ=0D0
73906 RQV=0D0
73907 RVA=0D0
73908 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
73909 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
73910 MSTJ(93)=1
73911 PMQ=PYMASS(KFLC)
73912 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
73913 QF=KCHG(KFLC,1)/3D0
73914 VQ=1D0
73915 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
73916
73917C...Calculate R and sum of charges for QED or QFD case.
73918 RQQ=RQQ+3D0*QF**2*POLL
73919 IF(MSTJ(102).LE.1) THEN
73920 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
73921 ELSE
73922 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
73923 RQV=RQV-6D0*QF*VF*SF1I
73924 RVA=RVA+3D0*(VF**2+1D0)*SF1W
73925 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
73926 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
73927 ENDIF
73928 110 CONTINUE
73929 RSUM=RQQ
73930 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
73931
73932C...Calculate cross-section, including QCD corrections.
73933 PARJ(141)=RQQ
73934 PARJ(142)=RTOT
73935 PARJ(143)=RTOT*RQCD
73936 PARJ(144)=PARJ(143)
73937 PARJ(145)=PARJ(141)*86.8D0/ECM**2
73938 PARJ(146)=PARJ(142)*86.8D0/ECM**2
73939 PARJ(147)=PARJ(143)*86.8D0/ECM**2
73940 PARJ(148)=PARJ(147)
73941 PARJ(157)=RSUM*RQCD
73942 PARJ(158)=0D0
73943 PARJ(159)=0D0
73944 XTOT=PARJ(147)
73945 IF(MSTJ(107).LE.0) RETURN
73946
73947C...Virtual cross-section.
73948 XKL=PARJ(135)
73949 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
73950 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
73951 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
73952 &1.526D0*LOG(ECM**2/0.932D0)
73953
73954C...Soft and hard radiative cross-section in QED case.
73955 IF(MSTJ(102).LE.1) THEN
73956 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
73957 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
73958 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
73959
73960C...Soft and hard radiative cross-section in QFD case.
73961 ELSE
73962 SZM=1D0-(PARJ(123)/ECM)**2
73963 SZW=PARJ(123)*PARJ(124)/ECM**2
73964 PARJ(161)=-RQQ/RSUM
73965 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
73966 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
73967 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
73968 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
73969 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
73970 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
73971 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
73972 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
73973 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
73974 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
73975 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
73976 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
73977 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
73978 ENDIF
73979
73980C...Total cross-section and fraction of hard photon events.
73981 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
73982 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
73983 PARJ(144)=PARJ(157)
73984 PARJ(148)=PARJ(144)*86.8D0/ECM**2
73985 XTOT=PARJ(148)
73986
73987 RETURN
73988 END
73989
73990C*********************************************************************
73991
73992C...PYRADK
73993C...Generates initial state photon radiation.
73994
73995 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
73996
73997C...Double precision and integer declarations.
73998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73999 IMPLICIT INTEGER(I-N)
74000 INTEGER PYK,PYCHGE,PYCOMP
74001C...Commonblocks.
74002 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74003 SAVE /PYDAT1/
74004
74005C...Function: cumulative hard photon spectrum in QFD case.
74006 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
74007 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
74008
74009C...Determine whether radiative photon or not.
74010 MK=0
74011 PAK=0D0
74012 IF(PARJ(160).LT.PYR(0)) RETURN
74013 MK=1
74014
74015C...Photon energy range. Find photon momentum in QED case.
74016 XKL=PARJ(135)
74017 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
74018 IF(MSTJ(102).LE.1) THEN
74019 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
74020 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
74021
74022C...Ditto in QFD case, by numerical inversion of integrated spectrum.
74023 ELSE
74024 SZM=1D0-(PARJ(123)/ECM)**2
74025 SZW=PARJ(123)*PARJ(124)/ECM**2
74026 FXKL=FXK(XKL)
74027 FXKU=FXK(XKU)
74028 FXKD=1D-4*(FXKU-FXKL)
74029 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
74030 NXK=0
74031 110 NXK=NXK+1
74032 XK=0.5D0*(XKL+XKU)
74033 FXKV=FXK(XK)
74034 IF(FXKV.GT.FXKR) THEN
74035 XKU=XK
74036 FXKU=FXKV
74037 ELSE
74038 XKL=XK
74039 FXKL=FXKV
74040 ENDIF
74041 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
74042 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
74043 ENDIF
74044 PAK=0.5D0*ECM*XK
74045
74046C...Photon polar and azimuthal angle.
74047 PME=2D0*(PYMASS(11)/ECM)**2
74048 120 CTHM=PME*(2D0/PME)**PYR(0)
74049 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
74050 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
74051 CTHE=1D0-CTHM
74052 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
74053 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
74054 THEK=PYANGL(CTHE,STHE)
74055 PHIK=PARU(2)*PYR(0)
74056
74057C...Rotation angle for hadronic system.
74058 SGN=1D0
74059 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
74060 &PYR(0)) SGN=-1D0
74061 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
74062 &(2D0-XK*(1D0-SGN*CTHE)))
74063
74064 RETURN
74065 END
74066
74067C*********************************************************************
74068
74069C...PYXKFL
74070C...Selects flavour for produced qqbar pair.
74071
74072 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
74073
74074C...Double precision and integer declarations.
74075 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74076 IMPLICIT INTEGER(I-N)
74077 INTEGER PYK,PYCHGE,PYCOMP
74078C...Commonblocks.
74079 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74080 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74081 SAVE /PYDAT1/,/PYDAT2/
74082
74083C...Calculate maximum weight in QED or QFD case.
74084 IF(MSTJ(102).LE.1) THEN
74085 RFMAX=4D0/9D0
74086 ELSE
74087 POLL=1D0-PARJ(131)*PARJ(132)
74088 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74089 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74090 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
74091 VE=4D0*PARU(102)-1D0
74092 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
74093 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
74094 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
74095 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
74096 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
74097 & 1D0)*HF1W)
74098 ENDIF
74099
74100C...Choose flavour. Gives charge and velocity.
74101 NTRY=0
74102 100 NTRY=NTRY+1
74103 IF(NTRY.GT.100) THEN
74104 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
74105 KFLC=0
74106 RETURN
74107 ENDIF
74108 KFLC=KFL
74109 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
74110 MSTJ(93)=1
74111 PMQ=PYMASS(KFLC)
74112 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
74113 QF=KCHG(KFLC,1)/3D0
74114 VQ=1D0
74115 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
74116
74117C...Calculate weight in QED or QFD case.
74118 IF(MSTJ(102).LE.1) THEN
74119 RF=QF**2
74120 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
74121 ELSE
74122 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
74123 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
74124 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
74125 & VQ**3*HF1W
74126 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
74127 ENDIF
74128
74129C...Weighting or new event (radiative photon). Cross-section update.
74130 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
74131 PARJ(158)=PARJ(158)+1D0
74132 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
74133 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
74134 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
74135 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
74136 PARJ(148)=PARJ(144)*86.8D0/ECM**2
74137
74138 RETURN
74139 END
74140
74141C*********************************************************************
74142
74143C...PYXJET
74144C...Selects number of jets in matrix element approach.
74145
74146 SUBROUTINE PYXJET(ECM,NJET,CUT)
74147
74148C...Double precision and integer declarations.
74149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74150 IMPLICIT INTEGER(I-N)
74151 INTEGER PYK,PYCHGE,PYCOMP
74152C...Commonblocks.
74153 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74154 SAVE /PYDAT1/
74155C...Local array and data.
74156 DIMENSION ZHUT(5)
74157 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
74158
74159C...Trivial result for two-jets only, including parton shower.
74160 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74161 CUT=0D0
74162
74163C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
74164 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
74165 CF=4D0/3D0
74166 IF(MSTJ(109).EQ.2) CF=1D0
74167 IF(MSTJ(111).EQ.0) THEN
74168 Q2=ECM**2
74169 Q2R=ECM**2
74170 ELSEIF(MSTU(111).EQ.0) THEN
74171 PARJ(169)=MIN(1D0,PARJ(129))
74172 Q2=PARJ(169)*ECM**2
74173 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
74174 & ((33D0-2D0*MSTU(112))*PARU(111)))))
74175 Q2R=PARJ(168)*ECM**2
74176 ELSE
74177 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
74178 Q2=PARJ(169)*ECM**2
74179 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
74180 & (2D0*PARU(112)/ECM)**2))
74181 Q2R=PARJ(168)*ECM**2
74182 ENDIF
74183
74184C...alpha_strong for R and R itself.
74185 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
74186 IF(IABS(MSTJ(101)).EQ.1) THEN
74187 RQCD=1D0+ALSPI
74188 ELSEIF(MSTJ(109).EQ.0) THEN
74189 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
74190 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
74191 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
74192 ELSE
74193 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
74194 ENDIF
74195
74196C...alpha_strong for jet rate. Initial value for y cut.
74197 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74198 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
74199 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
74200 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
74201 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74202
74203C...Parametrization of first order three-jet cross-section.
74204 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
74205 PARJ(152)=0D0
74206 ELSE
74207 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
74208 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
74209 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
74210 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
74211 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
74212 & PARJ(152)=0D0
74213 ENDIF
74214
74215C...Parametrization of second order three-jet cross-section.
74216 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
74217 & CUT.GE.0.25D0) THEN
74218 PARJ(153)=0D0
74219 ELSEIF(MSTJ(110).LE.1) THEN
74220 CT=LOG(1D0/CUT-2D0)
74221 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
74222 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
74223
74224C...Interpolation in second/first order ratio for Zhu parametrization.
74225 ELSEIF(MSTJ(110).EQ.2) THEN
74226 IZA=0
74227 DO 110 IY=1,5
74228 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74229 110 CONTINUE
74230 IF(IZA.NE.0) THEN
74231 ZHURAT=ZHUT(IZA)
74232 ELSE
74233 IZ=100D0*CUT
74234 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
74235 ENDIF
74236 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
74237 ENDIF
74238
74239C...Shift in second order three-jet cross-section with optimized Q^2.
74240 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
74241 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
74242 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
74243
74244C...Parametrization of second order four-jet cross-section.
74245 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
74246 PARJ(154)=0D0
74247 ELSE
74248 CT=LOG(1D0/CUT-5D0)
74249 IF(CUT.LE.0.018D0) THEN
74250 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
74251 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
74252 & 0.4059D0*CT**2)
74253 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
74254 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74255 ELSE
74256 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
74257 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
74258 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
74259 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
74260 & 0.002093D0*CT**3)
74261 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
74262 ENDIF
74263 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
74264 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
74265 ENDIF
74266
74267C...If negative three-jet rate, change y' optimization parameter.
74268 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
74269 & PARJ(169).LT.0.99D0) THEN
74270 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74271 Q2=PARJ(169)*ECM**2
74272 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74273 GOTO 100
74274 ENDIF
74275
74276C...If too high cross-section, use harder cuts, or fail.
74277 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
74278 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
74279 & PARJ(169).LT.0.99D0) THEN
74280 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
74281 Q2=PARJ(169)*ECM**2
74282 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
74283 GOTO 100
74284 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
74285 CALL PYERRM(26,
74286 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
74287 ENDIF
74288 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
74289 & PARJ(154))**(-1D0/3D0)
74290 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
74291 GOTO 100
74292 ENDIF
74293
74294C...Scalar gluon (first order only).
74295 ELSE
74296 ALSPI=PYALPS(ECM**2)/PARU(1)
74297 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
74298 PARJ(152)=0D0
74299 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
74300 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
74301 PARJ(153)=0D0
74302 PARJ(154)=0D0
74303 ENDIF
74304
74305C...Select number of jets.
74306 PARJ(150)=CUT
74307 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
74308 NJET=2
74309 ELSEIF(MSTJ(101).LE.0) THEN
74310 NJET=MIN(4,2-MSTJ(101))
74311 ELSE
74312 RNJ=PYR(0)
74313 NJET=2
74314 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
74315 IF(PARJ(154).GT.RNJ) NJET=4
74316 ENDIF
74317
74318 RETURN
74319 END
74320
74321C*********************************************************************
74322
74323C...PYX3JT
74324C...Selects the kinematical variables of three-jet events.
74325
74326 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
74327
74328C...Double precision and integer declarations.
74329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74330 IMPLICIT INTEGER(I-N)
74331 INTEGER PYK,PYCHGE,PYCOMP
74332C...Commonblocks.
74333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74334 SAVE /PYDAT1/
74335C...Local array.
74336 DIMENSION ZHUP(5,12)
74337
74338C...Coefficients of Zhu second order parametrization.
74339 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
74340 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
74341 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
74342 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
74343 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
74344 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
74345 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
74346 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
74347 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
74348 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
74349 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
74350
74351C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
74352 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
74353 &X**7/49D0
74354
74355C...Event type. Mass effect factors and other common constants.
74356 MSTJ(120)=2
74357 MSTJ(121)=0
74358 PMQ=PYMASS(KFL)
74359 QME=(2D0*PMQ/ECM)**2
74360 IF(MSTJ(109).NE.1) THEN
74361 CUTL=LOG(CUT)
74362 CUTD=LOG(1D0/CUT-2D0)
74363 IF(MSTJ(109).EQ.0) THEN
74364 CF=4D0/3D0
74365 CN=3D0
74366 TR=2D0
74367 WTMX=MIN(20D0,37D0-6D0*CUTD)
74368 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
74369 ELSE
74370 CF=1D0
74371 CN=0D0
74372 TR=12D0
74373 WTMX=0D0
74374 ENDIF
74375
74376C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
74377 ALS2PI=PARU(118)/PARU(2)
74378 WTOPT=0D0
74379 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
74380 & LOG(PARJ(169))*ALS2PI
74381 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
74382
74383C...Choose three-jet events in allowed region.
74384 100 NJET=3
74385 110 Y13L=CUTL+CUTD*PYR(0)
74386 Y23L=CUTL+CUTD*PYR(0)
74387 Y13=EXP(Y13L)
74388 Y23=EXP(Y23L)
74389 Y12=1D0-Y13-Y23
74390 IF(Y12.LE.CUT) GOTO 110
74391 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
74392
74393C...Second order corrections.
74394 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
74395 Y12L=LOG(Y12)
74396 Y13M=LOG(1D0-Y13)
74397 Y23M=LOG(1D0-Y23)
74398 Y12M=LOG(1D0-Y12)
74399 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
74400 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
74401 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
74402 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
74403 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
74404 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
74405 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
74406 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
74407 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
74408 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
74409 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
74410 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
74411 & TR*(2D0*CUTL/3D0-10D0/9D0)+
74412 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
74413 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
74414 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
74415 & Y13*Y23)/(Y12+Y13)**2)/WT1+
74416 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
74417 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
74418 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
74419 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
74420 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
74421 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
74422 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
74423 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74424 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74425 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
74426
74427 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
74428C...Second order corrections; Zhu parametrization of ERT.
74429 ZX=(Y23-Y13)**2
74430 ZY=1D0-Y12
74431 IZA=0
74432 DO 120 IY=1,5
74433 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
74434 120 CONTINUE
74435 IF(IZA.NE.0) THEN
74436 IZ=IZA
74437 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74438 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74439 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74440 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74441 ELSE
74442 IZ=100D0*CUT
74443 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74444 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74445 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74446 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74447 IZ=IZ+1
74448 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
74449 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
74450 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
74451 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
74452 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
74453 ENDIF
74454 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
74455 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
74456 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
74457 ENDIF
74458
74459C...Impose mass cuts (gives two jets). For fixed jet number new try.
74460 X1=1D0-Y23
74461 X2=1D0-Y13
74462 X3=1D0-Y12
74463 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
74464 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
74465 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
74466 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
74467 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
74468
74469C...Scalar gluon model (first order only, no mass effects).
74470 ELSE
74471 130 NJET=3
74472 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
74473 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
74474 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
74475 X1=1D0-0.5D0*(X3+YD)
74476 X2=1D0-0.5D0*(X3-YD)
74477 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
74478 IF(MSTJ(102).GE.2) THEN
74479 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
74480 & X3**2*PYR(0)) NJET=2
74481 ENDIF
74482 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
74483 ENDIF
74484
74485 RETURN
74486 END
74487
74488C*********************************************************************
74489
74490C...PYX4JT
74491C...Selects the kinematical variables of four-jet events.
74492
74493 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
74494
74495C...Double precision and integer declarations.
74496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74497 IMPLICIT INTEGER(I-N)
74498 INTEGER PYK,PYCHGE,PYCOMP
74499C...Commonblocks.
74500 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74501 SAVE /PYDAT1/
74502C...Local arrays.
74503 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
74504
74505C...Common constants. Colour factors for QCD and Abelian gluon theory.
74506 PMQ=PYMASS(KFL)
74507 QME=(2D0*PMQ/ECM)**2
74508 CT=LOG(1D0/CUT-5D0)
74509 IF(MSTJ(109).EQ.0) THEN
74510 CF=4D0/3D0
74511 CN=3D0
74512 TR=2.5D0
74513 ELSE
74514 CF=1D0
74515 CN=0D0
74516 TR=15D0
74517 ENDIF
74518
74519C...Choice of process (qqbargg or qqbarqqbar).
74520 100 NJET=4
74521 IT=1
74522 IF(PARJ(155).GT.PYR(0)) IT=2
74523 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
74524 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
74525 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
74526 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
74527 ID=1
74528
74529C...Sample the five kinematical variables (for qqgg preweighted in y34).
74530 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74531 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
74532 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
74533 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
74534 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
74535 VT=PYR(0)
74536 CP=COS(PARU(1)*PYR(0))
74537 Y14=(Y134-Y34)*VT
74538 Y13=Y134-Y14-Y34
74539 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
74540 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
74541 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
74542 Y23=Y234-Y34-Y24
74543 Y12=1D0-Y134-Y23-Y24
74544 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
74545 Y123=Y12+Y13+Y23
74546 Y124=Y12+Y14+Y24
74547
74548C...Calculate matrix elements for qqgg or qqqq process.
74549 IC=0
74550 WTTOT=0D0
74551 120 IC=IC+1
74552 IF(IT.EQ.1) THEN
74553 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
74554 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
74555 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
74556 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
74557 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
74558 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
74559 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
74560 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
74561 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
74562 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
74563 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
74564 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
74565 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
74566 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
74567 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
74568 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
74569 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
74570 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
74571 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
74572 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
74573 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
74574 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
74575 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
74576 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
74577 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
74578 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
74579 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
74580 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
74581 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
74582 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
74583 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
74584 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
74585 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
74586 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
74587 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
74588 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
74589 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
74590 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
74591 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
74592 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
74593 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
74594 & CN*WTC(IC))/8D0
74595 ELSE
74596 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
74597 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
74598 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
74599 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
74600 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
74601 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
74602 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
74603 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
74604 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
74605 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
74606 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
74607 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
74608 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
74609 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
74610 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
74611 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
74612 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
74613 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
74614 ENDIF
74615
74616C...Permutations of momenta in matrix element. Weighting.
74617 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
74618 YSAV=Y13
74619 Y13=Y14
74620 Y14=YSAV
74621 YSAV=Y23
74622 Y23=Y24
74623 Y24=YSAV
74624 YSAV=Y123
74625 Y123=Y124
74626 Y124=YSAV
74627 ENDIF
74628 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
74629 YSAV=Y13
74630 Y13=Y23
74631 Y23=YSAV
74632 YSAV=Y14
74633 Y14=Y24
74634 Y24=YSAV
74635 YSAV=Y134
74636 Y134=Y234
74637 Y234=YSAV
74638 ENDIF
74639 IF(IC.LE.3) GOTO 120
74640 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
74641 IC=5
74642
74643C...qqgg events: string configuration and event type.
74644 IF(IT.EQ.1) THEN
74645 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
74646 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
74647 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
74648 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
74649 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
74650 IF(ID.EQ.2) GOTO 130
74651 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
74652 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
74653 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
74654 IF(ID.EQ.2) GOTO 130
74655 ENDIF
74656 MSTJ(120)=3
74657 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
74658 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
74659 KFLN=21
74660
74661C...Mass cuts. Kinematical variables out.
74662 IF(Y12.LE.CUT+QME) NJET=2
74663 IF(NJET.EQ.2) GOTO 150
74664 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
74665 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
74666 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
74667 X2=1D0-Y124
74668 X12=(1D0-Q12)*Y13+Q12*Y23
74669 X14=Y12-0.5D0*QME
74670 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74671
74672C...qqbarqqbar events: string configuration, choose new flavour.
74673 ELSE
74674 IF(ID.EQ.1) THEN
74675 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
74676 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
74677 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
74678 IF(WTR.LT.WTD(4)) ID=4
74679 IF(ID.GE.2) GOTO 130
74680 ENDIF
74681 MSTJ(120)=5
74682 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
74683 140 KFLN=1+INT(5D0*PYR(0))
74684 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
74685 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
74686 IF(KFLN.GT.MSTJ(104)) NJET=2
74687 PMQN=PYMASS(KFLN)
74688 QMEN=(2D0*PMQN/ECM)**2
74689
74690C...Mass cuts. Kinematical variables out.
74691 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
74692 IF(NJET.EQ.2) GOTO 150
74693 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
74694 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
74695 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
74696 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
74697 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
74698 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
74699 & Q13*Y23)
74700 X14=Y24-0.5D0*QME
74701 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
74702 & Q13*Y14)
74703 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
74704 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
74705 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
74706 ENDIF
74707 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
74708
74709 RETURN
74710 END
74711
74712C*********************************************************************
74713
74714C...PYXDIF
74715C...Gives the angular orientation of events.
74716
74717 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
74718
74719C...Double precision and integer declarations.
74720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74721 IMPLICIT INTEGER(I-N)
74722 INTEGER PYK,PYCHGE,PYCOMP
74723C...Commonblocks.
74724 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74726 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74727 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74728
74729C...Charge. Factors depending on polarization for QED case.
74730 QF=KCHG(KFL,1)/3D0
74731 POLL=1D0-PARJ(131)*PARJ(132)
74732 POLD=PARJ(132)-PARJ(131)
74733 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
74734 HF1=POLL
74735 HF2=0D0
74736 HF3=PARJ(133)**2
74737 HF4=0D0
74738
74739C...Factors depending on flavour, energy and polarization for QFD case.
74740 ELSE
74741 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
74742 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
74743 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
74744 AE=-1D0
74745 VE=4D0*PARU(102)-1D0
74746 AF=SIGN(1D0,QF)
74747 VF=AF-4D0*QF*PARU(102)
74748 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
74749 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
74750 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
74751 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
74752 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
74753 & SFW*SFF**2*(VE**2-AE**2))
74754 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
74755 & SFF*AE
74756 ENDIF
74757
74758C...Mass factor. Differential cross-sections for two-jet events.
74759 SQ2=SQRT(2D0)
74760 QME=0D0
74761 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
74762 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
74763 IF(NJET.EQ.2) THEN
74764 SIGU=4D0*SQRT(1D0-QME)
74765 SIGL=2D0*QME*SQRT(1D0-QME)
74766 SIGT=0D0
74767 SIGI=0D0
74768 SIGA=0D0
74769 SIGP=4D0
74770
74771C...Kinematical variables. Reduce four-jet event to three-jet one.
74772 ELSE
74773 IF(NJET.EQ.3) THEN
74774 X1=2D0*P(NC+1,4)/ECM
74775 X2=2D0*P(NC+3,4)/ECM
74776 ELSE
74777 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
74778 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
74779 X1=2D0*P(NC+1,4)/ECMR
74780 X2=2D0*P(NC+4,4)/ECMR
74781 ENDIF
74782
74783C...Differential cross-sections for three-jet (or reduced four-jet).
74784 XQ=(1D0-X1)/(1D0-X2)
74785 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
74786 ST12=SQRT(1D0-CT12**2)
74787 IF(MSTJ(109).NE.1) THEN
74788 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
74789 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
74790 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
74791 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
74792 & X2)*XQ
74793 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
74794 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
74795 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
74796 SIGA=X2**2*ST12/SQ2
74797 SIGP=2D0*(X1**2-X2**2*CT12)
74798
74799C...Differential cross-sect for scalar gluons (no mass effects).
74800 ELSE
74801 X3=2D0-X1-X2
74802 XT=X2*ST12
74803 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
74804 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
74805 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
74806 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
74807 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
74808 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
74809 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
74810 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
74811 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
74812 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
74813 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
74814 ENDIF
74815 ENDIF
74816
74817C...Upper bounds for differential cross-section.
74818 HF1A=ABS(HF1)
74819 HF2A=ABS(HF2)
74820 HF3A=ABS(HF3)
74821 HF4A=ABS(HF4)
74822 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
74823 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
74824 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
74825 &2D0*HF2A*ABS(SIGP)
74826
74827C...Generate angular orientation according to differential cross-sect.
74828 100 CHI=PARU(2)*PYR(0)
74829 CTHE=2D0*PYR(0)-1D0
74830 PHI=PARU(2)*PYR(0)
74831 CCHI=COS(CHI)
74832 SCHI=SIN(CHI)
74833 C2CHI=COS(2D0*CHI)
74834 S2CHI=SIN(2D0*CHI)
74835 THE=ACOS(CTHE)
74836 STHE=SIN(THE)
74837 C2PHI=COS(2D0*(PHI-PARJ(134)))
74838 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74839 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
74840 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
74841 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
74842 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
74843 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
74844 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
74845 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
74846 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
74847
74848 RETURN
74849 END
74850
74851C*********************************************************************
74852
74853C...PYONIA
74854C...Generates Upsilon and toponium decays into three gluons
74855C...or two gluons and a photon.
74856
74857 SUBROUTINE PYONIA(KFL,ECM)
74858
74859C...Double precision and integer declarations.
74860 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74861 IMPLICIT INTEGER(I-N)
74862 INTEGER PYK,PYCHGE,PYCOMP
74863C...Commonblocks.
74864 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74865 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74866 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74867 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74868
74869C...Printout. Check input parameters.
74870 IF(MSTU(12).NE.12345) CALL PYLIST(0)
74871 IF(KFL.LT.0.OR.KFL.GT.8) THEN
74872 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
74873 IF(MSTU(21).GE.1) RETURN
74874 ENDIF
74875 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
74876 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
74877 IF(MSTU(21).GE.1) RETURN
74878 ENDIF
74879
74880C...Initial e+e- and onium state (optional).
74881 NC=0
74882 IF(MSTJ(115).GE.2) THEN
74883 NC=NC+2
74884 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
74885 K(NC-1,1)=21
74886 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
74887 K(NC,1)=21
74888 ENDIF
74889 KFLC=IABS(KFL)
74890 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
74891 NC=NC+1
74892 KF=110*KFLC+3
74893 MSTU10=MSTU(10)
74894 MSTU(10)=1
74895 P(NC,5)=ECM
74896 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
74897 K(NC,1)=21
74898 K(NC,3)=1
74899 MSTU(10)=MSTU10
74900 ENDIF
74901
74902C...Choose x1 and x2 according to matrix element.
74903 NTRY=0
74904 100 X1=PYR(0)
74905 X2=PYR(0)
74906 X3=2D0-X1-X2
74907 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
74908 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
74909 NTRY=NTRY+1
74910 NJET=3
74911 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
74912 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
74913
74914C...Photon-gluon-gluon events. Small system modifications. Jet origin.
74915 MSTU(111)=MSTJ(108)
74916 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
74917 &MSTU(111)=1
74918 PARU(112)=PARJ(121)
74919 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
74920 QF=0D0
74921 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
74922 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
74923 MK=0
74924 ECMC=ECM
74925 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
74926 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
74927 & NJET=2
74928 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
74929 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
74930 ELSE
74931 MK=1
74932 ECMC=SQRT(1D0-X1)*ECM
74933 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
74934 K(NC+1,1)=1
74935 K(NC+1,2)=22
74936 K(NC+1,4)=0
74937 K(NC+1,5)=0
74938 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
74939 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
74940 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
74941 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
74942 NJET=2
74943 IF(ECMC.LT.4D0*PARJ(127)) THEN
74944 MSTU10=MSTU(10)
74945 MSTU(10)=1
74946 P(NC+2,5)=ECMC
74947 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
74948 MSTU(10)=MSTU10
74949 NJET=0
74950 ENDIF
74951 ENDIF
74952 DO 110 IP=NC+1,N
74953 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
74954 110 CONTINUE
74955
74956C...Differential cross-sections. Upper limit for cross-section.
74957 IF(MSTJ(106).EQ.1) THEN
74958 SQ2=SQRT(2D0)
74959 HF1=1D0-PARJ(131)*PARJ(132)
74960 HF3=PARJ(133)**2
74961 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
74962 ST13=SQRT(1D0-CT13**2)
74963 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
74964 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
74965 SIGT=0.5D0*SIGL
74966 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
74967 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
74968 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
74969
74970C...Angular orientation of event.
74971 120 CHI=PARU(2)*PYR(0)
74972 CTHE=2D0*PYR(0)-1D0
74973 PHI=PARU(2)*PYR(0)
74974 CCHI=COS(CHI)
74975 SCHI=SIN(CHI)
74976 C2CHI=COS(2D0*CHI)
74977 S2CHI=SIN(2D0*CHI)
74978 THE=ACOS(CTHE)
74979 STHE=SIN(THE)
74980 C2PHI=COS(2D0*(PHI-PARJ(134)))
74981 S2PHI=SIN(2D0*(PHI-PARJ(134)))
74982 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
74983 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
74984 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
74985 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
74986 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
74987 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
74988 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
74989 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
74990 ENDIF
74991
74992C...Generate parton shower. Rearrange along strings and check.
74993 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
74994 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
74995 MSTJ14=MSTJ(14)
74996 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
74997 IF(MSTJ(105).GE.0) MSTU(28)=0
74998 CALL PYPREP(0)
74999 MSTJ(14)=MSTJ14
75000 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
75001 ENDIF
75002
75003C...Generate fragmentation. Information for PYTABU:
75004 IF(MSTJ(105).EQ.1) CALL PYEXEC
75005 MSTU(161)=110*KFLC+3
75006 MSTU(162)=0
75007
75008 RETURN
75009 END
75010
75011C*********************************************************************
75012
75013C...PYBOOK
75014C...Books a histogram.
75015
75016 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
75017
75018C...Double precision declaration.
75019 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75020 IMPLICIT INTEGER(I-N)
75021C...Commonblock.
75022 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75023 SAVE /PYBINS/
75024C...Local character variables.
75025 CHARACTER TITLE*(*), TITFX*60
75026
75027C...Check that input is sensible. Find initial address in memory.
75028 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75029 &'(PYBOOK:) not allowed histogram number')
75030 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
75031 &'(PYBOOK:) not allowed number of bins')
75032 IF(XL.GE.XU) CALL PYERRM(28,
75033 &'(PYBOOK:) x limits in wrong order')
75034 INDX(ID)=IHIST(4)
75035 IHIST(4)=IHIST(4)+28+NX
75036 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
75037 &'(PYBOOK:) out of histogram space')
75038 IS=INDX(ID)
75039
75040C...Store histogram size and reset contents.
75041 BIN(IS+1)=NX
75042 BIN(IS+2)=XL
75043 BIN(IS+3)=XU
75044 BIN(IS+4)=(XU-XL)/NX
75045 CALL PYNULL(ID)
75046
75047C...Store title by conversion to integer to double precision.
75048 TITFX=TITLE//' '
75049 DO 100 IT=1,20
75050 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
75051 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
75052 100 CONTINUE
75053
75054 RETURN
75055 END
75056
75057C*********************************************************************
75058
75059C...PYFILL
75060C...Fills entry in histogram.
75061
75062 SUBROUTINE PYFILL(ID,X,W)
75063
75064C...Double precision declaration.
75065 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75066 IMPLICIT INTEGER(I-N)
75067C...Commonblock.
75068 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75069 SAVE /PYBINS/
75070
75071C...Find initial address in memory. Increase number of entries.
75072 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75073 &'(PYFILL:) not allowed histogram number')
75074 IS=INDX(ID)
75075 IF(IS.EQ.0) CALL PYERRM(28,
75076 &'(PYFILL:) filling unbooked histogram')
75077 BIN(IS+5)=BIN(IS+5)+1D0
75078
75079C...Find bin in x, including under/overflow, and fill.
75080 IF(X.LT.BIN(IS+2)) THEN
75081 BIN(IS+6)=BIN(IS+6)+W
75082 ELSEIF(X.GE.BIN(IS+3)) THEN
75083 BIN(IS+8)=BIN(IS+8)+W
75084 ELSE
75085 BIN(IS+7)=BIN(IS+7)+W
75086 IX=(X-BIN(IS+2))/BIN(IS+4)
75087 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
75088 BIN(IS+9+IX)=BIN(IS+9+IX)+W
75089 ENDIF
75090
75091 RETURN
75092 END
75093
75094C*********************************************************************
75095
75096C...PYFACT
75097C...Multiplies histogram contents by factor.
75098
75099 SUBROUTINE PYFACT(ID,F)
75100
75101C...Double precision declaration.
75102 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75103 IMPLICIT INTEGER(I-N)
75104C...Commonblock.
75105 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75106 SAVE /PYBINS/
75107
75108C...Find initial address in memory. Multiply all contents bins.
75109 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
75110 &'(PYFACT:) not allowed histogram number')
75111 IS=INDX(ID)
75112 IF(IS.EQ.0) CALL PYERRM(28,
75113 &'(PYFACT:) scaling unbooked histogram')
75114 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
75115 BIN(IX)=F*BIN(IX)
75116 100 CONTINUE
75117
75118 RETURN
75119 END
75120
75121C*********************************************************************
75122
75123C...PYOPER
75124C...Performs operations between histograms.
75125
75126 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
75127
75128C...Double precision declaration.
75129 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75130 IMPLICIT INTEGER(I-N)
75131C...Commonblock.
75132 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75133 SAVE /PYBINS/
75134C...Character variable.
75135 CHARACTER OPER*(*)
75136
75137C...Find initial addresses in memory, and histogram size.
75138 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
75139 &'(PYFACT:) not allowed histogram number')
75140 IS1=INDX(ID1)
75141 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
75142 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
75143 NX=NINT(BIN(IS3+1))
75144 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
75145
75146C...Update info on number of histogram entries.
75147 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
75148 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
75149 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
75150 BIN(IS3+5)=BIN(IS1+5)
75151 ENDIF
75152
75153C...Operations on pair of histograms: addition, subtraction,
75154C...multiplication, division.
75155 IF(OPER.EQ.'+') THEN
75156 DO 100 IX=6,8+NX
75157 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
75158 100 CONTINUE
75159 ELSEIF(OPER.EQ.'-') THEN
75160 DO 110 IX=6,8+NX
75161 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
75162 110 CONTINUE
75163 ELSEIF(OPER.EQ.'*') THEN
75164 DO 120 IX=6,8+NX
75165 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
75166 120 CONTINUE
75167 ELSEIF(OPER.EQ.'/') THEN
75168 DO 130 IX=6,8+NX
75169 FA2=F2*BIN(IS2+IX)
75170 IF(ABS(FA2).LE.1D-20) THEN
75171 BIN(IS3+IX)=0D0
75172 ELSE
75173 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
75174 ENDIF
75175 130 CONTINUE
75176
75177C...Operations on single histogram: multiplication+addition,
75178C...square root+addition, logarithm+addition.
75179 ELSEIF(OPER.EQ.'A') THEN
75180 DO 140 IX=6,8+NX
75181 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
75182 140 CONTINUE
75183 ELSEIF(OPER.EQ.'S') THEN
75184 DO 150 IX=6,8+NX
75185 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
75186 150 CONTINUE
75187 ELSEIF(OPER.EQ.'L') THEN
75188 ZMIN=1D20
75189 DO 160 IX=9,8+NX
75190 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
75191 & ZMIN=0.8D0*BIN(IS1+IX)
75192 160 CONTINUE
75193 DO 170 IX=6,8+NX
75194 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
75195 170 CONTINUE
75196
75197C...Operation on two or three histograms: average and
75198C...standard deviation.
75199 ELSEIF(OPER.EQ.'M') THEN
75200 DO 180 IX=6,8+NX
75201 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75202 BIN(IS2+IX)=0D0
75203 ELSE
75204 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
75205 ENDIF
75206 IF(ID3.NE.0) THEN
75207 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
75208 BIN(IS3+IX)=0D0
75209 ELSE
75210 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
75211 & BIN(IS2+IX)**2))
75212 ENDIF
75213 ENDIF
75214 BIN(IS1+IX)=F1*BIN(IS1+IX)
75215 180 CONTINUE
75216 ENDIF
75217
75218 RETURN
75219 END
75220
75221C*********************************************************************
75222
75223C...PYHIST
75224C...Prints and resets all histograms.
75225
75226 SUBROUTINE PYHIST
75227
75228C...Double precision declaration.
75229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75230 IMPLICIT INTEGER(I-N)
75231C...Commonblock.
75232 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75233 SAVE /PYBINS/
75234
75235C...Loop over histograms, print and reset used ones.
75236 DO 100 ID=1,IHIST(1)
75237 IS=INDX(ID)
75238 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
75239 CALL PYPLOT(ID)
75240 CALL PYNULL(ID)
75241 ENDIF
75242 100 CONTINUE
75243
75244 RETURN
75245 END
75246
75247C*********************************************************************
75248
75249C...PYPLOT
75250C...Prints a histogram (but does not reset it).
75251
75252 SUBROUTINE PYPLOT(ID)
75253
75254C...Double precision declaration.
75255 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75256 IMPLICIT INTEGER(I-N)
75257C...Commonblocks.
75258 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75259 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75260 SAVE /PYDAT1/,/PYBINS/
75261C...Local arrays and character variables.
75262 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
75263 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
75264
75265C...Steps in histogram scale. Character sequence.
75266 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
75267 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
75268
75269C...Find initial address in memory; skip if empty histogram.
75270 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75271 IS=INDX(ID)
75272 IF(IS.EQ.0) RETURN
75273 IF(NINT(BIN(IS+5)).LE.0) THEN
75274 WRITE(MSTU(11),5000) ID
75275 RETURN
75276 ENDIF
75277
75278C...Number of histogram lines and x bins.
75279 LIN=IHIST(3)-18
75280 NX=NINT(BIN(IS+1))
75281
75282C...Extract title by conversion from double precision via integer.
75283 DO 100 IT=1,20
75284 IEQ=NINT(BIN(IS+8+NX+IT))
75285 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
75286 & //CHAR(MOD(IEQ,256))
75287 100 CONTINUE
75288
75289C...Find time; print title.
75290 CALL PYTIME(IDATI)
75291 IF(IDATI(1).GT.0) THEN
75292 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
75293 ELSE
75294 WRITE(MSTU(11),5200) ID, TITLE
75295 ENDIF
75296
75297C...Find minimum and maximum bin content.
75298 YMIN=BIN(IS+9)
75299 YMAX=BIN(IS+9)
75300 DO 110 IX=IS+10,IS+8+NX
75301 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
75302 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
75303 110 CONTINUE
75304
75305C...Determine scale and step size for y axis.
75306 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
75307 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
75308 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
75309 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
75310 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
75311 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
75312 DELY=DYAC(1)
75313 DO 120 IDEL=1,9
75314 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
75315 120 CONTINUE
75316 DY=DELY*10D0**IPOT
75317
75318C...Convert bin contents to integer form; fractional fill in top row.
75319 DO 130 IX=1,NX
75320 CTA=ABS(BIN(IS+8+IX))/DY
75321 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
75322 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
75323 130 CONTINUE
75324 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
75325 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
75326
75327C...Print histogram row by row.
75328 DO 150 IR=IRMA,IRMI,-1
75329 IF(IR.EQ.0) GOTO 150
75330 OUT=' '
75331 DO 140 IX=1,NX
75332 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
75333 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
75334 140 CONTINUE
75335 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
75336 150 CONTINUE
75337
75338C...Print sign and value of bin contents.
75339 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
75340 OUT=' '
75341 DO 160 IX=1,NX
75342 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
75343 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
75344 160 CONTINUE
75345 WRITE(MSTU(11),5400) OUT
75346 DO 180 IR=4,1,-1
75347 DO 170 IX=1,NX
75348 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75349 170 CONTINUE
75350 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
75351 180 CONTINUE
75352
75353C...Print sign and value of lower bin edge.
75354 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
75355 & 10.0001D0)-10
75356 OUT=' '
75357 DO 190 IX=1,NX
75358 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
75359 & OUT(IX:IX)=CHA(11)
75360 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
75361 190 CONTINUE
75362 WRITE(MSTU(11),5600) OUT
75363 DO 210 IR=3,1,-1
75364 DO 200 IX=1,NX
75365 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
75366 200 CONTINUE
75367 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
75368 210 CONTINUE
75369 ENDIF
75370
75371C...Calculate and print statistics.
75372 CSUM=0D0
75373 CXSUM=0D0
75374 CXXSUM=0D0
75375 DO 220 IX=1,NX
75376 CTA=ABS(BIN(IS+8+IX))
75377 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
75378 CSUM=CSUM+CTA
75379 CXSUM=CXSUM+CTA*X
75380 CXXSUM=CXXSUM+CTA*X**2
75381 220 CONTINUE
75382 XMEAN=CXSUM/MAX(CSUM,1D-20)
75383 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
75384 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
75385 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
75386
75387C...Formats for output.
75388 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
75389 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
75390 &I2,':',I2/)
75391 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
75392 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
75393 5400 FORMAT(/8X,'Contents',3X,A100)
75394 5500 FORMAT(9X,'*10**',I2,3X,A100)
75395 5600 FORMAT(/8X,'Low edge',3X,A100)
75396 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
75397 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
75398 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
75399
75400 RETURN
75401 END
75402
75403C*********************************************************************
75404
75405C...PYNULL
75406C...Resets bin contents of a histogram.
75407
75408 SUBROUTINE PYNULL(ID)
75409
75410C...Double precision declaration.
75411 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75412 IMPLICIT INTEGER(I-N)
75413C...Commonblock.
75414 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75415 SAVE /PYBINS/
75416
75417 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
75418 IS=INDX(ID)
75419 IF(IS.EQ.0) RETURN
75420 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
75421 BIN(IX)=0D0
75422 100 CONTINUE
75423
75424 RETURN
75425 END
75426
75427C*********************************************************************
75428
75429C...PYDUMP
75430C...Dumps histogram contents on file for reading by other program.
75431C...Can also read back own dump.
75432
75433 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
75434
75435C...Double precision declaration.
75436 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75437 IMPLICIT INTEGER(I-N)
75438C...Commonblock.
75439 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
75440 SAVE /PYBINS/
75441C...Local arrays and character variables.
75442 DIMENSION IHI(*),ISS(100),VAL(5)
75443 CHARACTER TITLE*60,FORMAT*13
75444
75445C...Dump all histograms that have been booked,
75446C...including titles and ranges, one after the other.
75447 IF(MDUMP.EQ.1) THEN
75448
75449C...Loop over histograms and find which are wanted and booked.
75450 IF(NHI.LE.0) THEN
75451 NW=IHIST(1)
75452 ELSE
75453 NW=NHI
75454 ENDIF
75455 DO 130 IW=1,NW
75456 IF(NHI.EQ.0) THEN
75457 ID=IW
75458 ELSE
75459 ID=IHI(IW)
75460 ENDIF
75461 IS=INDX(ID)
75462 IF(IS.NE.0) THEN
75463
75464C...Write title, histogram size, filling statistics.
75465 NX=NINT(BIN(IS+1))
75466 DO 100 IT=1,20
75467 IEQ=NINT(BIN(IS+8+NX+IT))
75468 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
75469 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
75470 100 CONTINUE
75471 WRITE(LFN,5100) ID,TITLE
75472 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
75473 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
75474 & BIN(IS+8)
75475
75476
75477C...Write histogram contents, in groups of five.
75478 DO 120 IXG=1,(NX+4)/5
75479 DO 110 IXV=1,5
75480 IX=5*IXG+IXV-5
75481 IF(IX.LE.NX) THEN
75482 VAL(IXV)=BIN(IS+8+IX)
75483 ELSE
75484 VAL(IXV)=0D0
75485 ENDIF
75486 110 CONTINUE
75487 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
75488 120 CONTINUE
75489
75490C...Go to next histogram; finish.
75491 ELSEIF(NHI.GT.0) THEN
75492 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75493 ENDIF
75494 130 CONTINUE
75495
75496C...Read back in histograms dumped MDUMP=1.
75497 ELSEIF(MDUMP.EQ.2) THEN
75498
75499C...Read histogram number, title and range, and book.
75500 140 READ(LFN,5100,END=170) ID,TITLE
75501 READ(LFN,5200) NX,XL,XU
75502 CALL PYBOOK(ID,TITLE,NX,XL,XU)
75503 IS=INDX(ID)
75504
75505C...Read filling statistics.
75506 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
75507 BIN(IS+5)=DBLE(NENTRY)
75508
75509C...Read histogram contents, in groups of five.
75510 DO 160 IXG=1,(NX+4)/5
75511 READ(LFN,5400) (VAL(IXV),IXV=1,5)
75512 DO 150 IXV=1,5
75513 IX=5*IXG+IXV-5
75514 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
75515 150 CONTINUE
75516 160 CONTINUE
75517
75518C...Go to next histogram; finish.
75519 GOTO 140
75520 170 CONTINUE
75521
75522C...Write histogram contents in column format,
75523C...convenient e.g. for GNUPLOT input.
75524 ELSEIF(MDUMP.EQ.3) THEN
75525
75526C...Find addresses to wanted histograms.
75527 NSS=0
75528 IF(NHI.LE.0) THEN
75529 NW=IHIST(1)
75530 ELSE
75531 NW=NHI
75532 ENDIF
75533 DO 180 IW=1,NW
75534 IF(NHI.EQ.0) THEN
75535 ID=IW
75536 ELSE
75537 ID=IHI(IW)
75538 ENDIF
75539 IS=INDX(ID)
75540 IF(IS.NE.0.AND.NSS.LT.100) THEN
75541 NSS=NSS+1
75542 ISS(NSS)=IS
75543 ELSEIF(NSS.GE.100) THEN
75544 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
75545 ELSEIF(NHI.GT.0) THEN
75546 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
75547 ENDIF
75548 180 CONTINUE
75549
75550C...Check that they have common number of x bins. Fix format.
75551 NX=NINT(BIN(ISS(1)+1))
75552 DO 190 IW=2,NSS
75553 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
75554 CALL PYERRM(8,'(PYDUMP:) different number of bins')
75555 RETURN
75556 ENDIF
75557 190 CONTINUE
75558 FORMAT='(1P,000E12.4)'
75559 WRITE(FORMAT(5:7),'(I3)') NSS+1
75560
75561C...Write histogram contents; first column x values.
75562 DO 200 IX=1,NX
75563 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
75564 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
75565 200 CONTINUE
75566
75567 ENDIF
75568
75569C...Formats for output.
75570 5100 FORMAT(I5,5X,A60)
75571 5200 FORMAT(I5,1P,2D12.4)
75572 5300 FORMAT(I12,1P,3D12.4)
75573 5400 FORMAT(1P,5D12.4)
75574
75575 RETURN
75576 END
75577
75578C*********************************************************************
75579
75580C...PYSTOP
75581C...Allows users to handle STOP statemens
75582
75583 SUBROUTINE PYSTOP(MCOD)
75584
75585C...Double precision and integer declarations.
75586 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75587 IMPLICIT INTEGER(I-N)
75588 INTEGER PYK,PYCHGE,PYCOMP
75589C...Commonblocks.
75590 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75591 SAVE /PYDAT1/
75592
75593
75594C...Write message, then stop
75595 WRITE(MSTU(11),5000) MCOD
75596 STOP
75597
75598
75599C...Formats for output.
75600 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
75601 RETURN
75602 END
75603
75604C*********************************************************************
75605
75606C...PYKCUT
75607C...Dummy routine, which the user can replace in order to make cuts on
75608C...the kinematics on the parton level before the matrix elements are
75609C...evaluated and the event is generated. The cross-section estimates
75610C...will automatically take these cuts into account, so the given
75611C...values are for the allowed phase space region only. MCUT=0 means
75612C...that the event has passed the cuts, MCUT=1 that it has failed.
75613
75614 SUBROUTINE PYKCUT(MCUT)
75615
75616C...Double precision and integer declarations.
75617 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75618 IMPLICIT INTEGER(I-N)
75619 INTEGER PYK,PYCHGE,PYCOMP
75620C...Commonblocks.
75621 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75622 COMMON/PYINT1/MINT(400),VINT(400)
75623 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75624 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75625
75626C...Set default value (accepting event) for MCUT.
75627 MCUT=0
75628
75629C...Read out subprocess number.
75630 ISUB=MINT(1)
75631 ISTSB=ISET(ISUB)
75632
75633C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75634 TAU=VINT(21)
75635 YST=VINT(22)
75636 CTH=0D0
75637 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75638 TAUP=0D0
75639 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75640
75641C...Calculate x_1, x_2, x_F.
75642 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
75643 X1=SQRT(TAU)*EXP(YST)
75644 X2=SQRT(TAU)*EXP(-YST)
75645 ELSE
75646 X1=SQRT(TAUP)*EXP(YST)
75647 X2=SQRT(TAUP)*EXP(-YST)
75648 ENDIF
75649 XF=X1-X2
75650
75651C...Calculate shat, that, uhat, p_T^2.
75652 SHAT=TAU*VINT(2)
75653 SQM3=VINT(63)
75654 SQM4=VINT(64)
75655 RM3=SQM3/SHAT
75656 RM4=SQM4/SHAT
75657 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
75658 RPTS=4D0*VINT(71)**2/SHAT
75659 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
75660 RM34=2D0*RM3*RM4
75661 RSQM=1D0+RM34
75662 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
75663 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
75664 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
75665 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
75666
75667C...Decisions by user to be put here.
75668
75669C...Stop program if this routine is ever called.
75670C...You should not copy these lines to your own routine.
75671 WRITE(MSTU(11),5000)
75672 CALL PYSTOP(6)
75673
75674C...Format for error printout.
75675 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
75676 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75677 &1X,'Execution stopped!')
75678
75679 RETURN
75680 END
75681
75682C*********************************************************************
75683
75684C...PYEVWT
75685C...Dummy routine, which the user can replace in order to multiply the
75686C...standard PYTHIA differential cross-section by a process- and
75687C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
75688C...to generation of weighted events, with weight 1/WTXS, while for
75689C...MSTP(142)=2 it corresponds to a modification of the underlying
75690C...physics.
75691
75692 SUBROUTINE PYEVWT(WTXS)
75693
75694C...Double precision and integer declarations.
75695 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75696 IMPLICIT INTEGER(I-N)
75697 INTEGER PYK,PYCHGE,PYCOMP
75698C...Commonblocks.
75699 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75700 COMMON/PYINT1/MINT(400),VINT(400)
75701 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
75702 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
75703
75704C...Set default weight for WTXS.
75705 WTXS=1D0
75706
75707C...Read out subprocess number.
75708 ISUB=MINT(1)
75709 ISTSB=ISET(ISUB)
75710
75711C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
75712 TAU=VINT(21)
75713 YST=VINT(22)
75714 CTH=0D0
75715 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
75716 TAUP=0D0
75717 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
75718
75719C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
75720 X1=VINT(41)
75721 X2=VINT(42)
75722 XF=X1-X2
75723 SHAT=VINT(44)
75724 THAT=VINT(45)
75725 UHAT=VINT(46)
75726 PT2=VINT(48)
75727
75728C...Modifications by user to be put here.
75729
75730C...Stop program if this routine is ever called.
75731C...You should not copy these lines to your own routine.
75732 WRITE(MSTU(11),5000)
75733 CALL PYSTOP(4)
75734
75735C...Format for error printout.
75736 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
75737 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
75738 &1X,'Execution stopped!')
75739
75740 RETURN
75741 END
75742
75743C*********************************************************************
75744
75745C...UPINIT
75746C...Dummy routine, to be replaced by a user implementing external
75747C...processes. Is supposed to fill the HEPRUP commonblock with info
75748C...on incoming beams and allowed processes.
75749
75750C...New example: handles a standard Les Houches Events File.
75751
75752 SUBROUTINE UPINIT
75753
75754C...Double precision and integer declarations.
75755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75756 IMPLICIT INTEGER(I-N)
75757
75758C...PYTHIA commonblock: only used to provide read unit MSTP(161).
75759 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75760 SAVE /PYPARS/
75761
75762C...User process initialization commonblock.
75763 INTEGER MAXPUP
75764 PARAMETER (MAXPUP=100)
75765 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75766 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75767 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75768 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75769 &LPRUP(MAXPUP)
75770 SAVE /HEPRUP/
75771
75772C...Lines to read in assumed never longer than 200 characters.
75773 PARAMETER (MAXLEN=200)
75774 CHARACTER*(MAXLEN) STRING
75775
75776C...Format for reading lines.
75777 CHARACTER*6 STRFMT
75778 STRFMT='(A000)'
75779 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75780
75781C...Loop until finds line beginning with "<init>" or "<init ".
75782 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
75783 IBEG=0
75784 110 IBEG=IBEG+1
75785C...Allow indentation.
75786 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
75787 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
75788 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
75789
75790C...Read first line of initialization info.
75791 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
75792 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75793
75794C...Read NPRUP subsequent lines with information on each process.
75795 DO 120 IPR=1,NPRUP
75796 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
75797 & XMAXUP(IPR),LPRUP(IPR)
75798 120 CONTINUE
75799 RETURN
75800
75801C...Error exit: give up if initalization does not work.
75802 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
75803 WRITE(*,*) ' Event generation will be stopped.'
75804 CALL PYSTOP(12)
75805
75806 RETURN
75807 END
75808
75809C...Old example: handles a simple Pythia 6.4 initialization file.
75810
75811c SUBROUTINE UPINIT
75812
75813C...Double precision and integer declarations.
75814c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75815c IMPLICIT INTEGER(I-N)
75816
75817C...Commonblocks.
75818c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75819c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75820c SAVE /PYDAT1/,/PYPARS/
75821
75822C...User process initialization commonblock.
75823c INTEGER MAXPUP
75824c PARAMETER (MAXPUP=100)
75825c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
75826c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
75827c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
75828c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
75829c &LPRUP(MAXPUP)
75830c SAVE /HEPRUP/
75831
75832C...Read info from file.
75833c IF(MSTP(161).GT.0) THEN
75834c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
75835c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
75836c DO 100 IPR=1,NPRUP
75837c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
75838c & XMAXUP(IPR),LPRUP(IPR)
75839c 100 CONTINUE
75840c RETURN
75841C...Error or prematurely reached end of file.
75842c 110 WRITE(MSTU(11),5000)
75843c STOP
75844
75845C...Else not implemented.
75846c ELSE
75847c WRITE(MSTU(11),5100)
75848c STOP
75849c ENDIF
75850
75851C...Format for error printout.
75852c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
75853c &1X,'Execution stopped!')
75854c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
75855c &1X,'Dummy routine in PYTHIA file called instead.'/
75856c &1X,'Execution stopped!')
75857
75858c RETURN
75859c END
75860
75861C*********************************************************************
75862
75863C...UPEVNT
75864C...Dummy routine, to be replaced by a user implementing external
75865C...processes. Depending on cross section model chosen, it either has
75866C...to generate a process of the type IDPRUP requested, or pick a type
75867C...itself and generate this event. The event is to be stored in the
75868C...HEPEUP commonblock, including (often) an event weight.
75869
75870C...New example: handles a standard Les Houches Events File.
75871
75872 SUBROUTINE UPEVNT
75873
75874C...Double precision and integer declarations.
75875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75876 IMPLICIT INTEGER(I-N)
75877
75878C...PYTHIA commonblock: only used to provide read unit MSTP(162).
75879 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75880 SAVE /PYPARS/
75881
75882C...User process event common block.
75883 INTEGER MAXNUP
75884 PARAMETER (MAXNUP=500)
75885 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75886 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75887 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75888 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75889 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75890 SAVE /HEPEUP/
75891
75892C...Lines to read in assumed never longer than 200 characters.
75893 PARAMETER (MAXLEN=200)
75894 CHARACTER*(MAXLEN) STRING
75895
75896C...Format for reading lines.
75897 CHARACTER*6 STRFMT
75898 STRFMT='(A000)'
75899 WRITE(STRFMT(3:5),'(I3)') MAXLEN
75900
75901C...Loop until finds line beginning with "<event>" or "<event ".
75902 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
75903 IBEG=0
75904 110 IBEG=IBEG+1
75905C...Allow indentation.
75906 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
75907 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
75908 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
75909
75910C...Read first line of event info.
75911 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
75912 &AQEDUP,AQCDUP
75913
75914C...Read NUP subsequent lines with information on each particle.
75915 DO 120 I=1,NUP
75916 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
75917 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75918 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75919 120 CONTINUE
75920 RETURN
75921
75922C...Error exit, typically when no more events.
75923 130 WRITE(*,*) ' Failed to read LHEF event information.'
75924 WRITE(*,*) ' Will assume end of file has been reached.'
75925 NUP=0
75926 MSTI(51)=1
75927
75928 RETURN
75929 END
75930
75931C...Old example: handles a simple Pythia 6.4 event file.
75932
75933c SUBROUTINE UPEVNT
75934
75935C...Double precision and integer declarations.
75936c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75937c IMPLICIT INTEGER(I-N)
75938
75939C...Commonblocks.
75940c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75941c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75942c SAVE /PYDAT1/,/PYPARS/
75943
75944C...User process event common block.
75945c INTEGER MAXNUP
75946c PARAMETER (MAXNUP=500)
75947c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
75948c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
75949c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
75950c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
75951c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
75952c SAVE /HEPEUP/
75953
75954C...Read info from file.
75955c IF(MSTP(162).GT.0) THEN
75956c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
75957c & AQEDUP,AQCDUP
75958c DO 100 I=1,NUP
75959c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
75960c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
75961c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
75962c 100 CONTINUE
75963c RETURN
75964C...Special when reached end of file or other error.
75965c 110 NUP=0
75966
75967C...Else not implemented.
75968c ELSE
75969c WRITE(MSTU(11),5000)
75970c STOP
75971c ENDIF
75972
75973C...Format for error printout.
75974c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
75975c &1X,'Dummy routine in PYTHIA file called instead.'/
75976c &1X,'Execution stopped!')
75977
75978c RETURN
75979c END
75980
75981C*********************************************************************
75982
75983C...UPVETO
75984C...Dummy routine, to be replaced by user, to veto event generation
75985C...on the parton level, after parton showers but before multiple
75986C...interactions, beam remnants and hadronization is added.
75987C...If resonances like W, Z, top, Higgs and SUSY particles are handed
75988C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
75989C...be undecayed at this stage; if decayed their decay products will
75990C...have been allowed to shower.
75991
75992C...All partons at the end of the shower phase are stored in the
75993C...HEPEVT commonblock. The interesting information is
75994C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
75995C...IDHEP(I) = the particle ID code according to PDG conventions,
75996C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
75997C...All ISTHEP entries are 1, while the rest is zeroed.
75998
75999C...The user decision is to be conveyed by the IVETO value.
76000C...IVETO = 0 : retain current event and generate in full;
76001C... = 1 : abort generation of current event and move to next.
76002
76003 SUBROUTINE UPVETO(IVETO)
76004
76005C...HEPEVT commonblock.
76006 PARAMETER (NMXHEP=4000)
76007 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
76008 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
76009 DOUBLE PRECISION PHEP,VHEP
76010 SAVE /HEPEVT/
76011
76012C...Next few lines allow you to see what info PYVETO extracted from
76013C...the full event record for the first two events.
76014C...Delete if you don't want it.
76015 DATA NLIST/0/
76016 SAVE NLIST
76017 IF(NLIST.LE.2) THEN
76018 WRITE(*,*) ' Full event record at time of UPVETO call:'
76019 CALL PYLIST(1)
76020 WRITE(*,*) ' Part of event record made available to UPVETO:'
76021 CALL PYLIST(5)
76022 NLIST=NLIST+1
76023 ENDIF
76024
76025C...Make decision here.
76026 IVETO = 0
76027
76028 RETURN
76029 END
76030
76031C*********************************************************************
76032
76033C*********************************************************************
76034
76035C...SUGRA
76036C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
76037
76038 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
76039 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76040 IMPLICIT INTEGER(I-N)
76041 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
76042 INTEGER IMODL
76043C...Commonblocks.
76044 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76045 SAVE /PYDAT1/
76046
76047C...Stop program if this routine is ever called.
76048 WRITE(MSTU(11),5000)
76049 CALL PYSTOP(110)
76050
76051C...Format for error printout.
76052 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76053 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
76054 &1X,'Execution stopped!')
76055
76056 RETURN
76057 END
76058
76059C*********************************************************************
76060
76061C...VISAJE
76062C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76063
76064 FUNCTION VISAJE()
76065 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76066 IMPLICIT INTEGER(I-N)
76067 CHARACTER*40 VISAJE
76068
76069C...Commonblocks.
76070 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76071 SAVE /PYDAT1/
76072
76073C...Assign default value.
76074 VISAJE='Undefined'
76075
76076C...Stop program if this routine is ever called.
76077 WRITE(MSTU(11),5000)
76078 CALL PYSTOP(110)
76079
76080C...Format for error printout.
76081 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76082 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
76083 &1X,'Execution stopped!')
76084
76085 RETURN
76086 END
76087
76088C*********************************************************************
76089
76090C...SSMSSM
76091C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
76092
76093 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
76094 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
76095 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
76096 &IDUM1,IDUM2)
76097 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76098 IMPLICIT INTEGER(I-N)
76099 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
76100 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
76101 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
76102C...Commonblocks.
76103 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76104 SAVE /PYDAT1/
76105
76106C...Stop program if this routine is ever called.
76107 WRITE(MSTU(11),5000)
76108 CALL PYSTOP(110)
76109
76110C...Format for error printout.
76111 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
76112 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
76113 &1X,'Execution stopped!')
76114 RETURN
76115 END
76116
76117C*********************************************************************
76118
76119C...FHSETFLAGS
76120C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76121
76122 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
76123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76124 IMPLICIT INTEGER(I-N)
76125Cmssmpart = 4 # full MSSM [recommended]
76126Cfieldren = 0 # MSbar field ren. [strongly recommended]
76127Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
76128Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
76129Cp2approx = 0 # no approximation [recommended]
76130Clooplevel= 2 # include 2-loop corrections
76131Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
76132Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
76133
76134C...Commonblocks.
76135 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76136 SAVE /PYDAT1/
76137
76138C...Stop program if this routine is ever called.
76139 WRITE(MSTU(11),5000)
76140 CALL PYSTOP(103)
76141
76142C...Format for error printout.
76143 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76144 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
76145 &1X,'Execution stopped!')
76146 RETURN
76147 END
76148
76149C*********************************************************************
76150
76151C...FHSETPARA
76152C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76153
76154 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
76155 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
76156 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
76157 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
76158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76159 IMPLICIT INTEGER(I-N)
76160
76161 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76162 DOUBLE COMPLEX DMU,
76163 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76164 & DM1, DM2, DM3
76165
76166C...Commonblocks.
76167 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76168 SAVE /PYDAT1/
76169
76170C...Stop program if this routine is ever called.
76171 WRITE(MSTU(11),5000)
76172 CALL PYSTOP(103)
76173
76174C...Format for error printout.
76175 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76176 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76177 &1X,'Execution stopped!')
76178 RETURN
76179 END
76180
76181C*********************************************************************
76182
76183C...FHHIGGSCORR
76184C...Dummy function, to be removed when FEYNHIGGS is to be linked.
76185
76186 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
76187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76188 IMPLICIT INTEGER(I-N)
76189
76190C...FeynHiggs variables
76191 DOUBLE PRECISION RMHIGG(4)
76192 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
76193 DOUBLE COMPLEX DMU,
76194 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
76195 & DM1, DM2, DM3
76196
76197C...Commonblocks.
76198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76199 SAVE /PYDAT1/
76200
76201C...Stop program if this routine is ever called.
76202 WRITE(MSTU(11),5000)
76203 CALL PYSTOP(103)
76204
76205C...Format for error printout.
76206 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
76207 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
76208 &1X,'Execution stopped!')
76209 RETURN
76210 END
76211
76212C*********************************************************************
76213
76214C...PYTAUD
76215C...Dummy routine, to be replaced by user, to handle the decay of a
76216C...polarized tau lepton.
76217C...Input:
76218C...ITAU is the position where the decaying tau is stored in /PYJETS/.
76219C...IORIG is the position where the mother of the tau is stored;
76220C... is 0 when the mother is not stored.
76221C...KFORIG is the flavour of the mother of the tau;
76222C... is 0 when the mother is not known.
76223C...Note that IORIG=0 does not necessarily imply KFORIG=0;
76224C... e.g. in B hadron semileptonic decays the W propagator
76225C... is not explicitly stored but the W code is still unambiguous.
76226C...Output:
76227C...NDECAY is the number of decay products in the current tau decay.
76228C...These decay products should be added to the /PYJETS/ common block,
76229C...in positions N+1 through N+NDECAY. For each product I you must
76230C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
76231C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
76232
76233 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
76234
76235C...Double precision and integer declarations.
76236 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76237 IMPLICIT INTEGER(I-N)
76238 INTEGER PYK,PYCHGE,PYCOMP
76239C...Commonblocks.
76240 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76242 SAVE /PYJETS/,/PYDAT1/
76243
76244C...Stop program if this routine is ever called.
76245C...You should not copy these lines to your own routine.
76246 NDECAY=ITAU+IORIG+KFORIG
76247 WRITE(MSTU(11),5000)
76248 CALL PYSTOP(10)
76249
76250C...Format for error printout.
76251 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
76252 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
76253 &1X,'Execution stopped!')
76254
76255 RETURN
76256 END
76257
76258C*********************************************************************
76259
76260C...PYTIME
76261C...Finds current date and time.
76262C...Since this task is not standardized in Fortran 77, the routine
76263C...is dummy, to be replaced by the user. Examples are given for
76264C...the Fortran 90 routine and DEC Fortran 77, and what to do if
76265C...you do not have access to suitable routines.
76266
76267 SUBROUTINE PYTIME(IDATI)
76268
76269C...Double precision and integer declarations.
76270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76271 IMPLICIT INTEGER(I-N)
76272 INTEGER PYK,PYCHGE,PYCOMP
76273 CHARACTER*8 ATIME
76274C...Local array.
76275 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
76276
76277C...Example 0: if you do not have suitable routines.
76278 DO 100 J=1,6
76279 IDATI(J)=0
76280 100 CONTINUE
76281
76282C...Example 1: Fortran 90 routine.
76283C CALL DATE_AND_TIME(VALUES=IVAL)
76284C IDATI(1)=IVAL(1)
76285C IDATI(2)=IVAL(2)
76286C IDATI(3)=IVAL(3)
76287C IDATI(4)=IVAL(5)
76288C IDATI(5)=IVAL(6)
76289C IDATI(6)=IVAL(7)
76290
76291C...Example 2: DEC Fortran 77. AIX.
76292C CALL IDATE(IMON,IDAY,IYEAR)
76293C IDATI(1)=IYEAR
76294C IDATI(2)=IMON
76295C IDATI(3)=IDAY
76296C CALL ITIME(IHOUR,IMIN,ISEC)
76297C IDATI(4)=IHOUR
76298C IDATI(5)=IMIN
76299C IDATI(6)=ISEC
76300
76301C...Example 3: DEC Fortran, IRIX, IRIX64.
76302C CALL IDATE(IMON,IDAY,IYEAR)
76303C IDATI(1)=IYEAR
76304C IDATI(2)=IMON
76305C IDATI(3)=IDAY
76306C CALL TIME(ATIME)
76307C IHOUR=0
76308C IMIN=0
76309C ISEC=0
76310C READ(ATIME(1:2),'(I2)') IHOUR
76311C READ(ATIME(4:5),'(I2)') IMIN
76312C READ(ATIME(7:8),'(I2)') ISEC
76313C IDATI(4)=IHOUR
76314C IDATI(5)=IMIN
76315C IDATI(6)=ISEC
76316
76317C...Example 4: GNU LINUX libU77, SunOS.
76318C CALL IDATE(IDTEMP)
76319C IDATI(1)=IDTEMP(3)
76320C IDATI(2)=IDTEMP(2)
76321C IDATI(3)=IDTEMP(1)
76322C CALL ITIME(IDTEMP)
76323C IDATI(4)=IDTEMP(1)
76324C IDATI(5)=IDTEMP(2)
76325C IDATI(6)=IDTEMP(3)
76326
76327C...Common code to ensure right century.
76328 IDATI(1)=2000+MOD(IDATI(1),100)
76329
76330 RETURN
76331 END