]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia6.4.21/pythia-6.4.21.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Upgrades and fixes of warnings from FC
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6.4.21 / pythia-6.4.21.f
CommitLineData
02626a96 1C*********************************************************************
2C*********************************************************************
3C* **
4C* Jul 2009 **
5C* **
6C* The Lund Monte Carlo **
7C* **
8C* PYTHIA version 6.4 **
9C* **
10C* Torbjorn Sjostrand **
11C* Department of Theoretical Physics **
12C* Lund University **
13C* Solvegatan 14A, S-223 62 Lund, Sweden **
14C* E-mail torbjorn@thep.lu.se **
15C* **
16C* SUSY and Technicolor parts by **
17C* Stephen Mrenna **
18C* Computing Division **
19C* Generators and Detector Simulation Group **
20C* Fermi National Accelerator Laboratory **
21C* MS 234, Batavia, IL 60510, USA **
22C* phone + 1 - 630 - 840 - 2556 **
23C* E-mail mrenna@fnal.gov **
24C* **
25C* New multiple interactions and more SUSY parts by **
26C* Peter Skands **
27C* Theoretical Physics Department **
28C* Fermi National Accelerator Laboratory **
29C* MS 106, Batavia, IL 60510, USA **
30C* and **
31C* CERN/PH, CH-1211 Geneva, Switzerland **
32C* phone +41 - 22 - 767 24 59 **
33C* E-mail skands@fnal.gov **
34C* **
35C* Several parts are written by Hans-Uno Bengtsson **
36C* PYSHOW is written together with Mats Bengtsson **
37C* PYMAEL is written by Emanuel Norrbin **
38C* advanced popcorn baryon production written by Patrik Eden **
39C* code for virtual photons mainly written by Christer Friberg **
40C* code for low-mass strings mainly written by Emanuel Norrbin **
41C* Bose-Einstein code mainly written by Leif Lonnblad **
42C* CTEQ parton distributions are by the CTEQ collaboration **
43C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
44C* SaS photon parton distributions together with Gerhard Schuler **
45C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
46C* MSSM Higgs mass calculation code by M. Carena, **
47C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
48C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
49C* PYGAUS adapted from CERN library (K.S. Kolbig) **
50C* NRQCD/colour octet production of onium by S. Wolf **
51C* **
52C* The latest program version and documentation is found on WWW **
53C* http://www.thep.lu.se/~torbjorn/Pythia.html **
54C* **
55C* Copyright Torbjorn Sjostrand, Lund (and CERN) 2008 **
56C* **
57C*********************************************************************
58C*********************************************************************
59C *
60C List of subprograms in order of appearance, with main purpose *
61C (S = subroutine, F = function, B = block data) *
62C *
63C B PYDATA to contain all default values *
64C S PYCKBD to check that BLOCK DATA has been correctly loaded *
65C S PYTEST to test the proper functioning of the package *
66C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
67C *
68C S PYINIT to administer the initialization procedure *
69C S PYEVNT to administer the generation of an event *
70C S PYEVNW ditto, for new multiple interactions scenario *
71C S PYSTAT to print cross-section and other information *
72C S PYUPEV to administer the generation of an LHA hard process *
73C S PYUPIN to provide initialization needed for LHA input *
74C S PYLHEF to produce a Les Houches Event File from run *
75C S PYINRE to initialize treatment of resonances *
76C S PYINBM to read in beam, target and frame choices *
77C S PYINKI to initialize kinematics of incoming particles *
78C S PYINPR to set up the selection of included processes *
79C S PYXTOT to give total, elastic and diffractive cross-sect. *
80C S PYMAXI to find differential cross-section maxima *
81C S PYPILE to select multiplicity of pileup events *
82C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
83C S PYGAGA to handle lepton -> lepton + gamma branchings *
84C S PYRAND to select subprocess and kinematics for event *
85C S PYSCAT to set up kinematics and colour flow of event *
86C S PYEVOL handler for pT-ordered ISR and multiple interactions *
87C S PYSSPA to simulate initial state spacelike showers *
88C S PYPTIS to do pT-ordered initial state spacelike showers *
89C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
90C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
91C S PYPTMI to do pT-ordered multiple interactions *
92C F PYFCMP to give companion quark x*f distribution *
93C F PYPCMP to calculate momentum integral for companion quarks *
94C S PYUPRE to rearranges contents of the HEPEUP commonblock *
95C S PYADSH to administrate sequential final-state showers *
96C S PYVETO to allow the generation of an event to be aborted *
97C S PYRESD to perform resonance decays *
98C S PYMULT to generate multiple interactions - old scheme *
99C S PYREMN to add on target remnants - old scheme *
100C S PYMIGN to generate multiple interactions - new scheme *
101C S PYMIHK to connect colours in mult. int. - new scheme *
102C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
103C S PYMIHG to collapse two pairs of LHA1 colour tags. *
104C S PYMIRM to add on target remnants in mult. int.- new scheme *
105C S PYFSCR to perform final state colour reconnections - -"- *
106C S PYDIFF to set up kinematics for diffractive events *
107C S PYDISG to set up kinematics, remnant and showers for DIS *
108C S PYDOCU to compute cross-sections and handle documentation *
109C S PYFRAM to perform boosts between different frames *
110C S PYWIDT to calculate full and partial widths of resonances *
111C S PYOFSH to calculate partial width into off-shell channels *
112C S PYRECO to handle colour reconnection in W+W- events *
113C S PYKLIM to calculate borders of allowed kinematical region *
114C S PYKMAP to construct value of kinematical variable *
115C S PYSIGH to calculate differential cross-sections *
116C S PYSGQC auxiliary to PYSIGH for QCD processes *
117C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
118C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
119C S PYSGHG auxiliary to PYSIGH for Higgs processes *
120C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
121C S PYSGTC auxiliary to PYSIGH for technicolor processes *
122C S PYSGEX auxiliary to PYSIGH for various exotic processes *
123C S PYPDFU to evaluate parton distributions *
124C S PYPDFL to evaluate parton distributions at low x and Q^2 *
125C S PYPDEL to evaluate electron parton distributions *
126C S PYPDGA to evaluate photon parton distributions (generic) *
127C S PYGGAM to evaluate photon parton distributions (SaS sets) *
128C S PYGVMD to evaluate VMD part of photon parton distributions *
129C S PYGANO to evaluate anomalous part of photon PDFs *
130C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
131C S PYGDIR to evaluate direct contribution to photon PDFs *
132C S PYPDPI to evaluate pion parton distributions *
133C S PYPDPR to evaluate proton parton distributions *
134C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
135C S PYGRVL to evaluate the GRV 94L proton parton distributions *
136C S PYGRVM to evaluate the GRV 94M proton parton distributions *
137C S PYGRVD to evaluate the GRV 94D proton parton distributions *
138C F PYGRVV auxiliary to the PYGRV* routines *
139C F PYGRVW auxiliary to the PYGRV* routines *
140C F PYGRVS auxiliary to the PYGRV* routines *
141C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
142C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
143C S PYPDPO to evaluate old proton parton distributions *
144C F PYHFTH to evaluate threshold factor for heavy flavour *
145C S PYSPLI to find flavours left in hadron when one removed *
146C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
147C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
148C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
149C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
150C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
151C S PYSTBH to evaluate matrix element for t + b + H processes *
152C S PYTBHB auxiliary to PYSTBH *
153C S PYTBHG auxiliary to PYSTBH *
154C S PYTBHQ auxiliary to PYSTBH *
155C F PYTBHS auxiliary to PYSTBH *
156C *
157C S PYMSIN to initialize the supersymmetry simulation *
158C S PYSLHA to interface to SUSY spectrum and decay calculators *
159C S PYAPPS to determine MSSM parameters from SUGRA input *
160C S PYSUGI to determine MSSM parameters using ISASUSY *
161C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
162C F PYRNMQ to determine running squark masses *
163C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
164C S PYINOM to calculate neutralino/chargino mass eigenstates *
165C F PYRNM3 to determine running M3, gluino mass *
166C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
167C S PYHGGM to determine Higgs mass spectrum *
168C S PYSUBH to determine Higgs masses in the MSSM *
169C S PYPOLE to determine Higgs masses in the MSSM *
170C S PYRGHM auxiliary to PYPOLE *
171C S PYGFXX auxiliary to PYRGHM *
172C F PYFINT auxiliary to PYPOLE *
173C F PYFISB auxiliary to PYFINT *
174C S PYSFDC to calculate sfermion decay partial widths *
175C S PYGLUI to calculate gluino decay partial widths *
176C S PYTBBN to calculate 3-body decay of gluino to neutralino *
177C S PYTBBC to calculate 3-body decay of gluino to chargino *
178C S PYNJDC to calculate neutralino decay partial widths *
179C S PYCJDC to calculate chargino decay partial widths *
180C F PYXXZ6 auxiliary for ino 3-body decays *
181C F PYXXGA auxiliary for ino -> ino + gamma decay *
182C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
183C F PYX2XH auxiliary for ino -> ino + Higgs decay *
184C S PYHEXT to calculate non-SM Higgs decay partial widths *
185C F PYH2XX auxiliary for H -> ino + ino decay *
186C F PYGAUS to perform Gaussian integration *
187C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
188C F PYSIMP to perform Simpson integration *
189C F PYLAMF to evaluate the lambda kinematics function *
190C S PYTBDY to perform 3-body decay of gauginos *
191C S PYTECM to calculate techni_rho/omega masses *
192C S PYXDIN to initialize Universal Extra Dimensions *
193C S PYUEDC to compute UED mass radiative corrections *
194C S PYXUED to compute UED cross sections *
195C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
196C F PYGRAW to compute UED partial widths to G* *
197C F PYWDKK to compute UED differential partial widths to G* *
198C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
199C S PYCMQR auxiliary to PYEICG *
200C S PYCMQ2 auxiliary to PYEICG *
201C S PYCDIV auxiliary to PYCMQR *
202C S PYCSRT auxiliary to PYCMQR *
203C S PYTHAG auxiliary to PYCMQR *
204C S PYCBAL auxiliary to PYEICG *
205C S PYCBA2 auxiliary to PYEICG *
206C S PYCRTH auxiliary to PYEICG *
207C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
208C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
209C S PYWIDX to calculate decay widths from within PYWIDT *
210C S PYRVSF to calculate R-violating sfermion decay widths *
211C S PYRVNE to calculate R-violating neutralino decay widths *
212C S PYRVCH to calculate R-violating chargino decay widths *
213C S PYRVGL to calculate R-violating gluino decay widths *
214C F PYRVSB auxiliary to PYRVSF *
215C S PYRVGW to calculate R-Violating 3-body widths *
216C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
217C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
218C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
219C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
220C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
221C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
222C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
223C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
224C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
225C *
226C S PY1ENT to fill one entry (= parton or particle) *
227C S PY2ENT to fill two entries *
228C S PY3ENT to fill three entries *
229C S PY4ENT to fill four entries *
230C S PY2FRM to interface to generic two-fermion generator *
231C S PY4FRM to interface to generic four-fermion generator *
232C S PY6FRM to interface to generic six-fermion generator *
233C S PY4JET to generate a shower from a given 4-parton config *
234C S PY4JTW to evaluate the weight od a shower history for above *
235C S PY4JTS to set up the parton configuration for above *
236C S PYJOIN to connect entries with colour flow information *
237C S PYGIVE to fill (or query) commonblock variables *
238C S PYONOF to allow easy control of particle decay modes *
239C S PYTUNE to select a predefined 'tune' for min-bias and UE *
240C S PYEXEC to administrate fragmentation and decay chain *
241C S PYPREP to rearrange showered partons along strings *
242C S PYSTRF to do string fragmentation of jet system *
243C S PYJURF to find boost to string junction rest frame *
244C S PYINDF to do independent fragmentation of one or many jets *
245C S PYDECY to do the decay of a particle *
246C S PYDCYK to select parton and hadron flavours in decays *
247C S PYKFDI to select parton and hadron flavours in fragm *
248C S PYNMES to select number of popcorn mesons *
249C S PYKFIN to calculate falvour prod. ratios from input params. *
250C S PYPTDI to select transverse momenta in fragm *
251C S PYZDIS to select longitudinal scaling variable in fragm *
252C S PYSHOW to do m-ordered timelike parton shower evolution *
253C S PYPTFS to do pT-ordered timelike parton shower evolution *
254C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
255C S PYBOEI to include Bose-Einstein effects (crudely) *
256C S PYBESQ auxiliary to PYBOEI *
257C F PYMASS to give the mass of a particle or parton *
258C F PYMRUN to give the running MSbar mass of a quark *
259C S PYNAME to give the name of a particle or parton *
260C F PYCHGE to give three times the electric charge *
261C F PYCOMP to compress standard KF flavour code to internal KC *
262C S PYERRM to write error messages and abort faulty run *
263C F PYALEM to give the alpha_electromagnetic value *
264C F PYALPS to give the alpha_strong value *
265C F PYANGL to give the angle from known x and y components *
266C F PYR to provide a random number generator *
267C S PYRGET to save the state of the random number generator *
268C S PYRSET to set the state of the random number generator *
269C S PYROBO to rotate and/or boost an event *
270C S PYEDIT to remove unwanted entries from record *
271C S PYLIST to list event record or particle data *
272C S PYLOGO to write a logo *
273C S PYUPDA to update particle data *
274C F PYK to provide integer-valued event information *
275C F PYP to provide real-valued event information *
276C S PYSPHE to perform sphericity analysis *
277C S PYTHRU to perform thrust analysis *
278C S PYCLUS to perform three-dimensional cluster analysis *
279C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
280C S PYJMAS to give high and low jet mass of event *
281C S PYFOWO to give Fox-Wolfram moments *
282C S PYTABU to analyze events, with tabular output *
283C *
284C S PYEEVT to administrate the generation of an e+e- event *
285C S PYXTEE to give the total cross-section at given CM energy *
286C S PYRADK to generate initial state photon radiation *
287C S PYXKFL to select flavour of primary qqbar pair *
288C S PYXJET to select (matrix element) jet multiplicity *
289C S PYX3JT to select kinematics of three-jet event *
290C S PYX4JT to select kinematics of four-jet event *
291C S PYXDIF to select angular orientation of event *
292C S PYONIA to perform generation of onium decay to gluons *
293C *
294C S PYBOOK to book a histogram *
295C S PYFILL to fill an entry in a histogram *
296C S PYFACT to multiply histogram contents by a factor *
297C S PYOPER to perform operations between histograms *
298C S PYHIST to print and reset all histograms *
299C S PYPLOT to print a single histogram *
300C S PYNULL to reset contents of a single histogram *
301C S PYDUMP to dump histogram contents onto a file *
302C *
303C S PYSTOP routine to handle Fortran STOP condition *
304C *
305C S PYKCUT dummy routine for user kinematical cuts *
306C S PYEVWT dummy routine for weighting events *
307C S UPINIT dummy routine to initialize user processes *
308C S UPEVNT dummy routine to generate a user process event *
309C S UPVETO dummy routine to abort event at parton level *
310C S PDFSET dummy routine to be removed when using PDFLIB *
311C S STRUCTM dummy routine to be removed when using PDFLIB *
312C S STRUCTP dummy routine to be removed when using PDFLIB *
313C S SUGRA dummy routine to be removed when linking with ISAJET *
314C F VISAJE dummy functn. to be removed when linking with ISAJET *
315C S SSMSSM dummy routine to be removed when linking with ISAJET *
316C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
317C S FHSETPARA dummy routine -"- FEYNHIGGS *
318C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
319C S PYTAUD dummy routine for interface to tau decay libraries *
320C S PYTIME dummy routine for giving date and time *
321C *
322C*********************************************************************
323
324C...PYDATA
325C...Default values for switches and parameters,
326C...and particle, decay and process data.
327
328 BLOCK DATA PYDATA
329
330C...Double precision and integer declarations.
331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
332 IMPLICIT INTEGER(I-N)
333 INTEGER PYK,PYCHGE,PYCOMP
334C...Commonblocks.
335 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
336 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
337 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
338 COMMON/PYDAT4/CHAF(500,2)
339 CHARACTER CHAF*16
340 COMMON/PYDATR/MRPY(6),RRPY(100)
341 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
343 COMMON/PYINT1/MINT(400),VINT(400)
344 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
345 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
346 COMMON/PYINT4/MWID(500),WIDS(500,5)
347 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
348 COMMON/PYINT6/PROC(0:500)
349 CHARACTER PROC*28
350 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
351 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
352 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
353 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
354 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
355 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
356 COMMON/PYPUED/IUED(0:99),RUED(0:99)
357 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
358 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
359 & AU(3,3),AD(3,3),AE(3,3)
360 COMMON/PYLH3C/CPRO(2),CVER(2)
361 CHARACTER CPRO*12,CVER*12
362 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
363 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
364 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
365 &/PYBINS/,/PYLH3P/,/PYLH3C/
366
367C...PYDAT1, containing status codes and most parameters.
368 DATA MSTU/
369 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
370 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
371 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
372 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
373 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
374 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
375 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
376 7 30*0,
377 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
378 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
379 & 80*0/
380 DATA (PARU(I),I=1,100)/
381 & 3.141592653589793D0, 6.283185307179586D0,
382 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
383 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
384 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
385 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
386 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
387 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
388 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
389 6 40*0D0/
390 DATA (PARU(I),I=101,200)/
391 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
392 & 0D0, 0D0, 0D0, 0D0, 0D0,
393 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
394 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
395 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
396 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
397 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
398 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
399 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
400 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
401 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
402 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
403 DATA MSTJ/
404 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
405 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
406 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
407 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
408 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
409 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
410 6 40*0,
411 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
412 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
413 2 80*0/
414 DATA PARJ/
415 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
416 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
417 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
418 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
419 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
420 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
421 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
422 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
423 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
424 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
425 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
426 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
427 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
428 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
429 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
430 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
431 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
432 4 10*0D0,
433 5 10*0D0,
434 6 10*0D0,
435 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
436 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
437 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
438 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
439 9 5*0D0/
440
441C...PYDAT2, with particle data and flavour treatment parameters.
442 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
443 &-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,
444 &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,
445 &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,
446 &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,
447 &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,
448 &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,
449 &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,
450 &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,
451 &7*0,3,
452C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
453 &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
454 &3*-3,0,-3,0,-3,0,-3,
455 &3*0,3,
456 &25*0/
457 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
458 &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,
459 &-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,
460 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
461 &83*0,12*1,9*0,2,3*0,25*0/
462 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
463 &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,
464 &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,
465 &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,
466 &81*0,21*1,3*0,1,25*0/
467 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
468 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
469 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
470 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
471 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
472 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
473 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
474 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
475 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
476 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
477 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
478 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
479 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
480 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
481 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
482 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
483 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
484 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
485 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
486 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
487 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
488 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
489 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
490 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
491 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
492 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
493 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
494 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
495 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
496 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
497 &3000115,3000215,
498 &81*0,
499C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
500 &6100001,6100002,6100003,6100004,6100005,6100006,
501 &5100001,5100002,5100003,5100004,5100005,5100006,
502 &6100011,6100013,6100015,
503 &5100012,5100011,5100014,5100013,5100016,5100015,
504 &5100021,5100022,5100023,5100024,
505 &25*0/
506 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
507 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
508 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
509 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
510 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
511 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
512 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
513 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
514 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
515 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
516 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
517 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
518 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
519 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
520 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
521 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
522 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
523 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
524 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
525 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
526 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
527 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
528 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
529 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
530 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
531 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
532 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
533 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
534 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
535 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
536 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
537 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
538 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
539 &3*9.5D0,2*250D0,
540 &81*0,
541C...UED
542 &586.,588.,586.,588.,586.,586.,6*598.,
543 &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
544 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
545 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
546 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
547 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
548 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
549 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
550 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
551 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
552 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
553 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
554 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
555 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
556 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
557 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
558 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
559 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
560 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
561 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
562 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
563 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
564 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
565 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
566 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
567 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
568 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
569 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
570 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
571 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
572 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
573 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
574 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
575 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
576 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
577 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
578 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
579 &8.80013D0,13*0D0,2.54987D0,2.84456D0,
580 &81*0,
581C...UED
582 &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
583 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
584 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
585 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
586 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
587 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
588 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
589 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
590 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
591
592 DATA PARF/
593 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
594 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
595 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
596 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
597 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
598 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
599 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
600 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
601 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
602 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
603 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
604 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
605 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
606 3 60*0D0,
607 4 0.2D0, 0.5D0, 8*0D0,
608 5 1800*0D0/
609 DATA ((VCKM(I,J),J=1,4),I=1,4)/
610 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
611 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
612 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
613 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
614
615C...PYDAT3, with particle decay parameters and data.
616 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
617 &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,
618 &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,
619 &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,
620 &81*0,
621C...UED
622 &5*1,0,5*1,0,13*1,25*0/
623 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
624 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
625 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
626 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
627 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
628 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
629 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
630 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
631 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
632 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
633 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
634 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
635 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
636 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
637 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
638 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
639 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
640 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
641 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
642 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
643 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
644 &4214,4215,4216,4296,4322,
645 &81*0,
646C...UED
647 %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
648 &5031,5032,5033,
649 &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
650 &25*0/
651 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
652 &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,
653 &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,
654 &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,
655 &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,
656 &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,
657 &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,
658 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
659 &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,
660 &3*22,15,12,2*7,7*0,6*1,26,30,
661 &81*0,
662C...UED
663 &6*2,6*3,9*1,24,1,18,6,25*0/
664 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
665 &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,
666 &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,
667 &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,
668 &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,
669 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
670 &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,
671 &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,
672 &5*-1,3*1,-1,
673 &649*0,
674C...UED
675 &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
676 &1,24*1,2912*0/
677 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
678 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
679 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
680 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
681 &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,
682 &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,
683 &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,
684 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
685 &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,
686 &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,
687 &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,
688 &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,
689 &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,
690 &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,
691 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
692 &16*32,
693C...UED
694 &653*0,30*0,9*0,12*0,37*0,2912*0/
695 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
696 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
697 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
698 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
699 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
700 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
701 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
702 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
703 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
704 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
705 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
706 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
707 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
708 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
709 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
710 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
711 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
712 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
713 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
714 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
715 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
716 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
717 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
718 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
719 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
720 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
721 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
722 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
723 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
724 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
725 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
726 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
727 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
728 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
729 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
730 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
731 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
732 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
733 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
734 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
735 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
736 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
737 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
738 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
739 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
740 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
741 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
742 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
743 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
744 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
745 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
746 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
747 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
748 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
749 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
750 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
751 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
752 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
753 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
754 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
755 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
756 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
757 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
758 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
759 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
760 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
761 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
762 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
763 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
764 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
765 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
766 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
767 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
768 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
769 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
770 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
771 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
772 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
773 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
774 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
775 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
776 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
777 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
778 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
779 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
780 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
781 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
782 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
783 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
784 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
785 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
786 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
787 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
788 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
789 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
790 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
791 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
792 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
793 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
794 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
795 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
796 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
797 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
798 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
799 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
800 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
801 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
802 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
803 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
804 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
805 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
806 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
807 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
808 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
809 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
810 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
811 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
812 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
813 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
814 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0/
815 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
816 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
817 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
818 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
819 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
820 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
821 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
822 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
823 &0.015D0,0.005D0,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
824 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
825 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
826 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
827 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
828 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
829 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
830 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
831 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
832 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
833 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
834 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
835 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
836 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
837 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
838 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
839 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
840 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
841 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
842 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
843 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
844 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
845 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
846 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
847 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
848 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
849 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
850 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
851 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
852 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
853 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
854 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
855 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
856 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
857 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
858 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
859 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
860 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
861 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
862 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
863 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
864 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
865 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
866 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
867 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
868 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
869 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
870 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
871 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
872 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
873 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
874 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
875 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
876 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
877 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
878 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
879 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
880 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
881 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
882 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
883 &2*0.011947D0,0.011946D0,0D0,
884 &649*0.D0,
885C....UED
886 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
887 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
888 &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
889 &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
890 &9*1.D0,
891 &24*0.0416667,
892 &1.,
893 &3*0.D0,6*0.08333D0,
894 &3*0.D0,6*0.08333D0,
895 &6*0.166667D0,
896 &2912*0.D0/
897 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
898 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
899 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
900 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
901 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
902 &-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,
903 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
904 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
905 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
906 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
907 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
908 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
909 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
910 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
911 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
912 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
913 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
914 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
915 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
916 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
917 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
918 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
919 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
920 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
921 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
922 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
923 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
924 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
925 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
926 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
927 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
928 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
929 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
930 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
931 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
932 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
933 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
934 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
935 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
936 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
937 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
938 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
939 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
940 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
941 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
942 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
943 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
944 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
945 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
946 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
947 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
948 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
949 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
950 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
951 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
952 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
953 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
954 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
955 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
956 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
957 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
958 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
959 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
960 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
961 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
962 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
963 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
964 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
965 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
966 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
967 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
968 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
969 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
970 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
971 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
972 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
973 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
974 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
975 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
976 &2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2/
977 DATA (KFDP(I,1),I=1403,1713)/2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,
978 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
979 &-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,221,223,221,
980 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
981 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
982 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
983 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
984 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
985 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
986 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
987 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
988 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
989 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
990 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
991 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
992 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
993 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
994 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
995 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
996 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
997 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
998 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
999 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
1000 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
1001 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
1002 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
1003 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1004 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1005 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1007 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1009 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1010 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1011 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1012 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1013 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1014 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1015 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1016 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1017 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
1018 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1019 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1020 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1021 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1022 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1023 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1024 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1025 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1026 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1027 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1028 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1029 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1030 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1031 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1032 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1033 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1034 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1035 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1036 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1037 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1038 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1039 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1040 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1041 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1042 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1043 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1044 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1045 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1046 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1047 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1048 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1049 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1050 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1051 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1052 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1053 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1054 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1055 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1056 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1057 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1058 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1059 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1060 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1061 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1062 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1063 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1064 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1065 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1066 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1067 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1068 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1069 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1070 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1071 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1072 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1073 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1074 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1075 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1076 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1077 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1078 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1079 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1080 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1081 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1082 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1083 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1084 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1085 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1086 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1087 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1088 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1089 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1090 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1091 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1092 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1093 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1094 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1095 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1096 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1097 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1098 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1099 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1100 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1101 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1102 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1103 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1104 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1105 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1106 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1107 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1108 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1109 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1110 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1111 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1112 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1113 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1114 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1115 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1116 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1117 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1118 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1119 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1120 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1121 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1122 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1123 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1124 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1125 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1126 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1127 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1128 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1129 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1130 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1131 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1132 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1133 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1134 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1135 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1136 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1137 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1138 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1139 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1140 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1141 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1142 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1143 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1144 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1145 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1146 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1147 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1148 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1149 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1150 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1151 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1152 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1153 &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,
1154 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1155 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1156 &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1157 &9*15/
1158 DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1159 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1160 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1161 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1162 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1163 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1164 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1165 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1166 &-11,-13,-15,-17,
1167 &649*0,
1168C...UED
1169 &5100023,5100022,5100023,5100022,5100023,5100022,
1170 &5100023,5100022,5100023,5100022,5100023,5100022,
1171 &5100023,-5100024,5100022,5100023,5100024,5100022,
1172 &5100023,-5100024,5100022,5100023,5100024,5100022,
1173 &5100023,-5100024,5100022,5100023,5100024,5100022,
1174 &9*5100022,
1175 &6100001,6100002,6100003,6100004,6100005,6100006,
1176 &5100001,5100002,5100003,5100004,5100005,5100006,
1177 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1178 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1179 &39,
1180 &6100011,6100013,6100015,
1181 &5100011,5100013,5100015,
1182 %5100012,5100014,5100016,
1183 &-6100011,-6100013,-6100015,
1184 &-5100011,-5100013,-5100015,
1185 %-5100012,-5100014,-5100016,
1186 &-5100011,-5100013,-5100015,
1187 &5100012,5100014,5100016,
1188 &2912*0/
1189 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,
1190 &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,
1191 &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,
1192 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1193 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1194 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1195 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1196 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1197 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1198 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1199 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1200 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1201 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1202 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1203 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1204 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1205 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1206 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1207 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1208 &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/
1209 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1210 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1211 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1212 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1213 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1214 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1215 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1216 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1217 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1218 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1219 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1220 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1221 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1222 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1223 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1224 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1225 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1226 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1227 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1228 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1229 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1230 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1231 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1232 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1233 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1234 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1235 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1236 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1237 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1238 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1239 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1240 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1241 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1242 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1243 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1244 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1245 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1246 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1247 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1248 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1249 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1250 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1251 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1252 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1253 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1254 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1255 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1256 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1257 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1258 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1259 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1260 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1261 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1262 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1263 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1264 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1265 &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,
1266 &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,
1267 &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,
1268 &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/
1269 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1270 &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,
1271 &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,
1272 &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,
1273 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1274 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1275 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1276 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1277 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1278 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1279 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1280 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1281 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1282 &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,
1283 &-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,
1284 &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,
1285 &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,
1286 &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,
1287 &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,
1288 &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/
1289 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1290 &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,
1291 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1292 &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,
1293 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1294 &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,
1295 &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,
1296 &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,
1297 &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,
1298 &-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,
1299 &-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,
1300 &-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,
1301 &-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,
1302 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1303 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1304 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1305 &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,
1306 &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,
1307 &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,
1308 &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/
1309 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1310 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1311 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1312 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1313 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1314 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1315 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1316 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1317 &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,
1318 &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,
1319 &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,
1320 &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,
1321 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1322 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1323 &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,
1324 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1325 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1326 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1327 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1328 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1329 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1330 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1331 &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,
1332 &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,
1333 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1334 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1335 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1336 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1337 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1338 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1339 &-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,
1340 &-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,
1341 &-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,
1342 &-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,
1343 &-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,
1344 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1345 &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,
1346 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1347 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1348 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1349 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1350 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1351 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1352 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1353 &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,
1354 &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,
1355 &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,
1356 &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,
1357 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1358 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1359 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1360 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1361 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1362 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1363 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1364 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1365 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1366 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1367 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1368 &-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/
1369 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1370 &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,
1371 &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,
1372 &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,
1373 &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,
1374 &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,
1375 &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,
1376 &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,
1377 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1378 &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,
1379 &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,
1380 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1381 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1382 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1383 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1384 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1385 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1386 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1387 &3*-5,3*1,3*3,3*5,-11,11,-15,15,3*-1,3*-3,3*-5,3*1,3*3,3*5,-11,11,
1388 &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1389 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1390 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1391 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1392 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1393 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1394 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1395 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1396 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1397 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1398 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1399 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1400 &649*0,
1401C...UED
1402 &1,1,2,2,3,3,4,4,5,5,6,6,
1403 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1404 &11,13,15,12,11,14,13,16,15,
1405 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1406 &1,2,3,4,5,6,1,2,3,4,5,6,
1407 &22,
1408 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1409 &11,13,15,11,13,15,12,14,16,
1410 &12,14,16,-11,-13,-15,
1411 &2912*0/
1412 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1413 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1414 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1415 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1416 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1417 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1418 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1419 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1420 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1421 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1422 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1423 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1424 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1425 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1426 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1427 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1428 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1429 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1430 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1431 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1432 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1433 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1434 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1435 &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,
1436 &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,
1437 &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,
1438 &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,
1439 &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,
1440 &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,
1441 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1442 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1443 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1444 &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,
1445 &-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,
1446 &-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,
1447 &-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,
1448 &-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,
1449 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1450 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1451 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1452 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1453 &-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,
1454 &-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,
1455 &-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,
1456 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1457 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1458 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1459 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1460 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1461 &-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,
1462 &-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,
1463 &-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,
1464 &-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,
1465 &-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,
1466 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1467 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1468 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1469 &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,
1470 &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,
1471 &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/
1472 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1473 &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,
1474 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1475 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1476 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1477 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1478 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1479 &-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,
1480 &-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,
1481 &-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,
1482 &-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,
1483 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1484 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1485 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1486 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1487 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1488 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1489 &-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,
1490 &-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,
1491 &-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/
1492 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1493 &-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,
1494 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1495 &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,
1496 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1497 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1498 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1499 &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,
1500 &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,
1501 &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,
1502 &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,
1503 &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,
1504 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1505 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1506 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1507 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1508 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1509 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1510 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1511 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1512 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1513 &-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,
1514 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1515 &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,
1516 &162*81,31*0,-211,111,6516*0/
1517 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1518 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1519 &3*111,-211,111,7193*0/
1520
1521C...PYDAT4, with particle names (character strings).
1522 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1523 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1524 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1525 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1526 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1527 &'junction',' ','system','cluster','string','indep.','CMshower',
1528 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1529 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1530 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1531 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1532 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1533 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1534 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1535 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1536 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1537 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1538 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1539 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1540 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1541 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1542 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1543 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1544 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1545 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1546 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1547 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1548 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1549 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1550 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1551 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1552 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1553 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1554 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1555 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1556 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1557 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1558 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1559 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1560 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1561 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1562 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1563 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1564 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1565 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1566 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1567 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1568 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1569 &81*' ',
1570C...UED
1571 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1572 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1573 &'e*_S-','mu*_S-','tau*_S-',
1574 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1575 &'g*','gamma*','Z*0','W*+',25*' '/
1576 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1577 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1578 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1579 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1580 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1581 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1582 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1583 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1584 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1585 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1586 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1587 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1588 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1589 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1590 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1591 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1592 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1593 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1594 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1595 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1596 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1597 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1598 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1599 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1600 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1601 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1602 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1603 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1604 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1605 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1606 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1607 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1608 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1609 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1610 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1611 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1612 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1613 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1614 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1615 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1616 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1617 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1618 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1619 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1620 &81*' ',
1621C...UED
1622 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1623 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1624 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1625 &'nu*_eDbar','e*_Dbar+',
1626 &'nu*_muDbar','mu*_Dbar+',
1627 &'nu*_tauDbar','tau*_Dbar+',
1628 &'g*','gamma*','Z*0','W*-',25*' '/
1629
1630C...PYDATR, with initial values for the random number generator.
1631 DATA MRPY/19780503,0,0,97,33,0/
1632
1633C...Default values for allowed processes and kinematics constraints.
1634 DATA MSEL/1/
1635 DATA MSUB/500*0/
1636 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1637 &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,
1638 &6*1,4*0,4*1,16*0/
1639 DATA CKIN/
1640 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1641 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1642 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1643 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1644 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1645 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1646 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1647 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1648 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1649 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1650 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1651 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1652 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1653 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1654 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1655 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1656 8 120*0D0/
1657
1658C...Default values for main switches and parameters. Reset information.
1659 DATA (MSTP(I),I=1,100)/
1660 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1661 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1662 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1663 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1664 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1665 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1666 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1667 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1669 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1670 DATA (MSTP(I),I=101,200)/
1671 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1672 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1673 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1674 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1675 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1676 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1677 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1678 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1679 8 6, 421, 2009, 07, 13, 0, 0, 0, 0, 0,
1680 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1681 DATA (PARP(I),I=1,100)/
1682 & 0.25D0, 10D0, 8*0D0,
1683 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1684 2 10*0D0,
1685 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1686 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1687 5 10*0D0,
1688 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1689 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1690 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1691 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1692 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1693 DATA (PARP(I),I=101,200)/
1694 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1695 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1696 2 1.0D0, 0.4D0, 8*0D0,
1697 3 0.01D0, 9*0D0,
1698 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1699 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1700 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1701 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1702 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1703 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1704 8 0.3D0, 0.64D0,
1705 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1706 DATA MSTI/200*0/
1707 DATA PARI/200*0D0/
1708 DATA MINT/400*0/
1709 DATA VINT/400*0D0/
1710
1711C...Constants for the generation of the various processes.
1712 DATA (ISET(I),I=1,100)/
1713 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1714 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1715 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1716 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1717 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1718 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1719 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1720 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1721 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1722 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1723 DATA (ISET(I),I=101,200)/
1724 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1725 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1726 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1727 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1728 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1729 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1730 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1731 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1732 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1733 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1734 DATA (ISET(I),I=201,300)/
1735 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1736 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1737 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1738 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1740 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1741 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1742 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1743 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1744 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1745 DATA (ISET(I),I=301,500)/
1746 & 2, 9*-2, 9*2, 21*-2,
1747 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1748 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1749 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1750 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1752 9 1, 1, 2, 2, 2, 5*-2,
1753 & 5, 5, 18*-2,
1754 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1755 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1756 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1757 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2/
1758 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1759 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1760 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1761 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1762 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1763 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1764 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1765 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1766 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1767 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1768 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1769 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1770 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1771 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1772 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1773 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1774 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1775 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1776 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1777 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1778 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1779 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1780 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1781 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1782 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1783 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1784 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1785 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1786 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1787 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1788 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1789 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1790 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1791 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1792 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1793 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1794 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1795 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1796 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1797 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1798 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1799 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1800 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1801 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1802 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1803 & 1000011, 1000011, 2000011, 2000011, 1000011,
1804 & 2000011, 1000013, 1000013, 2000013, 2000013,
1805 & 1000013, 2000013, 1000015, 1000015, 2000015,
1806 & 2000015, 1000015, 2000015, 1000011, 1000012,
1807 1 1000015, 1000016, 2000015, 1000016, 1000012,
1808 1 1000012, 1000016, 1000016, 0, 0,
1809 1 1000022, 1000022, 1000023, 1000023, 1000025,
1810 1 1000025, 1000035, 1000035, 1000022, 1000023,
1811 2 1000022, 1000025, 1000022, 1000035, 1000023,
1812 2 1000025, 1000023, 1000035, 1000025, 1000035,
1813 2 1000024, 1000024, 1000037, 1000037, 1000024,
1814 2 1000037, 1000022, 1000024, 1000023, 1000024,
1815 3 1000025, 1000024, 1000035, 1000024, 1000022,
1816 3 1000037, 1000023, 1000037, 1000025, 1000037,
1817 3 1000035, 1000037, 1000021, 1000022, 1000021,
1818 3 1000023, 1000021, 1000025, 1000021, 1000035/
1819 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1820 4 1000021, 1000024, 1000021, 1000037, 1000021,
1821 4 1000021, 1000021, 1000021, 0, 0,
1822 4 1000002, 1000022, 2000002, 1000022, 1000002,
1823 4 1000023, 2000002, 1000023, 1000002, 1000025,
1824 5 2000002, 1000025, 1000002, 1000035, 2000002,
1825 5 1000035, 1000001, 1000024, 2000005, 1000024,
1826 5 1000001, 1000037, 2000005, 1000037, 1000002,
1827 5 1000021, 2000002, 1000021, 0, 0,
1828 6 1000006, 1000006, 2000006, 2000006, 1000006,
1829 6 2000006, 1000006, 1000006, 2000006, 2000006,
1830 6 0, 0, 0, 0, 0,
1831 6 0, 0, 0, 0, 0,
1832 7 1000002, 1000002, 2000002, 2000002, 1000002,
1833 7 2000002, 1000002, 1000002, 2000002, 2000002,
1834 7 1000002, 2000002, 1000002, 1000002, 2000002,
1835 7 2000002, 1000002, 1000002, 2000002, 2000002/
1836 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1837 8 1000005, 1000002, 2000005, 2000002, 1000005,
1838 8 2000002, 1000005, 1000002, 2000005, 2000002,
1839 8 1000005, 2000002, 1000005, 1000005, 2000005,
1840 8 2000005, 1000005, 1000005, 2000005, 2000005,
1841 9 1000005, 1000005, 2000005, 2000005, 1000005,
1842 9 2000005, 1000005, 1000021, 2000005, 1000021,
1843 9 1000005, 2000005, 37, 25, 37,
1844 9 35, 36, 25, 36, 35,
1845 & 37, 37, 18*0,
1846C...UED: 311-319
1847 & 5100021, 5100021,
1848 & 5100002, 5100021,
1849 & 5100002, 5100001,
1850 & 5100002, -5100002,
1851 & 5100002, -5100002,
1852 & 5100002, -6100001,
1853 & 5100002, -5100001,
1854 & 5100002, 6100001,
1855 & 5100001, -5100001,
1856 & 42*0,
1857 4 9900041, 0, 9900042, 0, 9900041,
1858 4 11, 9900042, 11, 9900041, 13,
1859 4 9900042, 13, 9900041, 15, 9900042,
1860 4 15, 9900041, 9900041, 9900042, 9900042/
1861 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1862 5 9900041, 0, 9900042, 0, 9900023,
1863 5 0, 9900024, 0, 0, 0,
1864 5 0, 0, 0, 0, 0,
1865 5 0, 0, 0, 0, 0,
1866 6 24, 24, 24, 3000211, 3000211,
1867 6 3000211, 22, 3000111, 22, 3000221,
1868 6 23, 3000111, 23, 3000221, 24,
1869 6 3000211, 0, 0, 24, 23,
1870 7 24, 3000111, 3000211, 23, 3000211,
1871 7 3000111, 22, 3000211, 23, 3000211,
1872 7 24, 3000111, 24, 3000221, 22,
1873 7 24, 22, 23, 23, 23,
1874 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1875 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1876 9 5000039, 0, 5000039, 0, 21,
1877 9 5000039, 0, 5000039, 21, 5000039,
1878 9 10*0/
1879 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1880 & 37, 6, 37, 6, 36*0,
1881 2 443, 21, 9900443, 21, 9900441,
1882 2 21, 9910441, 21, 0, 9900443,
1883 2 0, 9900441, 0, 9910441, 21,
1884 2 9900443, 21, 9900441, 21, 9910441,
1885 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1886 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1887 6 553, 21, 9900553, 21, 9900551,
1888 6 21, 9910551, 21, 0, 9900553,
1889 6 0, 9900551, 0, 9910551, 21,
1890 6 9900553, 21, 9900551, 21, 9910551,
1891 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1892 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1893 DATA COEF/10000*0D0/
1894 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1895 &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,
1896 &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,
1897 &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,
1898 &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,
1899 &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,
1900 &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,
1901 &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,
1902 &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,
1903 &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,
1904 &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/
1905
1906C...Treatment of resonances.
1907 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1908 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1909 &81*0,21*1,4*1,25*0/
1910
1911C...Character constants: name of processes.
1912 DATA PROC(0)/ 'All included subprocesses '/
1913 DATA (PROC(I),I=1,20)/
1914 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1915 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1916 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1917 &' ', 'W+ + W- -> h0 ',
1918 &' ', 'f + f'' -> f + f'' (QFD) ',
1919 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1920 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1921 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1922 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1923 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1924 DATA (PROC(I),I=21,40)/
1925 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1926 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1927 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1928 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1929 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1930 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1931 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1932 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1933 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1934 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1935 DATA (PROC(I),I=41,60)/
1936 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1937 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1938 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1939 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1940 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1941 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1942 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1943 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1944 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1945 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1946 DATA (PROC(I),I=61,80)/
1947 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1948 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1949 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1950 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1951 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1952 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1953 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1954 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1955 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1956 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1957 DATA (PROC(I),I=81,100)/
1958 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1959 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1960 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1961 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1962 8'g + g -> chi_2c + g ', ' ',
1963 9'Elastic scattering ', 'Single diffractive (XB) ',
1964 9'Single diffractive (AX) ', 'Double diffractive ',
1965 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1966 9' ', ' ',
1967 9'q + gamma* -> q ', ' '/
1968 DATA (PROC(I),I=101,120)/
1969 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1970 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1971 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1972 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1973 &' ', 'f + fbar -> gamma + h0 ',
1974 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1975 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1976 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1977 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1978 1' ', ' '/
1979 DATA (PROC(I),I=121,140)/
1980 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1981 2'f + f'' -> f + f'' + h0 ',
1982 2'f + f'' -> f" + f"'' + h0 ',
1983 2' ', ' ',
1984 2' ', ' ',
1985 2' ', ' ',
1986 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1987 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1988 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1989 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1990 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1991 DATA (PROC(I),I=141,160)/
1992 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1993 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1994 4'q + l -> LQ ', 'e + gamma -> e* ',
1995 4'd + g -> d* ', 'u + g -> u* ',
1996 4'g + g -> eta_tc ', ' ',
1997 5'f + fbar -> H0 ', 'g + g -> H0 ',
1998 5'gamma + gamma -> H0 ', ' ',
1999 5' ', 'f + fbar -> A0 ',
2000 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
2001 5' ', ' '/
2002 DATA (PROC(I),I=161,180)/
2003 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2004 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2005 6'f + fbar -> f'' + fbar'' (g/Z)',
2006 6'f +fbar'' -> f" + fbar"'' (W) ',
2007 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2008 6'q + qbar -> e + e* ', ' ',
2009 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2010 7'f + f'' -> f + f'' + H0 ',
2011 7'f + f'' -> f" + f"'' + H0 ',
2012 7' ', 'f + fbar -> Z0 + A0 ',
2013 7'f + fbar'' -> W+/- + A0 ',
2014 7'f + f'' -> f + f'' + A0 ',
2015 7'f + f'' -> f" + f"'' + A0 ',
2016 7' '/
2017 DATA (PROC(I),I=181,200)/
2018 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2019 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2020 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2021 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2022 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2023 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2024 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2025 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2026 9' ', ' ',
2027 9' ', ' '/
2028 DATA (PROC(I),I=201,220)/
2029 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2030 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2031 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2032 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2033 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2034 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2035 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2036 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2037 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2038 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2039 DATA (PROC(I),I=221,240)/
2040 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2041 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2042 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2043 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2044 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2045 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2046 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2047 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2048 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2049 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2050 DATA (PROC(I),I=241,260)/
2051 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2052 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2053 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2054 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2055 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2056 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2057 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2058 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2059 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2060 5'qj + g -> ~qj_R + ~g ', ' '/
2061 DATA (PROC(I),I=261,300)/
2062 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2063 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2064 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2065 6' ', ' ',
2066 6' ', ' ',
2067 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2068 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2069 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2070 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2071 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2072 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2073 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2074 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2075 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2076 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2077 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2078 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2079 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2080 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2081 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2082 DATA (PROC(I),I=301,340)/
2083 &'f + fbar -> H+ + H- ',
2084 &9*' ', 'g + g -> g* + g* ',
2085 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2086 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2087 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2088 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2089 &21*' '/
2090 DATA (PROC(I),I=341,380)/
2091 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2092 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2093 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2094 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2095 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2096 5'f + f -> f'' + f'' + H_L++/-- ',
2097 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2098 5'f + fbar'' -> W_R+/- ',5*' ',
2099 6' ', 'f + fbar -> W_L+ W_L- ',
2100 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2101 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2102 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2103 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2104 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2105 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2106 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2107 7'f + fbar'' -> W+/- pi_T0 ',
2108 7'f + fbar'' -> W+/- pi_T0'' ',
2109 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2110 7'f + fbar -> Z0 Z0 (ETC) '/
2111 DATA (PROC(I),I=381,420)/
2112 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2113 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2114 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2115 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2116 8' ', ' ',
2117 9'f + fbar -> G* ', 'g + g -> G* ',
2118 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2119 9'g + g -> g + G* ', ' ',
2120 9 4*' ',
2121 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2122 & 18*' '/
2123 DATA (PROC(I),I=421,460)/
2124 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2125 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2126 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2127 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2128 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2129 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2130 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2131 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2132 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2133 3'q + q~ -> g + cc~[3P2(1)] ',
2134 3 21 *' '/
2135 DATA (PROC(I),I=461,500)/
2136 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2137 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2138 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2139 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2140 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2141 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2142 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2143 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2144 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2145 7'q + q~ -> g + bb~[3P2(1)] ',
2146 7 21 *' '/
2147
2148C...Cross sections and slope offsets.
2149 DATA SIGT/294*0D0/
2150
2151C...Supersymmetry switches and parameters.
2152 DATA IMSS/0,
2153 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2154 1 89*0/
2155 DATA RMSS/0D0,
2156 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2157 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2158 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2159 3 10*0D0,
2160 4 0D0,1D0,8*0D0,
2161 5 49*0D0/
2162C...Initial values for R-violating SUSY couplings.
2163C...Should not be changed here. See PYMSIN.
2164 DATA RVLAM/27*0D0/
2165 DATA RVLAMP/27*0D0/
2166 DATA RVLAMB/27*0D0/
2167
2168C...Technicolor switches and parameters
2169 DATA ITCM/0,
2170 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2171 1 89*0/
2172 DATA RTCM/0D0,
2173 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2174 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2175 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2176 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2177 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2178 4 200D0, 48*0D0/
2179
2180C...UED switches and parameters.
2181C... IUED(0) empty IUED vector element
2182C... IUED(1) UED ON(=1)/OFF(=0) switch
2183C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2184C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2185C... IUED(4) N the number of large extra dimensions
2186C... IUED(5) Selects whether the code takes Lambda (=0)
2187C... or Lambda*R (=1) as input.
2188C... IUED(6) With radiative corrections to the masses (=1)
2189C... or without (=0)
2190C...
2191C... RUED(0) empty RUED vector element
2192C... RUED(1) RINV (1/R) the curvature of the extra dimension
2193C... RUED(2) XMD the (4+N)-dimensional Planck scale
2194C... RUED(3) LAMUED (Lambda cutoff scale)
2195C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2196C...
2197 DATA IUED/0,0,0,5,6,0,1,93*0/
2198 DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2199
2200C...Data for histogramming routines.
2201 DATA IHIST/1000,20000,55,1/
2202 DATA INDX/1000*0/
2203
2204C...Data for SUSY Les Houches Accord.
2205 DATA CPRO/'PYTHIA ','PYTHIA '/
2206 DATA CVER/'6.4 ','6.4 '/
2207 DATA MODSEL/200*0/
2208 DATA PARMIN/100*0D0/
2209 DATA RMSOFT/101*0D0/
2210 DATA AU/9*0D0/
2211 DATA AD/9*0D0/
2212 DATA AE/9*0D0/
2213
2214 END
2215
2216C*********************************************************************
2217
2218C...PYCKBD
2219C...Check that BLOCK DATA PYDATA has been loaded.
2220C...Should not be required, except that some compilers/linkers
2221C...are pretty buggy in this respect.
2222
2223 SUBROUTINE PYCKBD
2224
2225C...Double precision and integer declarations.
2226 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2227 IMPLICIT INTEGER(I-N)
2228 INTEGER PYK,PYCHGE,PYCOMP
2229C...Commonblocks.
2230 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2231 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2232 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2233 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2234 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2235 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2236 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2237
2238C...Check a few variables to see they have been sensibly initialized.
2239 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2240 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2241 &MSTP(1).GT.5) THEN
2242C...If not, abort the run right away.
2243 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2244 WRITE(*,*) 'The program execution is stopped now!'
2245 CALL PYSTOP(8)
2246 ENDIF
2247
2248 RETURN
2249 END
2250
2251C*********************************************************************
2252
2253C...PYTEST
2254C...A simple program (disguised as subroutine) to run at installation
2255C...as a check that the program works as intended.
2256
2257 SUBROUTINE PYTEST(MTEST)
2258
2259C...Double precision and integer declarations.
2260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2261 IMPLICIT INTEGER(I-N)
2262 INTEGER PYK,PYCHGE,PYCOMP
2263C...Commonblocks.
2264 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2265 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2266 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2267 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2268 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2269 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2270 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2271C...Local arrays.
2272 DIMENSION PSUM(5),PINI(6),PFIN(6)
2273
2274C...Save defaults for values that are changed.
2275 MSTJ1=MSTJ(1)
2276 MSTJ3=MSTJ(3)
2277 MSTJ11=MSTJ(11)
2278 MSTJ42=MSTJ(42)
2279 MSTJ43=MSTJ(43)
2280 MSTJ44=MSTJ(44)
2281 PARJ17=PARJ(17)
2282 PARJ22=PARJ(22)
2283 PARJ43=PARJ(43)
2284 PARJ54=PARJ(54)
2285 MST101=MSTJ(101)
2286 MST104=MSTJ(104)
2287 MST105=MSTJ(105)
2288 MST107=MSTJ(107)
2289 MST116=MSTJ(116)
2290
2291C...First part: loop over simple events to be generated.
2292 IF(MTEST.GE.1) CALL PYTABU(20)
2293 NERR=0
2294 DO 180 IEV=1,500
2295
2296C...Reset parameter values. Switch on some nonstandard features.
2297 MSTJ(1)=1
2298 MSTJ(3)=0
2299 MSTJ(11)=1
2300 MSTJ(42)=2
2301 MSTJ(43)=4
2302 MSTJ(44)=2
2303 PARJ(17)=0.1D0
2304 PARJ(22)=1.5D0
2305 PARJ(43)=1D0
2306 PARJ(54)=-0.05D0
2307 MSTJ(101)=5
2308 MSTJ(104)=5
2309 MSTJ(105)=0
2310 MSTJ(107)=1
2311 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2312
2313C...Ten events each for some single jets configurations.
2314 IF(IEV.LE.50) THEN
2315 ITY=(IEV+9)/10
2316 MSTJ(3)=-1
2317 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2318 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2319 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2320 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2321 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2322 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2323
2324C...Ten events each for some simple jet systems; string fragmentation.
2325 ELSEIF(IEV.LE.130) THEN
2326 ITY=(IEV-41)/10
2327 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2328 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2329 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2330 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2331 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2332 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2333 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2334 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2335 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2336
2337C...Seventy events with independent fragmentation and momentum cons.
2338 ELSEIF(IEV.LE.200) THEN
2339 ITY=1+(IEV-131)/16
2340 MSTJ(2)=1+MOD(IEV-131,4)
2341 MSTJ(3)=1+MOD((IEV-131)/4,4)
2342 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2343 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2344 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2345 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2346 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2347 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2348
2349C...A hundred events with random jets (check invariant mass).
2350 ELSEIF(IEV.LE.300) THEN
2351 100 DO 110 J=1,5
2352 PSUM(J)=0D0
2353 110 CONTINUE
2354 NJET=2D0+6D0*PYR(0)
2355 DO 130 I=1,NJET
2356 KFL=21
2357 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2358 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2359 EJET=5D0+20D0*PYR(0)
2360 THETA=ACOS(2D0*PYR(0)-1D0)
2361 PHI=6.2832D0*PYR(0)
2362 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2363 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2364 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2365 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2366 DO 120 J=1,4
2367 PSUM(J)=PSUM(J)+P(I,J)
2368 120 CONTINUE
2369 130 CONTINUE
2370 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2371 & (PSUM(5)+PARJ(32))**2) GOTO 100
2372
2373C...Fifty e+e- continuum events with matrix elements.
2374 ELSEIF(IEV.LE.350) THEN
2375 MSTJ(101)=2
2376 CALL PYEEVT(0,40D0)
2377
2378C...Fifty e+e- continuum event with varying shower options.
2379 ELSEIF(IEV.LE.400) THEN
2380 MSTJ(42)=1+MOD(IEV,2)
2381 MSTJ(43)=1+MOD(IEV/2,4)
2382 MSTJ(44)=MOD(IEV/8,3)
2383 CALL PYEEVT(0,90D0)
2384
2385C...Fifty e+e- continuum events with coherent shower.
2386 ELSEIF(IEV.LE.450) THEN
2387 CALL PYEEVT(0,500D0)
2388
2389C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2390 ELSE
2391 CALL PYONIA(5,9.46D0)
2392 ENDIF
2393
2394C...Generate event. Find total momentum, energy and charge.
2395 DO 140 J=1,4
2396 PINI(J)=PYP(0,J)
2397 140 CONTINUE
2398 PINI(6)=PYP(0,6)
2399 CALL PYEXEC
2400 DO 150 J=1,4
2401 PFIN(J)=PYP(0,J)
2402 150 CONTINUE
2403 PFIN(6)=PYP(0,6)
2404
2405C...Check conservation of energy, momentum and charge;
2406C...usually exact, but only approximate for single jets.
2407 MERR=0
2408 IF(IEV.LE.50) THEN
2409 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2410 & MERR=MERR+1
2411 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2412 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2413 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2414 ELSE
2415 DO 160 J=1,4
2416 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2417 160 CONTINUE
2418 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2419 ENDIF
2420 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2421 & (PFIN(J),J=1,4),PFIN(6)
2422
2423C...Check that all KF codes are known ones, and that partons/particles
2424C...satisfy energy-momentum-mass relation. Store particle statistics.
2425 DO 170 I=1,N
2426 IF(K(I,1).GT.20) GOTO 170
2427 IF(PYCOMP(K(I,2)).EQ.0) THEN
2428 WRITE(MSTU(11),5100) I
2429 MERR=MERR+1
2430 ENDIF
2431 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2432 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2433 & THEN
2434 WRITE(MSTU(11),5200) I
2435 MERR=MERR+1
2436 ENDIF
2437 170 CONTINUE
2438 IF(MTEST.GE.1) CALL PYTABU(21)
2439
2440C...List all erroneous events and some normal ones.
2441 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2442 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2443 CALL PYLIST(2)
2444 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2445 CALL PYLIST(1)
2446 ENDIF
2447
2448C...Stop execution if too many errors.
2449 IF(MERR.NE.0) NERR=NERR+1
2450 IF(NERR.GE.10) THEN
2451 WRITE(MSTU(11),6300)
2452 CALL PYLIST(1)
2453 CALL PYSTOP(9)
2454 ENDIF
2455 180 CONTINUE
2456
2457C...Summarize result of run.
2458 IF(MTEST.GE.1) CALL PYTABU(22)
2459
2460C...Reset commonblock variables changed during run.
2461 MSTJ(1)=MSTJ1
2462 MSTJ(3)=MSTJ3
2463 MSTJ(11)=MSTJ11
2464 MSTJ(42)=MSTJ42
2465 MSTJ(43)=MSTJ43
2466 MSTJ(44)=MSTJ44
2467 PARJ(17)=PARJ17
2468 PARJ(22)=PARJ22
2469 PARJ(43)=PARJ43
2470 PARJ(54)=PARJ54
2471 MSTJ(101)=MST101
2472 MSTJ(104)=MST104
2473 MSTJ(105)=MST105
2474 MSTJ(107)=MST107
2475 MSTJ(116)=MST116
2476
2477C...Second part: complete events of various kinds.
2478C...Common initial values. Loop over initiating conditions.
2479 MSTP(122)=MAX(0,MIN(2,MTEST))
2480 MDCY(PYCOMP(111),1)=0
2481 DO 230 IPROC=1,8
2482
2483C...Reset process type, kinematics cuts, and the flags used.
2484 MSEL=0
2485 DO 190 ISUB=1,500
2486 MSUB(ISUB)=0
2487 190 CONTINUE
2488 CKIN(1)=2D0
2489 CKIN(3)=0D0
2490 MSTP(2)=1
2491 MSTP(11)=0
2492 MSTP(33)=0
2493 MSTP(81)=1
2494 MSTP(82)=1
2495 MSTP(111)=1
2496 MSTP(131)=0
2497 MSTP(133)=0
2498 PARP(131)=0.01D0
2499
2500C...Prompt photon production at fixed target.
2501 IF(IPROC.EQ.1) THEN
2502 PZSUM=300D0
2503 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2504 PQSUM=2D0
2505 MSEL=10
2506 CKIN(3)=5D0
2507 CALL PYINIT('FIXT','pi+','p',PZSUM)
2508
2509C...QCD processes at ISR energies.
2510 ELSEIF(IPROC.EQ.2) THEN
2511 PESUM=63D0
2512 PZSUM=0D0
2513 PQSUM=2D0
2514 MSEL=1
2515 CKIN(3)=5D0
2516 CALL PYINIT('CMS','p','p',PESUM)
2517
2518C...W production + multiple interactions at CERN Collider.
2519 ELSEIF(IPROC.EQ.3) THEN
2520 PESUM=630D0
2521 PZSUM=0D0
2522 PQSUM=0D0
2523 MSEL=12
2524 CKIN(1)=20D0
2525 MSTP(82)=4
2526 MSTP(2)=2
2527 MSTP(33)=3
2528 CALL PYINIT('CMS','p','pbar',PESUM)
2529
2530C...W/Z gauge boson pairs + pileup events at the Tevatron.
2531 ELSEIF(IPROC.EQ.4) THEN
2532 PESUM=1800D0
2533 PZSUM=0D0
2534 PQSUM=0D0
2535 MSUB(22)=1
2536 MSUB(23)=1
2537 MSUB(25)=1
2538 CKIN(1)=200D0
2539 MSTP(111)=0
2540 MSTP(131)=1
2541 MSTP(133)=2
2542 PARP(131)=0.04D0
2543 CALL PYINIT('CMS','p','pbar',PESUM)
2544
2545C...Higgs production at LHC.
2546 ELSEIF(IPROC.EQ.5) THEN
2547 PESUM=15400D0
2548 PZSUM=0D0
2549 PQSUM=2D0
2550 MSUB(3)=1
2551 MSUB(102)=1
2552 MSUB(123)=1
2553 MSUB(124)=1
2554 PMAS(25,1)=300D0
2555 CKIN(1)=200D0
2556 MSTP(81)=0
2557 MSTP(111)=0
2558 CALL PYINIT('CMS','p','p',PESUM)
2559
2560C...Z' production at SSC.
2561 ELSEIF(IPROC.EQ.6) THEN
2562 PESUM=40000D0
2563 PZSUM=0D0
2564 PQSUM=2D0
2565 MSEL=21
2566 PMAS(32,1)=600D0
2567 CKIN(1)=400D0
2568 MSTP(81)=0
2569 MSTP(111)=0
2570 CALL PYINIT('CMS','p','p',PESUM)
2571
2572C...W pair production at 1 TeV e+e- collider.
2573 ELSEIF(IPROC.EQ.7) THEN
2574 PESUM=1000D0
2575 PZSUM=0D0
2576 PQSUM=0D0
2577 MSUB(25)=1
2578 MSUB(69)=1
2579 MSTP(11)=1
2580 CALL PYINIT('CMS','e+','e-',PESUM)
2581
2582C...Deep inelastic scattering at a LEP+LHC ep collider.
2583 ELSEIF(IPROC.EQ.8) THEN
2584 P(1,1)=0D0
2585 P(1,2)=0D0
2586 P(1,3)=8000D0
2587 P(2,1)=0D0
2588 P(2,2)=0D0
2589 P(2,3)=-80D0
2590 PESUM=8080D0
2591 PZSUM=7920D0
2592 PQSUM=0D0
2593 MSUB(10)=1
2594 CKIN(3)=50D0
2595 MSTP(111)=0
2596 CALL PYINIT('3MOM','p','e-',PESUM)
2597 ENDIF
2598
2599C...Generate 20 events of each required type.
2600 DO 220 IEV=1,20
2601 CALL PYEVNT
2602 PESUMM=PESUM
2603 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2604
2605C...Check conservation of energy/momentum/flavour.
2606 PINI(1)=0D0
2607 PINI(2)=0D0
2608 PINI(3)=PZSUM
2609 PINI(4)=PESUMM
2610 PINI(6)=PQSUM
2611 DO 200 J=1,4
2612 PFIN(J)=PYP(0,J)
2613 200 CONTINUE
2614 PFIN(6)=PYP(0,6)
2615 MERR=0
2616 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2617 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2618 DEVQ=ABS(PFIN(6)-PINI(6))
2619 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2620 & DEVQ.GT.0.1D0) MERR=1
2621 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2622 & (PFIN(J),J=1,4),PFIN(6)
2623
2624C...Check that all KF codes are known ones, and that partons/particles
2625C...satisfy energy-momentum-mass relation.
2626 DO 210 I=1,N
2627 IF(K(I,1).GT.20) GOTO 210
2628 IF(PYCOMP(K(I,2)).EQ.0) THEN
2629 WRITE(MSTU(11),5100) I
2630 MERR=MERR+1
2631 ENDIF
2632 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2633 & SIGN(1D0,P(I,5))
2634 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2635 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2636 WRITE(MSTU(11),5200) I
2637 MERR=MERR+1
2638 ENDIF
2639 210 CONTINUE
2640
2641C...Listing of erroneous events, and first event of each type.
2642 IF(MERR.GE.1) NERR=NERR+1
2643 IF(NERR.GE.10) THEN
2644 WRITE(MSTU(11),6300)
2645 CALL PYLIST(1)
2646 CALL PYSTOP(9)
2647 ENDIF
2648 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2649 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2650 CALL PYLIST(1)
2651 ENDIF
2652 220 CONTINUE
2653
2654C...List statistics for each process type.
2655 IF(MTEST.GE.1) CALL PYSTAT(1)
2656 230 CONTINUE
2657
2658C...Summarize result of run.
2659 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2660 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2661
2662C...Format statements for output.
2663 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2664 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2665 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2666 &4(1X,F12.5),1X,F8.2)
2667 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2668 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2669 &'kinematics')
2670 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2671 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2672 6400 FORMAT(5X,'Faulty event follows:')
2673 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2674 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2675 &5X,'This should not have happened!')
2676
2677 RETURN
2678 END
2679
2680C*********************************************************************
2681
2682C...PYHEPC
2683C...Converts PYTHIA event record contents to or from
2684C...the standard event record commonblock.
2685
2686 SUBROUTINE PYHEPC(MCONV)
2687
2688C...Double precision and integer declarations.
2689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2690 IMPLICIT INTEGER(I-N)
2691 INTEGER PYK,PYCHGE,PYCOMP
2692C...Commonblocks.
2693 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2695 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2696 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2697C...HEPEVT commonblock.
2698 PARAMETER (NMXHEP=4000)
2699 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2700 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2701 DOUBLE PRECISION PHEP,VHEP
2702 SAVE /HEPEVT/
2703
2704C...Store HEPEVT commonblock size (for interfacing issues).
2705 MSTU(8)=NMXHEP
2706
2707C...Conversion from PYTHIA to standard, the easy part.
2708 IF(MCONV.EQ.1) THEN
2709 NEVHEP=0
2710 IF(N.GT.NMXHEP) CALL PYERRM(8,
2711 & '(PYHEPC:) no more space in /HEPEVT/')
2712 NHEP=MIN(N,NMXHEP)
2713 DO 150 I=1,NHEP
2714 ISTHEP(I)=0
2715 IF(K(I,1).GE.1.AND.K(I,1).LE.10) ISTHEP(I)=1
2716 IF(K(I,1).GE.11.AND.K(I,1).LE.20) ISTHEP(I)=2
2717 IF(K(I,1).GE.21.AND.K(I,1).LE.30) ISTHEP(I)=3
2718 IF(K(I,1).GE.31.AND.K(I,1).LE.100) ISTHEP(I)=K(I,1)
2719 IDHEP(I)=K(I,2)
2720 JMOHEP(1,I)=K(I,3)
2721 JMOHEP(2,I)=0
2722 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) THEN
2723 JDAHEP(1,I)=K(I,4)
2724 JDAHEP(2,I)=K(I,5)
2725 ELSE
2726 JDAHEP(1,I)=0
2727 JDAHEP(2,I)=0
2728 ENDIF
2729 DO 100 J=1,5
2730 PHEP(J,I)=P(I,J)
2731 100 CONTINUE
2732 DO 110 J=1,4
2733 VHEP(J,I)=V(I,J)
2734 110 CONTINUE
2735
2736C...Check if new event (from pileup).
2737 IF(I.EQ.1) THEN
2738 INEW=1
2739 ELSE
2740 IF(K(I,1).EQ.21.AND.K(I-1,1).NE.21) INEW=I
2741 ENDIF
2742
2743C...Fill in missing mother information.
2744 IF(I.GE.INEW+2.AND.K(I,1).EQ.21.AND.K(I,3).EQ.0) THEN
2745 IMO1=I-2
2746 120 IF(IMO1.GT.INEW.AND.K(IMO1+1,1).EQ.21.AND.K(IMO1+1,3).EQ.0)
2747 & THEN
2748 IMO1=IMO1-1
2749 GOTO 120
2750 ENDIF
2751 JMOHEP(1,I)=IMO1
2752 JMOHEP(2,I)=IMO1+1
2753 ELSEIF(K(I,2).GE.91.AND.K(I,2).LE.93) THEN
2754 I1=K(I,3)-1
2755 130 I1=I1+1
2756 IF(I1.GE.I) CALL PYERRM(8,
2757 & '(PYHEPC:) translation of inconsistent event history')
2758 IF(I1.LT.I.AND.K(I1,1).NE.1.AND.K(I1,1).NE.11) GOTO 130
2759 KC=PYCOMP(K(I1,2))
2760 IF(I1.LT.I.AND.KC.EQ.0) GOTO 130
2761 IF(I1.LT.I.AND.KCHG(KC,2).EQ.0) GOTO 130
2762 JMOHEP(2,I)=I1
2763 ELSEIF(K(I,2).EQ.94) THEN
2764 NJET=2
2765 IF(NHEP.GE.I+3.AND.K(I+3,3).LE.I) NJET=3
2766 IF(NHEP.GE.I+4.AND.K(I+4,3).LE.I) NJET=4
2767 JMOHEP(2,I)=MOD(K(I+NJET,4)/MSTU(5),MSTU(5))
2768 IF(JMOHEP(2,I).EQ.JMOHEP(1,I)) JMOHEP(2,I)=
2769 & MOD(K(I+1,4)/MSTU(5),MSTU(5))
2770 ENDIF
2771
2772C...Fill in missing daughter information.
2773 IF(K(I,2).EQ.94.AND.MSTU(16).NE.2) THEN
2774 DO 140 I1=JDAHEP(1,I),JDAHEP(2,I)
2775 I2=MOD(K(I1,4)/MSTU(5),MSTU(5))
2776 JDAHEP(1,I2)=I
2777 140 CONTINUE
2778 ENDIF
2779 IF(K(I,2).GE.91.AND.K(I,2).LE.94) GOTO 150
2780 I1=JMOHEP(1,I)
2781 IF(I1.LE.0.OR.I1.GT.NHEP) GOTO 150
2782 IF(K(I1,1).NE.13.AND.K(I1,1).NE.14) GOTO 150
2783 IF(JDAHEP(1,I1).EQ.0) THEN
2784 JDAHEP(1,I1)=I
2785 ELSE
2786 JDAHEP(2,I1)=I
2787 ENDIF
2788 150 CONTINUE
2789 DO 160 I=1,NHEP
2790 IF(K(I,1).NE.13.AND.K(I,1).NE.14) GOTO 160
2791 IF(JDAHEP(2,I).EQ.0) JDAHEP(2,I)=JDAHEP(1,I)
2792 160 CONTINUE
2793
2794C...Conversion from standard to PYTHIA, the easy part.
2795 ELSE
2796 IF(NHEP.GT.MSTU(4)) CALL PYERRM(8,
2797 & '(PYHEPC:) no more space in /PYJETS/')
2798 N=MIN(NHEP,MSTU(4))
2799 NKQ=0
2800 KQSUM=0
2801 DO 190 I=1,N
2802 K(I,1)=0
2803 IF(ISTHEP(I).EQ.1) K(I,1)=1
2804 IF(ISTHEP(I).EQ.2) K(I,1)=11
2805 IF(ISTHEP(I).EQ.3) K(I,1)=21
2806 K(I,2)=IDHEP(I)
2807 K(I,3)=JMOHEP(1,I)
2808 K(I,4)=JDAHEP(1,I)
2809 K(I,5)=JDAHEP(2,I)
2810 DO 170 J=1,5
2811 P(I,J)=PHEP(J,I)
2812 170 CONTINUE
2813 DO 180 J=1,4
2814 V(I,J)=VHEP(J,I)
2815 180 CONTINUE
2816 V(I,5)=0D0
2817 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2818 I1=JDAHEP(1,I)
2819 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2820 & PHEP(5,I)/PHEP(4,I)
2821 ENDIF
2822
2823C...Fill in missing information on colour connection in jet systems.
2824 IF(ISTHEP(I).EQ.1) THEN
2825 KC=PYCOMP(K(I,2))
2826 KQ=0
2827 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2828 IF(KQ.NE.0) NKQ=NKQ+1
2829 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2830 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2831 K(I,1)=2
2832 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2833 IF(K(I+1,2).EQ.21) K(I,1)=2
2834 ENDIF
2835 ENDIF
2836 190 CONTINUE
2837 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2838 & '(PYHEPC:) input parton configuration not colour singlet')
2839 ENDIF
2840
2841 END
2842
2843C*********************************************************************
2844
2845C...PYINIT
2846C...Initializes the generation procedure; finds maxima of the
2847C...differential cross-sections to be used for weighting.
2848
2849 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2850
2851C...Double precision and integer declarations.
2852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2853 IMPLICIT INTEGER(I-N)
2854 INTEGER PYK,PYCHGE,PYCOMP
2855C...Commonblocks.
2856 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2857 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2858 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2859 COMMON/PYDAT4/CHAF(500,2)
2860 CHARACTER CHAF*16
2861 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2862 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2863 COMMON/PYINT1/MINT(400),VINT(400)
2864 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2865 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2866 COMMON/PYPUED/IUED(0:99),RUED(0:99)
2867 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2868 &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2869C...Local arrays and character variables.
2870 DIMENSION ALAMIN(20),NFIN(20)
2871 CHARACTER*(*) FRAME,BEAM,TARGET
2872 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2873
2874C...Interface to PDFLIB.
2875 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
be4253b2 2876 COMMON/LW50512/QCDL4,QCDL5
2877 SAVE /W50511/,/LW50512/
02626a96 2878 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2879 CHARACTER*20 PARM(20)
2880 DATA VALUE/20*0D0/,PARM/20*' '/
2881
2882C...Data:Lambda and n_f values for parton distributions..
2883 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2884 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2885 &NFIN/20*4/
2886 DATA CHLH/'lepton','hadron'/
2887
2888C...Check that BLOCK DATA PYDATA has been loaded.
2889 CALL PYCKBD
2890
2891C...Reset MINT and VINT arrays. Write headers.
2892 MSTI(53)=0
2893 DO 100 J=1,400
2894 MINT(J)=0
2895 VINT(J)=0D0
2896 100 CONTINUE
2897 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2898 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2899
2900C...Reset error counters.
2901 MSTU(23)=0
2902 MSTU(27)=0
2903 MSTU(30)=0
2904
2905C...Reset processes that should not be on.
2906 MSUB(96)=0
2907 MSUB(97)=0
2908
2909C...Select global FSR/ISR/UE parameter set = 'tune'
2910C...See routine PYTUNE for details
2911 IF (MSTP(5).NE.0) THEN
2912 MSTP5=MSTP(5)
2913 CALL PYTUNE(MSTP5)
2914 ENDIF
2915
2916C...Call user process initialization routine.
2917 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2918 MSEL=0
2919 CALL UPINIT
2920 MSEL=0
2921 ENDIF
2922
2923C...Maximum 4 generations; set maximum number of allowed flavours.
2924 MSTP(1)=MIN(4,MSTP(1))
2925 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2926 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2927
2928C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2929 DO 120 I=-20,20
2930 VINT(180+I)=0D0
2931 IA=IABS(I)
2932 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2933 DO 110 J=1,MSTP(1)
2934 IB=2*J-1+MOD(IA,2)
2935 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2936 IPM=(5-ISIGN(1,I))/2
2937 IDC=J+MDCY(IA,2)+2
2938 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2939 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2940 110 CONTINUE
2941 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2942 VINT(180+I)=1D0
2943 ENDIF
2944 120 CONTINUE
2945
2946C...Initialize parton distributions: PDFLIB.
2947 IF(MSTP(52).EQ.2) THEN
2948 PARM(1)='NPTYPE'
2949 VALUE(1)=1
2950 PARM(2)='NGROUP'
2951 VALUE(2)=MSTP(51)/1000
2952 PARM(3)='NSET'
2953 VALUE(3)=MOD(MSTP(51),1000)
2954 PARM(4)='TMAS'
2955 VALUE(4)=PMAS(6,1)
2956 CALL PDFSET_ALICE(PARM,VALUE)
2957 MINT(93)=1000000+MSTP(51)
2958 ENDIF
02626a96 2959C...Choose Lambda value to use in alpha-strong.
2960 MSTU(111)=MSTP(2)
2961 IF(MSTP(3).GE.2) THEN
2962 ALAM=0.2D0
2963 NF=4
2964 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2965 ALAM=ALAMIN(MSTP(51))
2966 NF=NFIN(MSTP(51))
2967 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2968 ALAM=QCDL5
2969 NF=5
2970 ELSEIF(MSTP(52).EQ.2) THEN
2971 ALAM=QCDL4
2972 NF=4
2973 ENDIF
2974 PARP(1)=ALAM
2975 PARP(61)=ALAM
2976 PARP(72)=ALAM
2977 PARU(112)=ALAM
2978 MSTU(112)=NF
2979 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2980 ENDIF
02626a96 2981C...Initialize the UED masses and widths
2982 IF (IUED(1).EQ.1) CALL PYXDIN
2983
2984C...Initialize the SUSY generation: couplings, masses,
2985C...decay modes, branching ratios, and so on.
2986 CALL PYMSIN
2987C...Initialize widths and partial widths for resonances.
2988 CALL PYINRE
2989C...Set Z0 mass and width for e+e- routines.
2990 PARJ(123)=PMAS(23,1)
2991 PARJ(124)=PMAS(23,2)
2992
2993C...Identify beam and target particles and frame of process.
2994 CHFRAM=FRAME//' '
2995 CHBEAM=BEAM//' '
2996 CHTARG=TARGET//' '
2997 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
2998 IF(MINT(65).EQ.1) GOTO 170
2999
3000C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3001C...For e-gamma allow 2 alternatives.
3002 MINT(121)=1
3003 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3004 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3005 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3006 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3007 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3008 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3009 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3010 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3011 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3012 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3013 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3014 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3016 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3017 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3018 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3019 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3020 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3021 ENDIF
3022 MINT(123)=MSTP(14)
3023 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3024 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3025 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3026 IF(MSTP(14).EQ.11) MINT(123)=0
3027 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3028 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3029 IF(MSTP(14).EQ.15) MINT(123)=2
3030 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3031 IF(MSTP(14).EQ.19) MINT(123)=3
3032 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3033 IF(MSTP(14).EQ.21) MINT(123)=0
3034 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3035 IF(MSTP(14).EQ.24) MINT(123)=1
3036 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3037 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3038 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3039 ENDIF
3040
3041C...Set up kinematics of process.
3042 CALL PYINKI(0)
3043
3044C...Set up kinematics for photons inside leptons.
3045 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3046
3047C...Precalculate flavour selection weights.
3048 CALL PYKFIN
3049
3050C...Loop over gamma-p or gamma-gamma alternatives.
3051 CKIN3=CKIN(3)
3052 MSAV48=0
3053 DO 160 IGA=1,MINT(121)
3054 CKIN(3)=CKIN3
3055 MINT(122)=IGA
3056
3057C...Select partonic subprocesses to be included in the simulation.
3058 CALL PYINPR
3059 MINT(101)=1
3060 MINT(102)=1
3061 MINT(103)=MINT(11)
3062 MINT(104)=MINT(12)
3063
3064C...Count number of subprocesses on.
3065 MINT(48)=0
3066 DO 130 ISUB=1,500
3067 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3068 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3069 MSUB(ISUB)=0
3070 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3071 & MSUB(ISUB).EQ.1) THEN
3072 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3073 CALL PYSTOP(1)
3074 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3075 WRITE(MSTU(11),5300) ISUB
3076 CALL PYSTOP(1)
3077 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3078 WRITE(MSTU(11),5400) ISUB
3079 CALL PYSTOP(1)
3080 ELSEIF(MSUB(ISUB).EQ.1) THEN
3081 MINT(48)=MINT(48)+1
3082 ENDIF
3083 130 CONTINUE
3084
3085C...Stop or raise warning flag if no subprocesses on.
3086 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3087 IF(MSTP(127).NE.1) THEN
3088 WRITE(MSTU(11),5500)
3089 CALL PYSTOP(1)
3090 ELSE
3091 WRITE(MSTU(11),5700)
3092 MSTI(53)=1
3093 ENDIF
3094 ENDIF
3095 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3096 MSAV48=MSAV48+MINT(48)
3097
3098C...Reset variables for cross-section calculation.
3099 DO 150 I=0,500
3100 DO 140 J=1,3
3101 NGEN(I,J)=0
3102 XSEC(I,J)=0D0
3103 140 CONTINUE
3104 150 CONTINUE
3105
3106C...Find parametrized total cross-sections.
3107 CALL PYXTOT
3108 VINT(318)=VINT(317)
3109
3110C...Maxima of differential cross-sections.
3111 IF(MSTP(121).LE.1) CALL PYMAXI
3112
3113C...Initialize possibility of pileup events.
3114 IF(MINT(121).GT.1) MSTP(131)=0
3115 IF(MSTP(131).NE.0) CALL PYPILE(1)
3116
3117C...Initialize multiple interactions with variable impact parameter.
3118 IF(MINT(50).EQ.1) THEN
3119 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3120 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3121 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3122 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3123 MINT(35)=1
3124 CALL PYMULT(1)
3125 MINT(35)=3
3126 CALL PYMIGN(1)
3127 ENDIF
3128 ENDIF
3129
3130C...Save results for gamma-p and gamma-gamma alternatives.
3131 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3132 160 CONTINUE
3133
3134C...Initialization finished.
3135 IF(MSAV48.EQ.0) THEN
3136 IF(MSTP(127).NE.1) THEN
3137 WRITE(MSTU(11),5500)
3138 CALL PYSTOP(1)
3139 ELSE
3140 WRITE(MSTU(11),5700)
3141 MSTI(53)=1
3142 ENDIF
3143 ENDIF
3144 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3145
3146C...Formats for initialization information.
3147 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3148 &'routines',1X,17('*'))
3149 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3150 &'-',A6,' interactions.'/1X,'Execution stopped!')
3151 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3152 &1X,'Execution stopped!')
3153 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3154 &1X,'Execution stopped!')
3155 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3156 &1X,'Execution stopped.')
3157 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3158 &22('*'))
3159 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3160 &1X,'Execution will stop if you try to generate events.')
3161
3162 RETURN
3163 END
3164
3165C*********************************************************************
3166
3167C...PYEVNT
3168C...Administers the generation of a high-pT event via calls to
3169C...a number of subroutines.
3170
3171 SUBROUTINE PYEVNT
3172
3173C...Double precision and integer declarations.
3174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3175 IMPLICIT INTEGER(I-N)
3176 INTEGER PYK,PYCHGE,PYCOMP
3177 PARAMETER (MAXNUR=1000)
3178C...Commonblocks.
3179 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3180 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3181 COMMON/PYCTAG/NCT,MCT(4000,2)
3182 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3183 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3184 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3185 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3186 COMMON/PYINT1/MINT(400),VINT(400)
3187 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3188 COMMON/PYINT4/MWID(500),WIDS(500,5)
3189 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3190 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3191 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3192C...Local array.
3193 DIMENSION VTX(4)
3194
3195C...Optionally let PYEVNW do the whole job.
3196 IF(MSTP(81).GE.20) THEN
3197 CALL PYEVNW
3198 RETURN
3199 ENDIF
3200
3201C...Stop if no subprocesses on.
3202 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3203 WRITE(MSTU(11),5100)
3204 CALL PYSTOP(1)
3205 ENDIF
3206
3207C...Initial values for some counters.
3208 MSTU(1)=0
3209 MSTU(2)=0
3210 N=0
3211 MINT(5)=MINT(5)+1
3212 MINT(7)=0
3213 MINT(8)=0
3214 MINT(30)=0
3215 MINT(83)=0
3216 MINT(84)=MSTP(126)
3217 MSTU(24)=0
3218 MSTU70=0
3219 MSTJ14=MSTJ(14)
3220C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3221 NCT=0
3222 MINT(33)=0
3223
3224C...Let called routines know call is from PYEVNT (not PYEVNW).
3225 MINT(35)=1
3226 IF (MSTP(81).GE.10) MINT(35)=2
3227
3228C...If variable energies: redo incoming kinematics and cross-section.
3229 MSTI(61)=0
3230 IF(MSTP(171).EQ.1) THEN
3231 CALL PYINKI(1)
3232 IF(MSTI(61).EQ.1) THEN
3233 MINT(5)=MINT(5)-1
3234 RETURN
3235 ENDIF
3236 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3237 CALL PYXTOT
3238 ENDIF
3239
3240C...Loop over number of pileup events; check space left.
3241 IF(MSTP(131).LE.0) THEN
3242 NPILE=1
3243 ELSE
3244 CALL PYPILE(2)
3245 NPILE=MINT(81)
3246 ENDIF
3247 DO 270 IPILE=1,NPILE
3248 IF(MINT(84)+100.GE.MSTU(4)) THEN
3249 CALL PYERRM(11,
3250 & '(PYEVNT:) no more space in PYJETS for pileup events')
3251 IF(MSTU(21).GE.1) GOTO 280
3252 ENDIF
3253 MINT(82)=IPILE
3254
3255C...Generate variables of hard scattering.
3256 MINT(51)=0
3257 MSTI(52)=0
3258 100 CONTINUE
3259 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3260 MINT(31)=0
3261 MINT(39)=0
3262 MINT(51)=0
3263 MINT(57)=0
3264 CALL PYRAND
3265 IF(MSTI(61).EQ.1) THEN
3266 MINT(5)=MINT(5)-1
3267 RETURN
3268 ENDIF
3269 IF(MINT(51).EQ.2) RETURN
3270 ISUB=MINT(1)
3271 IF(MSTP(111).EQ.-1) GOTO 260
3272
3273C...Loopback point if PYPREP fails, especially for junction topologies.
3274 NPREP=0
3275 MNT31S=MINT(31)
3276 110 NPREP=NPREP+1
3277 MINT(31)=MNT31S
3278
3279 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3280C...Hard scattering (including low-pT):
3281C...reconstruct kinematics and colour flow of hard scattering.
3282 MINT31=MINT(31)
3283 120 MINT(31)=MINT31
3284 MINT(51)=0
3285 CALL PYSCAT
3286 IF(MINT(51).EQ.1) GOTO 100
3287 IPU1=MINT(84)+1
3288 IPU2=MINT(84)+2
3289 IF(ISUB.EQ.95) GOTO 140
3290
3291C...Reset statistics on activity in event.
3292 DO 130 J=351,359
3293 MINT(J)=0
3294 VINT(J)=0D0
3295 130 CONTINUE
3296
3297C...Showering of initial state partons (optional).
3298 NFIN=N
3299 ALAMSV=PARJ(81)
3300 PARJ(81)=PARP(72)
3301 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3302 & CALL PYSSPA(IPU1,IPU2)
3303 PARJ(81)=ALAMSV
3304 IF(MINT(51).EQ.1) GOTO 100
3305
3306C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3307 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3308 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3309 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3310 ENDIF
3311
3312C...Showering of final state partons (optional).
3313 ALAMSV=PARJ(81)
3314 PARJ(81)=PARP(72)
3315 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3316 & THEN
3317 IPU3=MINT(84)+3
3318 IPU4=MINT(84)+4
3319 IF(ISET(ISUB).EQ.5) IPU4=-3
3320 QMAX=VINT(55)
3321 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3322 CALL PYSHOW(IPU3,IPU4,QMAX)
3323 ELSEIF(ISET(ISUB).EQ.11) THEN
3324 CALL PYADSH(NFIN)
3325 ENDIF
3326 PARJ(81)=ALAMSV
3327
3328C...Allow possibility for user to abort event generation.
3329 IVETO=0
3330 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3331 IF(IVETO.EQ.1) GOTO 100
3332
3333C...Decay of final state resonances.
3334 MINT(32)=0
3335 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3336 IF(MINT(51).EQ.1) GOTO 100
3337 MINT(52)=N
3338
3339
3340C...Multiple interactions - PYTHIA 6.3 intermediate style.
3341 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3342 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3343 CALL PYMIGN(6)
3344 IF(MINT(51).EQ.1) GOTO 100
3345 MINT(53)=N
3346
3347C...Beam remnant flavour and colour assignments - new scheme.
3348 CALL PYMIHK
3349 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3350 & GOTO 120
3351 IF(MINT(51).EQ.1) GOTO 100
3352
3353C...Primordial kT and beam remnant momentum sharing - new scheme.
3354 CALL PYMIRM
3355 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3356 & GOTO 120
3357 IF(MINT(51).EQ.1) GOTO 100
3358 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3359
3360C...Multiple interactions - PYTHIA 6.2 style.
3361 ELSEIF(MINT(111).NE.12) THEN
3362 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3363 CALL PYMULT(6)
3364 MINT(53)=N
3365 ENDIF
3366
3367C...Hadron remnants and primordial kT.
3368 CALL PYREMN(IPU1,IPU2)
3369 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3370 & 110
3371 IF(MINT(51).EQ.1) GOTO 100
3372 ENDIF
3373
3374 ELSEIF(ISUB.NE.99) THEN
3375C...Diffractive and elastic scattering.
3376 CALL PYDIFF
3377
3378 ELSE
3379C...DIS scattering (photon flux external).
3380 CALL PYDISG
3381 IF(MINT(51).EQ.1) GOTO 100
3382 ENDIF
3383
3384C...Check that no odd resonance left undecayed.
3385 MINT(54)=N
3386 IF(MSTP(111).GE.1) THEN
3387 NFIX=N
3388 DO 150 I=MINT(84)+1,NFIX
3389 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3390 & K(I,2).NE.22) THEN
3391 KCA=PYCOMP(K(I,2))
3392 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3393 CALL PYRESD(I)
3394 IF(MINT(51).EQ.1) GOTO 100
3395 ENDIF
3396 ENDIF
3397 150 CONTINUE
3398 ENDIF
3399
3400C...Boost hadronic subsystem to overall rest frame.
3401C..(Only relevant when photon inside lepton beam.)
3402 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3403
3404C...Recalculate energies from momenta and masses (if desired).
3405 IF(MSTP(113).GE.1) THEN
3406 DO 160 I=MINT(83)+1,N
3407 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3408 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3409 160 CONTINUE
3410 NRECAL=N
3411 ENDIF
3412
3413C...Colour reconnection before string formation
3414 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3415
3416C...Rearrange partons along strings, check invariant mass cuts.
3417 MSTU(28)=0
3418 IF(MSTP(111).LE.0) MSTJ(14)=-1
3419 CALL PYPREP(MINT(84)+1)
3420 MSTJ(14)=MSTJ14
3421 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3422 MSTU(24)=0
3423 GOTO 100
3424 ENDIF
3425 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3426 IF (MINT(51).EQ.1) GOTO 100
3427 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3428 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3429 DO 190 I=MINT(84)+1,N
3430 IF(K(I,2).EQ.94) THEN
3431 DO 180 I1=I+1,MIN(N,I+10)
3432 IF(K(I1,3).EQ.I) THEN
3433 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3434 IF(K(I1,3).EQ.0) THEN
3435 DO 170 II=MINT(84)+1,I-1
3436 IF(K(II,2).EQ.K(I1,2)) THEN
3437 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3438 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3439 ENDIF
3440 170 CONTINUE
3441 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3442 ENDIF
3443 ENDIF
3444 180 CONTINUE
3445 ENDIF
3446 190 CONTINUE
3447 CALL PYEDIT(12)
3448 CALL PYEDIT(14)
3449 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3450 IF(MSTP(125).EQ.0) MINT(4)=0
3451 DO 210 I=MINT(83)+1,N
3452 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3453 DO 200 I1=I+1,N
3454 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3455 IF(K(I1,3).EQ.I) K(I,5)=I1
3456 200 CONTINUE
3457 ENDIF
3458 210 CONTINUE
3459 ENDIF
3460
3461C...Introduce separators between sections in PYLIST event listing.
3462 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3463 MSTU70=1
3464 MSTU(71)=N
3465 ELSEIF(IPILE.EQ.1) THEN
3466 MSTU70=3
3467 MSTU(71)=2
3468 MSTU(72)=MINT(4)
3469 MSTU(73)=N
3470 ENDIF
3471
3472C...Go back to lab frame (needed for vertices, also in fragmentation).
3473 CALL PYFRAM(1)
3474
3475C...Set nonvanishing production vertex (optional).
3476 IF(MSTP(151).EQ.1) THEN
3477 DO 220 J=1,4
3478 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3479 & SIN(PARU(2)*PYR(0))
3480 220 CONTINUE
3481 DO 240 I=MINT(83)+1,N
3482 DO 230 J=1,4
3483 V(I,J)=V(I,J)+VTX(J)
3484 230 CONTINUE
3485 240 CONTINUE
3486 ENDIF
3487
3488C...Perform hadronization (if desired).
3489 IF(MSTP(111).GE.1) THEN
3490 CALL PYEXEC
3491 IF(MSTU(24).NE.0) GOTO 100
3492 ENDIF
3493 IF(MSTP(113).GE.1) THEN
3494 DO 250 I=NRECAL,N
3495 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3496 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3497 250 CONTINUE
3498 ENDIF
3499 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3500
3501C...Store event information and calculate Monte Carlo estimates of
3502C...subprocess cross-sections.
3503 260 IF(IPILE.EQ.1) CALL PYDOCU
3504
3505C...Set counters for current pileup event and loop to next one.
3506 MSTI(41)=IPILE
3507 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3508 IF(MSTU70.LT.10) THEN
3509 MSTU70=MSTU70+1
3510 MSTU(70+MSTU70)=N
3511 ENDIF
3512 MINT(83)=N
3513 MINT(84)=N+MSTP(126)
3514 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3515 270 CONTINUE
3516
3517C...Generic information on pileup events. Reconstruct missing history.
3518 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3519 PARI(91)=VINT(132)
3520 PARI(92)=VINT(133)
3521 PARI(93)=VINT(134)
3522 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3523 ENDIF
3524 CALL PYEDIT(16)
3525
3526C...Transform to the desired coordinate frame.
3527 280 CALL PYFRAM(MSTP(124))
3528 MSTU(70)=MSTU70
3529 PARU(21)=VINT(1)
3530
3531C...Error messages
3532 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3533 &1X,'Execution stopped.')
3534
3535 RETURN
3536 END
3537
3538C*********************************************************************
3539
3540C...PYEVNW
3541C...Administers the generation of a high-pT event via calls to
3542C...a number of subroutines for the new multiple interactions and
3543C...showering framework.
3544
3545 SUBROUTINE PYEVNW
3546
3547C...Double precision and integer declarations.
3548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3549 IMPLICIT INTEGER(I-N)
3550 INTEGER PYK,PYCHGE,PYCOMP
3551 PARAMETER (MAXNUR=1000)
3552C...Commonblocks.
3553 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3554C...Commonblocks.
3555 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3556 COMMON/PYCTAG/NCT,MCT(4000,2)
3557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3559 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3560 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3561 COMMON/PYINT1/MINT(400),VINT(400)
3562 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3563 COMMON/PYINT4/MWID(500),WIDS(500,5)
3564 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3565 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3566 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3567 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3568 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3569 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3570C...Local arrays.
3571 DIMENSION VTX(4)
3572
3573C...Stop if no subprocesses on.
3574 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3575 WRITE(MSTU(11),5100)
3576 CALL PYSTOP(1)
3577 ENDIF
3578
3579C...Initial values for some counters.
3580 MSTU(1)=0
3581 MSTU(2)=0
3582 N=0
3583 MINT(5)=MINT(5)+1
3584 MINT(7)=0
3585 MINT(8)=0
3586 MINT(30)=0
3587 MINT(83)=0
3588 MINT(84)=MSTP(126)
3589 MSTU(24)=0
3590 MSTU70=0
3591 MSTJ14=MSTJ(14)
3592C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3593 NCT=0
3594 MINT(33)=0
3595C...Zero counters for pT-ordered showers (failsafe)
3596 NPART=0
3597 NPARTD=0
3598
3599C...Let called routines know call is from PYEVNW (not PYEVNT).
3600 MINT(35)=3
3601
3602C...If variable energies: redo incoming kinematics and cross-section.
3603 MSTI(61)=0
3604 IF(MSTP(171).EQ.1) THEN
3605 CALL PYINKI(1)
3606 IF(MSTI(61).EQ.1) THEN
3607 MINT(5)=MINT(5)-1
3608 RETURN
3609 ENDIF
3610 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3611 CALL PYXTOT
3612 ENDIF
3613
3614C...Loop over number of pileup events; check space left.
3615 IF(MSTP(131).LE.0) THEN
3616 NPILE=1
3617 ELSE
3618 CALL PYPILE(2)
3619 NPILE=MINT(81)
3620 ENDIF
3621 DO 300 IPILE=1,NPILE
3622 IF(MINT(84)+100.GE.MSTU(4)) THEN
3623 CALL PYERRM(11,
3624 & '(PYEVNW:) no more space in PYJETS for pileup events')
3625 IF(MSTU(21).GE.1) GOTO 310
3626 ENDIF
3627 MINT(82)=IPILE
3628
3629C...Generate variables of hard scattering.
3630 MINT(51)=0
3631 MSTI(52)=0
3632 LOOPHS =0
3633 100 CONTINUE
3634 LOOPHS = LOOPHS + 1
3635 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3636 IF(LOOPHS.GE.10) THEN
3637 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3638 & //'multiple interactions. Returning.')
3639 MINT(51)=1
3640 RETURN
3641 ENDIF
3642 MINT(31)=0
3643 MINT(39)=0
3644 MINT(36)=0
3645 MINT(51)=0
3646 MINT(57)=0
3647 CALL PYRAND
3648 IF(MSTI(61).EQ.1) THEN
3649 MINT(5)=MINT(5)-1
3650 RETURN
3651 ENDIF
3652 IF(MINT(51).EQ.2) RETURN
3653 ISUB=MINT(1)
3654 IF(MSTP(111).EQ.-1) GOTO 290
3655
3656C...Loopback point if PYPREP fails, especially for junction topologies.
3657 NPREP=0
3658 MNT31S=MINT(31)
3659 110 NPREP=NPREP+1
3660 MINT(31)=MNT31S
3661
3662 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3663C...Hard scattering (including low-pT):
3664C...reconstruct kinematics and colour flow of hard scattering.
3665 MINT31=MINT(31)
3666 120 MINT(31)=MINT31
3667 MINT(51)=0
3668 CALL PYSCAT
3669 IF(MINT(51).EQ.1) GOTO 100
3670 NPARTD=N
3671 NFIN=N
3672
3673C...Intertwined initial state showers and multiple interactions.
3674C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3675C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3676 MSTP61=MSTP(61)
3677 IF (MINT(47).LT.2) MSTP(61)=0
3678 MSTP81=MSTP(81)
3679 IF (MINT(50).EQ.0) MSTP(81)=0
3680 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3681 & MINT(111).NE.12) THEN
3682C...Absolute max pT2 scale for evolution: phase space limit.
3683 PT2MXS=0.25D0*VINT(2)
3684C...Check if more constrained by ISR and MI max scales:
3685 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3686C...Loopback point in case of failure in evolution.
3687 LOOP=0
3688 130 LOOP=LOOP+1
3689 MINT(51)=0
3690 IF(LOOP.GT.100) THEN
3691 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3692 & //'multiple interactions. Trying new point.')
3693 MINT(51)=1
3694 RETURN
3695 ENDIF
3696
3697C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3698C...once per event. (E.g. compute constants and save variables to be
3699C...restored later in case of failure.)
3700 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3701
3702C...Initialize interleaved MI/ISR/JI evolution.
3703C...PT2MAX: absolute upper limit for evolution - Initialization may
3704C... return a PT2MAX which is lower than this.
3705C...PT2MIN: absolute lower limit for evolution - Initialization may
3706C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3707 PT2MAX=PT2MXS
3708 PT2MIN=0D0
3709 CALL PYEVOL(0,PT2MAX,PT2MIN)
3710C...If failed to initialize evolution, generate a new hard process
3711 IF (MINT(51).EQ.1) GOTO 100
3712
3713C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3714C...In principle factorized, so can be stopped and restarted.
3715C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3716C PT2MED=MAX(10D0**2,PT2MIN)
3717C CALL PYEVOL(1,PT2MAX,PT2MED)
3718C IF (MINT(51).EQ.1) GOTO 160
3719C PT2MAX=PT2MED
3720 CALL PYEVOL(1,PT2MAX,PT2MIN)
3721C...If fatal error (e.g., massive hard-process initiator, but no available
3722C...phase space for creation), generate a new hard process
3723 IF (MINT(51).EQ.2) GOTO 100
3724C...If smaller error, just try running evolution again
3725 IF (MINT(51).EQ.1) GOTO 130
3726
3727C...Finalize interleaved MI/ISR/JI evolution.
3728 CALL PYEVOL(2,PT2MAX,PT2MIN)
3729 IF (MINT(51).EQ.1) GOTO 130
3730
3731 ENDIF
3732 MSTP(61)=MSTP61
3733 MSTP(81)=MSTP81
3734 IF(MINT(51).EQ.1) GOTO 100
3735C...(MINT(52) is actually obsolete in this routine. Set anyway
3736C...to ensure PYDOCU stable.)
3737 MINT(52)=N
3738 MINT(53)=N
3739
3740C...Beam remnants - new scheme.
3741 140 IF(MINT(50).EQ.1) THEN
3742 IF (ISUB.EQ.95) MINT(31)=1
3743
3744C...Beam remnant flavour and colour assignments - new scheme.
3745 CALL PYMIHK
3746 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3747 & GOTO 120
3748 IF(MINT(51).EQ.1) GOTO 100
3749
3750C...Primordial kT and beam remnant momentum sharing - new scheme.
3751 CALL PYMIRM
3752 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3753 & GOTO 120
3754 IF(MINT(51).EQ.1) GOTO 100
3755 IF (ISUB.EQ.95) MINT(31)=0
3756 ELSEIF(MINT(111).NE.12) THEN
3757C...Hadron remnants and primordial kT - old model.
3758C...Happens e.g. for direct photon on one side.
3759 IPU1=IMI(1,1,1)
3760 IPU2=IMI(2,1,1)
3761 CALL PYREMN(IPU1,IPU2)
3762 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3763 & 110
3764 IF(MINT(51).EQ.1) GOTO 100
3765C...PYREMN does not set colour tags for BRs, so needs to be done now.
3766 DO 160 I=MINT(53)+1,N
3767 DO 150 KCS=4,5
3768 IDA=MOD(K(I,KCS),MSTU(5))
3769 IF (IDA.NE.0) THEN
3770 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3771 ELSE
3772 MCT(I,KCS-3)=0
3773 ENDIF
3774 150 CONTINUE
3775 160 CONTINUE
3776C...Instruct PYPREP to use colour tags
3777 MINT(33)=1
3778
3779 DO 360 MQGST=1,2
3780 DO 350 I=MINT(84)+1,N
3781
3782C...Look for coloured string endpoint, or (later) leftover gluon.
3783 IF (K(I,1).NE.3) GOTO 350
3784 KC=PYCOMP(K(I,2))
3785 IF(KC.EQ.0) GOTO 350
3786 KQ=KCHG(KC,2)
3787 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3788
3789C... Pick up loose string end with no previous tag.
3790 KCS=4
3791 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3792 IF(MCT(I,KCS-3).NE.0) GOTO 350
3793
3794 CALL PYCTTR(I,KCS,I)
3795 IF(MINT(51).NE.0) RETURN
3796
3797 350 CONTINUE
3798 360 CONTINUE
3799C...Now delete any colour processing information if set (since partons
3800C...otherwise not FS showered!)
3801 DO 170 I=MINT(84)+1,N
3802 IF (I.LE.N) THEN
3803 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3804 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3805 ENDIF
3806 170 CONTINUE
3807 ENDIF
3808
3809C...Showering of final state partons (optional).
3810 ALAMSV=PARJ(81)
3811 PARJ(81)=PARP(72)
3812 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3813 & THEN
3814 QMAX=VINT(55)
3815 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3816 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3817C...External processes: handle successive showers.
3818 ELSEIF(ISET(ISUB).EQ.11) THEN
3819 CALL PYADSH(NFIN)
3820 ENDIF
3821 PARJ(81)=ALAMSV
3822
3823C...Allow possibility for user to abort event generation.
3824 IVETO=0
3825 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3826 IF(IVETO.EQ.1) THEN
3827C...........No reason to count this as an error
3828 LOOPHS = LOOPHS-1
3829 GOTO 100
3830 ENDIF
3831
3832
3833C...Decay of final state resonances.
3834 MINT(32)=0
3835 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3836 CALL PYRESD(0)
3837 IF(MINT(51).NE.0) GOTO 100
3838 ENDIF
3839
3840 IF(MINT(51).EQ.1) GOTO 100
3841
3842 ELSEIF(ISUB.NE.99) THEN
3843C...Diffractive and elastic scattering.
3844 CALL PYDIFF
3845
3846 ELSE
3847C...DIS scattering (photon flux external).
3848 CALL PYDISG
3849 IF(MINT(51).EQ.1) GOTO 100
3850 ENDIF
3851
3852C...Check that no odd resonance left undecayed.
3853 MINT(54)=N
3854 IF(MSTP(111).GE.1) THEN
3855 NFIX=N
3856 DO 180 I=MINT(84)+1,NFIX
3857 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3858 & K(I,2).NE.22) THEN
3859 KCA=PYCOMP(K(I,2))
3860 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3861 CALL PYRESD(I)
3862 IF(MINT(51).EQ.1) GOTO 100
3863 ENDIF
3864 ENDIF
3865 180 CONTINUE
3866 ENDIF
3867
3868C...Boost hadronic subsystem to overall rest frame.
3869C..(Only relevant when photon inside lepton beam.)
3870 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3871
3872C...Recalculate energies from momenta and masses (if desired).
3873 IF(MSTP(113).GE.1) THEN
3874 DO 190 I=MINT(83)+1,N
3875 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3876 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3877 190 CONTINUE
3878 NRECAL=N
3879 ENDIF
3880
3881C...Colour reconnection before string formation
3882 CALL PYFSCR(MINT(84)+1)
3883
3884C...Rearrange partons along strings, check invariant mass cuts.
3885 MSTU(28)=0
3886 IF(MSTP(111).LE.0) MSTJ(14)=-1
3887 CALL PYPREP(MINT(84)+1)
3888 MSTJ(14)=MSTJ14
3889 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3890 MSTU(24)=0
3891 GOTO 100
3892 ENDIF
3893 IF(MINT(51).EQ.1) GOTO 110
3894 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3895 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3896 DO 220 I=MINT(84)+1,N
3897 IF(K(I,2).EQ.94) THEN
3898 DO 210 I1=I+1,MIN(N,I+10)
3899 IF(K(I1,3).EQ.I) THEN
3900 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3901 IF(K(I1,3).EQ.0) THEN
3902 DO 200 II=MINT(84)+1,I-1
3903 IF(K(II,2).EQ.K(I1,2)) THEN
3904 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3905 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3906 ENDIF
3907 200 CONTINUE
3908 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3909 ENDIF
3910 ENDIF
3911 210 CONTINUE
3912CC...Also collapse particles decaying to themselves (if same KS)
3913 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3914 & .AND.K(I,4).LT.N) THEN
3915 IDA=K(I,4)
3916 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3917 K(I,1)=0
3918 ENDIF
3919 ENDIF
3920 220 CONTINUE
3921 CALL PYEDIT(12)
3922 CALL PYEDIT(14)
3923 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3924 IF(MSTP(125).EQ.0) MINT(4)=0
3925 DO 240 I=MINT(83)+1,N
3926 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3927 DO 230 I1=I+1,N
3928 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3929 IF(K(I1,3).EQ.I) K(I,5)=I1
3930 230 CONTINUE
3931 ENDIF
3932 240 CONTINUE
3933 ENDIF
3934
3935C...Introduce separators between sections in PYLIST event listing.
3936 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3937 MSTU70=1
3938 MSTU(71)=N
3939 ELSEIF(IPILE.EQ.1) THEN
3940 MSTU70=3
3941 MSTU(71)=2
3942 MSTU(72)=MINT(4)
3943 MSTU(73)=N
3944 ENDIF
3945
3946C...Go back to lab frame (needed for vertices, also in fragmentation).
3947 CALL PYFRAM(1)
3948
3949C...Set nonvanishing production vertex (optional).
3950 IF(MSTP(151).EQ.1) THEN
3951 DO 250 J=1,4
3952 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3953 & SIN(PARU(2)*PYR(0))
3954 250 CONTINUE
3955 DO 270 I=MINT(83)+1,N
3956 DO 260 J=1,4
3957 V(I,J)=V(I,J)+VTX(J)
3958 260 CONTINUE
3959 270 CONTINUE
3960 ENDIF
3961
3962C...Perform hadronization (if desired).
3963 IF(MSTP(111).GE.1) THEN
3964 CALL PYEXEC
3965 IF(MSTU(24).NE.0) GOTO 100
3966 ENDIF
3967 IF(MSTP(113).GE.1) THEN
3968 DO 280 I=NRECAL,N
3969 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3970 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3971 280 CONTINUE
3972 ENDIF
3973 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3974
3975C...Store event information and calculate Monte Carlo estimates of
3976C...subprocess cross-sections.
3977 290 IF(IPILE.EQ.1) CALL PYDOCU
3978
3979C...Set counters for current pileup event and loop to next one.
3980 MSTI(41)=IPILE
3981 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3982 IF(MSTU70.LT.10) THEN
3983 MSTU70=MSTU70+1
3984 MSTU(70+MSTU70)=N
3985 ENDIF
3986 MINT(83)=N
3987 MINT(84)=N+MSTP(126)
3988 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3989 300 CONTINUE
3990
3991C...Generic information on pileup events. Reconstruct missing history.
3992 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3993 PARI(91)=VINT(132)
3994 PARI(92)=VINT(133)
3995 PARI(93)=VINT(134)
3996 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3997 ENDIF
3998 CALL PYEDIT(16)
3999
4000C...Transform to the desired coordinate frame.
4001 310 CALL PYFRAM(MSTP(124))
4002 MSTU(70)=MSTU70
4003 PARU(21)=VINT(1)
4004
4005C...Error messages
4006 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4007 &1X,'Execution stopped.')
4008
4009 RETURN
4010 END
4011
4012
4013C***********************************************************************
4014
4015C...PYSTAT
4016C...Prints out information about cross-sections, decay widths, branching
4017C...ratios, kinematical limits, status codes and parameter values.
4018
4019 SUBROUTINE PYSTAT(MSTAT)
4020
4021C...Double precision and integer declarations.
4022 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4023 IMPLICIT INTEGER(I-N)
4024 INTEGER PYK,PYCHGE,PYCOMP
4025C...Parameter statement to help give large particle numbers.
4026 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4027 &KEXCIT=4000000,KDIMEN=5000000)
4028 PARAMETER (EPS=1D-3)
4029C...Commonblocks.
4030 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4031 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4032 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4033 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4034 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4035 COMMON/PYINT1/MINT(400),VINT(400)
4036 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4037 COMMON/PYINT4/MWID(500),WIDS(500,5)
4038 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4039 COMMON/PYINT6/PROC(0:500)
4040 CHARACTER PROC*28, CHTMP*16
4041 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4042 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4043 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4044 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4045C...Local arrays, character variables and data.
4046 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4047 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4048 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4049 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4050 CHARACTER*24 CHD0, CHDC(10)
4051 CHARACTER*6 DNAME(3)
4052 DATA PROGA/
4053 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4054 &'VMD/hadron * anomalous ','direct * direct ',
4055 &'direct * anomalous ','anomalous * anomalous '/
4056 DATA DISGA/'e * VMD','e * anomalous'/
4057 DATA PROGG9/
4058 &'direct * direct ','direct * VMD ',
4059 &'direct * anomalous ','VMD * direct ',
4060 &'VMD * VMD ','VMD * anomalous ',
4061 &'anomalous * direct ','anomalous * VMD ',
4062 &'anomalous * anomalous ','DIS * VMD ',
4063 &'DIS * anomalous ','VMD * DIS ',
4064 &'anomalous * DIS '/
4065 DATA PROGG4/
4066 &'direct * direct ','direct * resolved ',
4067 &'resolved * direct ','resolved * resolved '/
4068 DATA PROGG2/
4069 &'direct * hadron ','resolved * hadron '/
4070 DATA PROGP4/
4071 &'VMD * hadron ','direct * hadron ',
4072 &'anomalous * hadron ','DIS * hadron '/
4073 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4074 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4075 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4076 &' y*_small ',' eta*_large ',' eta*_small ',
4077 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4078 &' x_2 ',' x_F ',' cos(theta_hard) ',
4079 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4080 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4081 &' tau'' '/
4082 DATA DNAME /'q ','lepton','nu '/
4083
4084C...Cross-sections.
4085 IF(MSTAT.LE.1) THEN
4086 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4087 WRITE(MSTU(11),5000)
4088 WRITE(MSTU(11),5100)
4089 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4090 DO 100 I=1,500
4091 IF(MSUB(I).NE.1) GOTO 100
4092 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4093 100 CONTINUE
4094 IF(MINT(121).GT.1) THEN
4095 WRITE(MSTU(11),5300)
4096 DO 110 IGA=1,MINT(121)
4097 CALL PYSAVE(3,IGA)
4098 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4099 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4100 & XSEC(0,3)
4101 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4102 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4103 & XSEC(0,3)
4104 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4105 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4106 & XSEC(0,3)
4107 ELSEIF(MINT(121).EQ.4) THEN
4108 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4109 & XSEC(0,3)
4110 ELSEIF(MINT(121).EQ.2) THEN
4111 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4112 & XSEC(0,3)
4113 ELSE
4114 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4115 & XSEC(0,3)
4116 ENDIF
4117 110 CONTINUE
4118 CALL PYSAVE(5,0)
4119 ENDIF
4120 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4121 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4122
4123C...Decay widths and branching ratios.
4124 ELSEIF(MSTAT.EQ.2) THEN
4125 WRITE(MSTU(11),5500)
4126 WRITE(MSTU(11),5600)
4127 DO 140 KC=1,500
4128 KF=KCHG(KC,4)
4129 CALL PYNAME(KF,CHKF)
4130 IOFF=0
4131 IF(KC.LE.22) THEN
4132 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4133 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4134 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4135 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4136 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4137 ELSE
4138 IF(MWID(KC).LE.0) GOTO 140
4139 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4140 & KF/KSUSY1.EQ.2)) GOTO 140
4141 ENDIF
4142C...Off-shell branchings.
4143 IF(IOFF.EQ.1) THEN
4144 NGP=0
4145 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4146 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4147 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4148 DO 120 J=1,MDCY(KC,3)
4149 IDC=J+MDCY(KC,2)-1
4150 NGP1=0
4151 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4152 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4153 NGP2=0
4154 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4155 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4156 CALL PYNAME(KFDP(IDC,1),CHD1)
4157 CALL PYNAME(KFDP(IDC,2),CHD2)
4158 IF(KFDP(IDC,3).EQ.0) THEN
4159 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4160 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4161 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4162 ELSE
4163 CALL PYNAME(KFDP(IDC,3),CHD3)
4164 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4165 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4166 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4167 ENDIF
4168 120 CONTINUE
4169C...On-shell decays.
4170 ELSE
4171 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4172 BRFIN=1D0
4173 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4174 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4175 & STATE(MDCY(KC,1)),BRFIN
4176 DO 130 J=1,MDCY(KC,3)
4177 IDC=J+MDCY(KC,2)-1
4178 NGP1=0
4179 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4180 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4181 NGP2=0
4182 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4183 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4184 BRPRI=0D0
4185 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4186 BRFIN=0D0
4187 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4188 CALL PYNAME(KFDP(IDC,1),CHD1)
4189 CALL PYNAME(KFDP(IDC,2),CHD2)
4190 IF(KFDP(IDC,3).EQ.0) THEN
4191 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4192 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4193 & CHD2(1:10),WDTP(J),BRPRI,
4194 & STATE(MDME(IDC,1)),BRFIN
4195 ELSE
4196 CALL PYNAME(KFDP(IDC,3),CHD3)
4197 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4198 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4199 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4200 & STATE(MDME(IDC,1)),BRFIN
4201 ENDIF
4202 130 CONTINUE
4203 ENDIF
4204 140 CONTINUE
4205 WRITE(MSTU(11),6000)
4206
4207C...Allowed incoming partons/particles at hard interaction.
4208 ELSEIF(MSTAT.EQ.3) THEN
4209 WRITE(MSTU(11),6100)
4210 CALL PYNAME(MINT(11),CHAU)
4211 CHIN(1)=CHAU(1:12)
4212 CALL PYNAME(MINT(12),CHAU)
4213 CHIN(2)=CHAU(1:12)
4214 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4215 DO 150 I=-20,22
4216 IF(I.EQ.0) GOTO 150
4217 IA=IABS(I)
4218 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4219 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4220 CALL PYNAME(I,CHAU)
4221 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4222 & STATE(KFIN(2,I))
4223 150 CONTINUE
4224 WRITE(MSTU(11),6400)
4225
4226C...User-defined limits on kinematical variables.
4227 ELSEIF(MSTAT.EQ.4) THEN
4228 WRITE(MSTU(11),6500)
4229 WRITE(MSTU(11),6600)
4230 SHRMAX=CKIN(2)
4231 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4232 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4233 PTHMIN=MAX(CKIN(3),CKIN(5))
4234 PTHMAX=CKIN(4)
4235 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4236 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4237 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4238 DO 160 I=4,14
4239 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4240 160 CONTINUE
4241 SPRMAX=CKIN(32)
4242 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4243 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4244 WRITE(MSTU(11),7000)
4245
4246C...Status codes and parameter values.
4247 ELSEIF(MSTAT.EQ.5) THEN
4248 WRITE(MSTU(11),7100)
4249 WRITE(MSTU(11),7200)
4250 DO 170 I=1,100
4251 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4252 & PARP(100+I)
4253 170 CONTINUE
4254
4255C...List of all processes implemented in the program.
4256 ELSEIF(MSTAT.EQ.6) THEN
4257 WRITE(MSTU(11),7400)
4258 WRITE(MSTU(11),7500)
4259 DO 180 I=1,500
4260 IF(ISET(I).LT.0) GOTO 180
4261 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4262 180 CONTINUE
4263 WRITE(MSTU(11),7700)
4264
4265 ELSEIF(MSTAT.EQ.7) THEN
4266 WRITE (MSTU(11),8000)
4267 NMODES(0)=0
4268 NMODES(10)=0
4269 NMODES(9)=0
4270 DO 290 ILR=1,2
4271 DO 280 KFSM=1,16
4272 KFSUSY=ILR*KSUSY1+KFSM
4273 NRVDC=0
4274C...SDOWN DECAYS
4275 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4276 NRVDC=3
4277 DO 190 I=1,NRVDC
4278 PBRAT(I)=0D0
4279 NMODES(I)=0
4280 190 CONTINUE
4281 CALL PYNAME(KFSUSY,CHTMP)
4282 CHD0=CHTMP//' '
4283 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4284 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4285 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4286 KC=PYCOMP(KFSUSY)
4287 DO 200 J=1,MDCY(KC,3)
4288 IDC=J+MDCY(KC,2)-1
4289 ID1=IABS(KFDP(IDC,1))
4290 ID2=IABS(KFDP(IDC,2))
4291 IF (KFDP(IDC,3).EQ.0) THEN
4292 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4293 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4294 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4295 NMODES(1)=NMODES(1)+1
4296 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4297 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4298 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4299 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4300 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4301 NMODES(2)=NMODES(2)+1
4302 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4303 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4304 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4305 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4306 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4307 NMODES(3)=NMODES(3)+1
4308 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4309 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4310 ENDIF
4311 ENDIF
4312 200 CONTINUE
4313 ENDIF
4314C...SUP DECAYS
4315 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4316 NRVDC=2
4317 DO 210 I=1,NRVDC
4318 NMODES(I)=0
4319 PBRAT(I)=0D0
4320 210 CONTINUE
4321 CALL PYNAME(KFSUSY,CHTMP)
4322 CHD0=CHTMP//' '
4323 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4324 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4325 KC=PYCOMP(KFSUSY)
4326 DO 220 J=1,MDCY(KC,3)
4327 IDC=J+MDCY(KC,2)-1
4328 ID1=IABS(KFDP(IDC,1))
4329 ID2=IABS(KFDP(IDC,2))
4330 IF (KFDP(IDC,3).EQ.0) THEN
4331 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4332 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4333 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4334 NMODES(1)=NMODES(1)+1
4335 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4336 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4337 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4338 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4339 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4340 NMODES(2)=NMODES(2)+1
4341 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4342 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4343 ENDIF
4344 ENDIF
4345 220 CONTINUE
4346 ENDIF
4347C...SLEPTON DECAYS
4348 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4349 NRVDC=2
4350 DO 230 I=1,NRVDC
4351 PBRAT(I)=0D0
4352 NMODES(I)=0
4353 230 CONTINUE
4354 CALL PYNAME(KFSUSY,CHTMP)
4355 CHD0=CHTMP//' '
4356 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4357 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4358 KC=PYCOMP(KFSUSY)
4359 DO 240 J=1,MDCY(KC,3)
4360 IDC=J+MDCY(KC,2)-1
4361 ID1=IABS(KFDP(IDC,1))
4362 ID2=IABS(KFDP(IDC,2))
4363 IF (KFDP(IDC,3).EQ.0) THEN
4364 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4365 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4366 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4367 NMODES(1)=NMODES(1)+1
4368 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4369 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4370 ENDIF
4371 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4372 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4373 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4374 NMODES(2)=NMODES(2)+1
4375 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4376 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4377 ENDIF
4378 ENDIF
4379 240 CONTINUE
4380 ENDIF
4381C...SNEUTRINO DECAYS
4382 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4383 & THEN
4384 NRVDC=2
4385 DO 250 I=1,NRVDC
4386 PBRAT(I)=0D0
4387 NMODES(I)=0
4388 250 CONTINUE
4389 CALL PYNAME(KFSUSY,CHTMP)
4390 CHD0=CHTMP//' '
4391 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4392 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4393 KC=PYCOMP(KFSUSY)
4394 DO 260 J=1,MDCY(KC,3)
4395 IDC=J+MDCY(KC,2)-1
4396 ID1=IABS(KFDP(IDC,1))
4397 ID2=IABS(KFDP(IDC,2))
4398 IF (KFDP(IDC,3).EQ.0) THEN
4399 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4400 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4401 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4402 NMODES(1)=NMODES(1)+1
4403 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4404 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4405 ENDIF
4406 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4407 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4408 NMODES(2)=NMODES(2)+1
4409 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4410 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4411 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4412 ENDIF
4413 ENDIF
4414 260 CONTINUE
4415 ENDIF
4416 IF (NRVDC.NE.0) THEN
4417 DO 270 I=1,NRVDC
4418 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4419 NMODES(0)=NMODES(0)+NMODES(I)
4420 270 CONTINUE
4421 ENDIF
4422 280 CONTINUE
4423 290 CONTINUE
4424 DO 370 KFSM=21,37
4425 KFSUSY=KSUSY1+KFSM
4426 NRVDC=0
4427C...NEUTRALINO DECAYS
4428 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4429 NRVDC=4
4430 DO 300 I=1,NRVDC
4431 PBRAT(I)=0D0
4432 NMODES(I)=0
4433 300 CONTINUE
4434 CALL PYNAME(KFSUSY,CHTMP)
4435 CHD0=CHTMP//' '
4436 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4437 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4438 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4439 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4440 KC=PYCOMP(KFSUSY)
4441 DO 310 J=1,MDCY(KC,3)
4442 IDC=J+MDCY(KC,2)-1
4443 ID1=IABS(KFDP(IDC,1))
4444 ID2=IABS(KFDP(IDC,2))
4445 ID3=IABS(KFDP(IDC,3))
4446 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4447 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4448 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4449 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4450 NMODES(1)=NMODES(1)+1
4451 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4452 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4453 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4454 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4455 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4456 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4457 NMODES(2)=NMODES(2)+1
4458 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4459 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4460 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4461 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4462 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4463 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4464 NMODES(3)=NMODES(3)+1
4465 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4466 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4467 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4468 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4469 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4470 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4471 NMODES(4)=NMODES(4)+1
4472 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4473 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4474 ENDIF
4475 310 CONTINUE
4476 ENDIF
4477C...CHARGINO DECAYS
4478 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4479 NRVDC=5
4480 DO 320 I=1,NRVDC
4481 PBRAT(I)=0D0
4482 NMODES(I)=0
4483 320 CONTINUE
4484 CALL PYNAME(KFSUSY,CHTMP)
4485 CHD0=CHTMP//' '
4486 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4487 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4488 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4489 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4490 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4491 KC=PYCOMP(KFSUSY)
4492 DO 330 J=1,MDCY(KC,3)
4493 IDC=J+MDCY(KC,2)-1
4494 ID1=IABS(KFDP(IDC,1))
4495 ID2=IABS(KFDP(IDC,2))
4496 ID3=IABS(KFDP(IDC,3))
4497 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4498 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4499 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4500 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4501 NMODES(1)=NMODES(1)+1
4502 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4503 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4504 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4505 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4506 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4507 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4508 NMODES(1)=NMODES(1)+1
4509 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4510 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4511 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4512 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4513 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4514 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4515 NMODES(2)=NMODES(2)+1
4516 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4517 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4518 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4519 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4520 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4521 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4522 NMODES(3)=NMODES(3)+1
4523 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4524 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4525 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4526 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4527 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4528 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4529 NMODES(3)=NMODES(3)+1
4530 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4531 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4532 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4533 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4534 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4535 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4536 NMODES(4)=NMODES(4)+1
4537 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4538 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4539 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4540 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4541 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4542 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4543 NMODES(4)=NMODES(4)+1
4544 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4545 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4546 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4547 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4548 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4549 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4550 NMODES(5)=NMODES(5)+1
4551 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4552 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4553 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4554 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4555 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4556 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4557 NMODES(5)=NMODES(5)+1
4558 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4559 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4560 ENDIF
4561 330 CONTINUE
4562 ENDIF
4563C...GLUINO DECAYS
4564 IF (KFSM.EQ.21) THEN
4565 NRVDC=3
4566 DO 340 I=1,NRVDC
4567 PBRAT(I)=0D0
4568 NMODES(I)=0
4569 340 CONTINUE
4570 CALL PYNAME(KFSUSY,CHTMP)
4571 CHD0=CHTMP//' '
4572 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4573 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4574 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4575 KC=PYCOMP(KFSUSY)
4576 DO 350 J=1,MDCY(KC,3)
4577 IDC=J+MDCY(KC,2)-1
4578 ID1=IABS(KFDP(IDC,1))
4579 ID2=IABS(KFDP(IDC,2))
4580 ID3=IABS(KFDP(IDC,3))
4581 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4582 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4583 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4584 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4585 NMODES(1)=NMODES(1)+1
4586 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4587 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4588 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4589 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4590 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4591 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4592 NMODES(2)=NMODES(2)+1
4593 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4594 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4595 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4596 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4597 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4598 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4599 NMODES(3)=NMODES(3)+1
4600 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4601 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4602 ENDIF
4603 350 CONTINUE
4604 ENDIF
4605
4606 IF (NRVDC.NE.0) THEN
4607 DO 360 I=1,NRVDC
4608 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4609 NMODES(0)=NMODES(0)+NMODES(I)
4610 360 CONTINUE
4611 ENDIF
4612 370 CONTINUE
4613 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4614
4615 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4616 WRITE (MSTU(11),8500)
4617 DO 400 IRV=1,3
4618 DO 390 JRV=1,3
4619 DO 380 KRV=1,3
4620 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4621 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4622 380 CONTINUE
4623 390 CONTINUE
4624 400 CONTINUE
4625 WRITE (MSTU(11),8600)
4626 ENDIF
4627 ENDIF
4628
4629C...Formats for printouts.
4630 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4631 &'Events and Cross-sections',1X,9('*'))
4632 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4633 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4634 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4635 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4636 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4637 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4638 &'I',12X,'I')
4639 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4640 &D10.3,1X,'I')
4641 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4642 &1X,'I',34X,'I',28X,'I',12X,'I')
4643 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4644 &1X,'********* Total number of errors, excluding junctions =',
4645 &1X,I8,' *************'/
4646 &1X,'********* Total number of errors, including junctions =',
4647 &1X,I8,' *************'/
4648 &1X,'********* Total number of warnings = ',
4649 &1X,I8,' *************'/
4650 &1X,'********* Fraction of events that fail fragmentation ',
4651 &'cuts =',1X,F8.5,' *********'/)
4652 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4653 &'Ratios',1X,27('*'))
4654 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4655 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4656 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4657 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4658 &1X,98('='))
4659 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4660 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4661 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4662 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4663 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4664 &1P,D10.3,0P,1X,'I')
4665 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4666 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4667 &1P,D10.3,0P,1X,'I')
4668 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4669 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4670 &'Particles at Hard Interaction',1X,7('*'))
4671 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4672 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4673 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4674 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4675 &78('=')/1X,'I',38X,'I',37X,'I')
4676 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4677 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4678 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4679 &'Kinematical Variables',1X,12('*'))
4680 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4681 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4682 &16X,'I')
4683 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4684 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4685 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4686 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4687 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4688 &'Parameter Values',1X,12('*'))
4689 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4690 &'PARP(I)'/)
4691 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4692 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4693 &1X,13('*'))
4694 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4695 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4696 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4697 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4698 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4699 8000 FORMAT(1X/ 1X/
4700 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4701 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4702 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4703 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4704 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4705 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4706 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4707 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4708 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4709 & /1X,70('='))
4710 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4711 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4712 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4713 8500 FORMAT(1X/ 1X/
4714 & 1X,'R-Violating couplings',1X/ 1X /
4715 & 1X,55('=')/
4716 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4717 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4718 & ,'I',15X,'I',15X,'I',15X,'I')
4719 8600 FORMAT(1X,55('='))
4720 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4721 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4722
4723 RETURN
4724 END
4725
4726C*********************************************************************
4727
4728C...PYUPEV
4729C...Administers the hard-process generation required for output to the
4730C...Les Houches event record.
4731
4732 SUBROUTINE PYUPEV
4733
4734C...Double precision and integer declarations.
4735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4736 IMPLICIT INTEGER(I-N)
4737 INTEGER PYK,PYCHGE,PYCOMP
4738
4739C...Commonblocks.
4740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4741 COMMON/PYCTAG/NCT,MCT(4000,2)
4742 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4743 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4744 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4745 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4746 COMMON/PYINT1/MINT(400),VINT(400)
4747 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4748 COMMON/PYINT4/MWID(500),WIDS(500,5)
4749 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4750 &/PYINT1/,/PYINT2/,/PYINT4/
4751
4752C...HEPEUP for output.
4753 INTEGER MAXNUP
4754 PARAMETER (MAXNUP=500)
4755 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4756 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4757 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4758 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4759 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4760 SAVE /HEPEUP/
4761
4762C...Stop if no subprocesses on.
4763 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4764 WRITE(MSTU(11),5100)
4765 STOP
4766 ENDIF
4767
4768C...Special flags for hard-process generation only.
4769 MSTP71=MSTP(71)
4770 MSTP(71)=0
4771 MST128=MSTP(128)
4772 MSTP(128)=1
4773
4774C...Initial values for some counters.
4775 N=0
4776 MINT(5)=MINT(5)+1
4777 MINT(7)=0
4778 MINT(8)=0
4779 MINT(30)=0
4780 MINT(83)=0
4781 MINT(84)=MSTP(126)
4782 MSTU(24)=0
4783 MSTU70=0
4784 MSTJ14=MSTJ(14)
4785C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4786 MINT(33)=0
4787
4788C...If variable energies: redo incoming kinematics and cross-section.
4789 MSTI(61)=0
4790 IF(MSTP(171).EQ.1) THEN
4791 CALL PYINKI(1)
4792 IF(MSTI(61).EQ.1) THEN
4793 MINT(5)=MINT(5)-1
4794 RETURN
4795 ENDIF
4796 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4797 CALL PYXTOT
4798 ENDIF
4799
4800C...Do not allow pileup events.
4801 MINT(82)=1
4802
4803C...Generate variables of hard scattering.
4804 MINT(51)=0
4805 MSTI(52)=0
4806 100 CONTINUE
4807 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4808 MINT(31)=0
4809 MINT(51)=0
4810 MINT(57)=0
4811 CALL PYRAND
4812 IF(MSTI(61).EQ.1) THEN
4813 MINT(5)=MINT(5)-1
4814 RETURN
4815 ENDIF
4816 IF(MINT(51).EQ.2) RETURN
4817 ISUB=MINT(1)
4818
4819 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4820C...Hard scattering (including low-pT):
4821C...reconstruct kinematics and colour flow of hard scattering.
4822 MINT31=MINT(31)
4823 110 MINT(31)=MINT31
4824 MINT(51)=0
4825 CALL PYSCAT
4826 IF(MINT(51).EQ.1) GOTO 100
4827 IPU1=MINT(84)+1
4828 IPU2=MINT(84)+2
4829
4830C...Decay of final state resonances.
4831 MINT(32)=0
4832 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4833 & CALL PYRESD(0)
4834 IF(MINT(51).EQ.1) GOTO 100
4835 MINT(52)=N
4836
4837C...Longitudinal boost of hard scattering.
4838 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4839 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4840
4841 ELSEIF(ISUB.NE.99) THEN
4842C...Diffractive and elastic scattering.
4843 CALL PYDIFF
4844
4845 ELSE
4846C...DIS scattering (photon flux external).
4847 CALL PYDISG
4848 IF(MINT(51).EQ.1) GOTO 100
4849 ENDIF
4850
4851C...Check that no odd resonance left undecayed.
4852 MINT(54)=N
4853 NFIX=N
4854 DO 120 I=MINT(84)+1,NFIX
4855 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4856 & K(I,2).NE.22) THEN
4857 KCA=PYCOMP(K(I,2))
4858 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4859 CALL PYRESD(I)
4860 IF(MINT(51).EQ.1) GOTO 100
4861 ENDIF
4862 ENDIF
4863 120 CONTINUE
4864
4865C...Boost hadronic subsystem to overall rest frame.
4866C..(Only relevant when photon inside lepton beam.)
4867 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4868
4869C...Store event information and calculate Monte Carlo estimates of
4870C...subprocess cross-sections.
4871 130 CALL PYDOCU
4872
4873C...Transform to the desired coordinate frame.
4874 140 CALL PYFRAM(MSTP(124))
4875 MSTU(70)=MSTU70
4876 PARU(21)=VINT(1)
4877
4878C...Restore special flags for hard-process generation only.
4879 MSTP(71)=MSTP71
4880 MSTP(128)=MST128
4881
4882C...Trace colour tags; convert to LHA style labels.
4883 NCT=100
4884 DO 150 I=MINT(84)+1,N
4885 MCT(I,1)=0
4886 MCT(I,2)=0
4887 150 CONTINUE
4888 DO 160 I=MINT(84)+1,N
4889 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4890 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4891 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4892 & THEN
4893 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4894 IDA=MOD(K(I,4),MSTU(5))
4895 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4896 & MCT(IMO,2).NE.0) THEN
4897 MCT(I,1)=MCT(IMO,2)
4898 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4899 & MCT(IMO,1).NE.0) THEN
4900 MCT(I,1)=MCT(IMO,1)
4901 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4902 & MCT(IDA,2).NE.0) THEN
4903 MCT(I,1)=MCT(IDA,2)
4904 ELSE
4905 NCT=NCT+1
4906 MCT(I,1)=NCT
4907 ENDIF
4908 ENDIF
4909 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4910 & THEN
4911 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4912 IDA=MOD(K(I,5),MSTU(5))
4913 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4914 & MCT(IMO,1).NE.0) THEN
4915 MCT(I,2)=MCT(IMO,1)
4916 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4917 & MCT(IMO,2).NE.0) THEN
4918 MCT(I,2)=MCT(IMO,2)
4919 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4920 & MCT(IDA,1).NE.0) THEN
4921 MCT(I,2)=MCT(IDA,1)
4922 ELSE
4923 NCT=NCT+1
4924 MCT(I,2)=NCT
4925 ENDIF
4926 ENDIF
4927 ENDIF
4928 160 CONTINUE
4929
4930C...Put event in HEPEUP commonblock.
4931 NUP=N-MINT(84)
4932 IDPRUP=MINT(1)
4933 XWGTUP=1D0
4934 SCALUP=VINT(53)
4935 AQEDUP=VINT(57)
4936 AQCDUP=VINT(58)
4937 DO 180 I=1,NUP
4938 IDUP(I)=K(I+MINT(84),2)
4939 IF(I.LE.2) THEN
4940 ISTUP(I)=-1
4941 MOTHUP(1,I)=0
4942 MOTHUP(2,I)=0
4943 ELSEIF(K(I+4,3).EQ.0) THEN
4944 ISTUP(I)=1
4945 MOTHUP(1,I)=1
4946 MOTHUP(2,I)=2
4947 ELSE
4948 ISTUP(I)=1
4949 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4950 MOTHUP(2,I)=0
4951 ENDIF
4952 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4953 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4954 ICOLUP(1,I)=MCT(I+MINT(84),1)
4955 ICOLUP(2,I)=MCT(I+MINT(84),2)
4956 DO 170 J=1,5
4957 PUP(J,I)=P(I+MINT(84),J)
4958 170 CONTINUE
4959 VTIMUP(I)=V(I,5)
4960 SPINUP(I)=9D0
4961 180 CONTINUE
4962
4963C...Optionally write out event to disk. Minimal size for time/spin fields.
4964 IF(MSTP(162).GT.0) THEN
4965 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4966 DO 190 I=1,NUP
4967 IF(VTIMUP(I).EQ.0D0) THEN
4968 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4969 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4970 & ' 0. 9.'
4971 ELSE
4972 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4973 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4974 & VTIMUP(I),' 9.'
4975 ENDIF
4976 190 CONTINUE
4977
4978C...Optional extra line with parton-density information.
4979 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4980 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4981 ENDIF
4982
4983C...Error messages and other print formats.
4984 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4985 &1X,'Execution stopped.')
4986 5200 FORMAT(1P,2I6,4E14.6)
4987 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4988 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4989 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4990
4991 RETURN
4992 END
4993
4994C*********************************************************************
4995
4996C...PYUPIN
4997C...Fills the HEPRUP commonblock with info on incoming beams and allowed
4998C...processes, and optionally stores that information on file.
4999
5000 SUBROUTINE PYUPIN
5001
5002C...Double precision and integer declarations.
5003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5004 IMPLICIT INTEGER(I-N)
5005
5006C...Commonblocks.
5007 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5008 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5009 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5010 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5011 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5012
5013C...User process initialization commonblock.
5014 INTEGER MAXPUP
5015 PARAMETER (MAXPUP=100)
5016 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5017 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5018 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5019 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5020 &LPRUP(MAXPUP)
5021 SAVE /HEPRUP/
5022
5023C...Store info on incoming beams.
5024 IDBMUP(1)=K(1,2)
5025 IDBMUP(2)=K(2,2)
5026 EBMUP(1)=P(1,4)
5027 EBMUP(2)=P(2,4)
5028 PDFGUP(1)=0
5029 PDFGUP(2)=0
5030 PDFSUP(1)=MSTP(51)
5031 PDFSUP(2)=MSTP(51)
5032
5033C...Event weighting strategy.
5034 IDWTUP=3
5035
5036C...Info on individual processes.
5037 NPRUP=0
5038 DO 100 ISUB=1,500
5039 IF(MSUB(ISUB).EQ.1) THEN
5040 NPRUP=NPRUP+1
5041 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5042 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5043 XMAXUP(NPRUP)=1D0
5044 LPRUP(NPRUP)=ISUB
5045 ENDIF
5046 100 CONTINUE
5047
5048C...Write info to file.
5049 IF(MSTP(161).GT.0) THEN
5050 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5051 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5052 DO 110 IPR=1,NPRUP
5053 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5054 & LPRUP(IPR)
5055 110 CONTINUE
5056 ENDIF
5057
5058C...Formats for printout.
5059 5100 FORMAT(1P,2I8,2E14.6,6I6)
5060 5200 FORMAT(1P,3E14.6,I6)
5061
5062 RETURN
5063 END
5064
5065
5066C*********************************************************************
5067
5068C...Combine the two old-style Pythia initialization and event files
5069C...into a single Les Houches Event File.
5070
5071 SUBROUTINE PYLHEF
5072
5073C...Double precision and integer declarations.
5074 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5075 IMPLICIT INTEGER(I-N)
5076
5077C...PYTHIA commonblock: only used to provide read/write units and version.
5078 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5079 SAVE /PYPARS/
5080
5081C...User process initialization commonblock.
5082 INTEGER MAXPUP
5083 PARAMETER (MAXPUP=100)
5084 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5085 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5086 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5087 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5088 &LPRUP(MAXPUP)
5089 SAVE /HEPRUP/
5090
5091C...User process event common block.
5092 INTEGER MAXNUP
5093 PARAMETER (MAXNUP=500)
5094 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5095 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5096 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5097 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5098 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5099 SAVE /HEPEUP/
5100
5101C...Lines to read in assumed never longer than 200 characters.
5102 PARAMETER (MAXLEN=200)
5103 CHARACTER*(MAXLEN) STRING
5104
5105C...Format for reading lines.
5106 CHARACTER*6 STRFMT
5107 STRFMT='(A000)'
5108 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5109
5110C...Rewind initialization and event files.
5111 REWIND MSTP(161)
5112 REWIND MSTP(162)
5113
5114C...Write header info.
5115 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5116 WRITE(MSTP(163),'(A)') '<!--'
5117 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5118 &MSTP(181),'.',MSTP(182)
5119 WRITE(MSTP(163),'(A)') '-->'
5120
5121C...Read first line of initialization info and get number of processes.
5122 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5123 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5124 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5125
5126C...Copy initialization lines, omitting trailing blanks.
5127C...Embed in <init> ... </init> block.
5128 WRITE(MSTP(163),'(A)') '<init>'
5129 DO 140 IPR=0,NPRUP
5130 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5131 LEN=MAXLEN+1
5132 120 LEN=LEN-1
5133 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5134 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5135 140 CONTINUE
5136 WRITE(MSTP(163),'(A)') '</init>'
5137
5138C...Begin event loop. Read first line of event info or already done.
5139 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5140 200 CONTINUE
5141
5142C...Look at first line to know number of particles in event.
5143 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5144
5145C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5146 WRITE(MSTP(163),'(A)') '<event>'
5147 DO 240 I=0,NUP
5148 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5149 LEN=MAXLEN+1
5150 220 LEN=LEN-1
5151 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5152 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5153 240 CONTINUE
5154
5155C...Copy trailing comment lines - with a # in the first column - as is.
5156 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5157 IF(STRING(1:1).EQ.'#') THEN
5158 LEN=MAXLEN+1
5159 280 LEN=LEN-1
5160 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5161 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5162 GOTO 260
5163 ENDIF
5164
5165C..End the <event> block. Loop back to look for next event.
5166 WRITE(MSTP(163),'(A)') '</event>'
5167 GOTO 200
5168
5169C...Successfully reached end of event loop: write closing tag
5170C...and remove temporary intermediate files (unless asked not to).
5171 300 WRITE(MSTP(163),'(A)') '</event>'
5172 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5173 IF(MSTP(164).EQ.1) RETURN
5174 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5175 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5176 RETURN
5177
5178C...Error exit.
5179 400 WRITE(*,*) ' PYLHEF file joining failed!'
5180
5181 RETURN
5182 END
5183
5184C*********************************************************************
5185
5186C...PYINRE
5187C...Calculates full and effective widths of gauge bosons, stores
5188C...masses and widths, rescales coefficients to be used for
5189C...resonance production generation.
5190
5191 SUBROUTINE PYINRE
5192
5193C...Double precision and integer declarations.
5194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5195 IMPLICIT INTEGER(I-N)
5196 INTEGER PYK,PYCHGE,PYCOMP
5197C...Parameter statement to help give large particle numbers.
5198 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5199 &KEXCIT=4000000,KDIMEN=5000000)
5200C...Commonblocks.
5201 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5202 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5203 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5204 COMMON/PYDAT4/CHAF(500,2)
5205 CHARACTER CHAF*16
5206 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5207 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5208 COMMON/PYINT1/MINT(400),VINT(400)
5209 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5210 COMMON/PYINT4/MWID(500),WIDS(500,5)
5211 COMMON/PYINT6/PROC(0:500)
5212 CHARACTER PROC*28
5213 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5214 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5215 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5216C...Local arrays and data.
5217 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5218 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5219
5220C...Born level couplings in MSSM Higgs doublet sector.
5221 XW=PARU(102)
5222 XWV=XW
5223 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5224 XW1=1D0-XW
5225 IF(MSTP(4).EQ.2) THEN
5226 TANBE=PARU(141)
5227 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5228 SQMZ=PMAS(23,1)**2
5229 SQMW=PMAS(24,1)**2
5230 SQMH=PMAS(25,1)**2
5231 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5232 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5233 SQMHC=SQMA+SQMW
5234 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5235 WRITE(MSTU(11),5000)
5236 CALL PYSTOP(101)
5237 ENDIF
5238 PMAS(35,1)=SQRT(SQMHP)
5239 PMAS(36,1)=SQRT(SQMA)
5240 PMAS(37,1)=SQRT(SQMHC)
5241 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5242 & (SQMA-SQMZ)))
5243 BESU=ATAN(TANBE)
5244 PARU(142)=1D0
5245 PARU(143)=1D0
5246 PARU(161)=-SIN(ALSU)/COS(BESU)
5247 PARU(162)=COS(ALSU)/SIN(BESU)
5248 PARU(163)=PARU(161)
5249 PARU(164)=SIN(BESU-ALSU)
5250 PARU(165)=PARU(164)
5251 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5252 PARU(171)=COS(ALSU)/COS(BESU)
5253 PARU(172)=SIN(ALSU)/SIN(BESU)
5254 PARU(173)=PARU(171)
5255 PARU(174)=COS(BESU-ALSU)
5256 PARU(175)=PARU(174)
5257 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5258 & SIN(BESU+ALSU)
5259 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5260 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5261 PARU(181)=TANBE
5262 PARU(182)=1D0/TANBE
5263 PARU(183)=PARU(181)
5264 PARU(184)=0D0
5265 PARU(185)=PARU(184)
5266 PARU(186)=COS(BESU-ALSU)
5267 PARU(187)=SIN(BESU-ALSU)
5268 PARU(188)=PARU(186)
5269 PARU(189)=PARU(187)
5270 PARU(190)=0D0
5271 PARU(195)=COS(BESU-ALSU)
5272 ENDIF
5273
5274C...Reset effective widths of gauge bosons.
5275 DO 110 I=1,500
5276 DO 100 J=1,5
5277 WIDS(I,J)=1D0
5278 100 CONTINUE
5279 110 CONTINUE
5280
5281C...Order resonances by increasing mass (except Z0 and W+/-).
5282 NRES=0
5283 DO 140 KC=1,500
5284 KF=KCHG(KC,4)
5285 IF(KF.EQ.0) GOTO 140
5286 IF(MWID(KC).EQ.0) GOTO 140
5287 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5288 IF(MSTP(1).LE.3) GOTO 140
5289 ENDIF
5290 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5291 IF(IMSS(1).LE.0) GOTO 140
5292 ENDIF
5293 NRES=NRES+1
5294 PMRES=PMAS(KC,1)
5295 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5296 DO 120 I1=NRES-1,1,-1
5297 IF(PMRES.GE.PMORD(I1)) GOTO 130
5298 KCORD(I1+1)=KCORD(I1)
5299 PMORD(I1+1)=PMORD(I1)
5300 120 CONTINUE
5301 130 KCORD(I1+1)=KC
5302 PMORD(I1+1)=PMRES
5303 140 CONTINUE
5304
5305C...Loop over possible resonances.
5306 DO 180 I=1,NRES
5307 KC=KCORD(I)
5308 KF=KCHG(KC,4)
5309
5310C...Check that no fourth generation channels on by mistake.
5311 IF(MSTP(1).LE.3) THEN
5312 DO 150 J=1,MDCY(KC,3)
5313 IDC=J+MDCY(KC,2)-1
5314 KFA1=IABS(KFDP(IDC,1))
5315 KFA2=IABS(KFDP(IDC,2))
5316 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5317 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5318 & MDME(IDC,1)=-1
5319 150 CONTINUE
5320 ENDIF
5321
5322C...Check that no supersymmetric channels on by mistake.
5323 IF(IMSS(1).LE.0) THEN
5324 DO 160 J=1,MDCY(KC,3)
5325 IDC=J+MDCY(KC,2)-1
5326 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5327 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5328 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5329 & MDME(IDC,1)=-1
5330 160 CONTINUE
5331 ENDIF
5332
5333C...Find mass and evaluate width.
5334 PMR=PMAS(KC,1)
5335 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5336 IF(MWID(KC).EQ.3) MINT(63)=1
5337 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5338 MINT(51)=0
5339
5340C...Evaluate suppression factors due to non-simulated channels.
5341 IF(KCHG(KC,3).EQ.0) THEN
5342 WDTP0I=0D0
5343 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5344 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5345 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5346 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5347 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5348 WIDS(KC,3)=0D0
5349 WIDS(KC,4)=0D0
5350 WIDS(KC,5)=0D0
5351 ELSE
5352 IF(MWID(KC).EQ.3) MINT(63)=1
5353 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5354 MINT(51)=0
5355 WDTP0I=0D0
5356 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5357 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5358 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5359 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5360 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5361 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5362 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5363 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5364 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5365 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5366 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5367 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5368 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5369 ENDIF
5370
5371C...Set resonance widths and branching ratios;
5372C...also on/off switch for decays.
5373 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5374 PMAS(KC,2)=WDTP(0)
5375 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5376 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5377 DO 170 J=1,MDCY(KC,3)
5378 IDC=J+MDCY(KC,2)-1
5379 BRAT(IDC)=0D0
5380 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5381 170 CONTINUE
5382 ENDIF
5383 180 CONTINUE
5384
5385C...Flavours of leptoquark: redefine charge and name.
5386 KFLQQ=KFDP(MDCY(42,2),1)
5387 KFLQL=KFDP(MDCY(42,2),2)
5388 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5389 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5390 LL=1
5391 IF(IABS(KFLQL).EQ.13) LL=2
5392 IF(IABS(KFLQL).EQ.15) LL=3
5393 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5394 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5395 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5396
5397C...Special cases in treatment of gamma*/Z0: redefine process name.
5398 IF(MSTP(43).EQ.1) THEN
5399 PROC(1)='f + fbar -> gamma*'
5400 PROC(15)='f + fbar -> g + gamma*'
5401 PROC(19)='f + fbar -> gamma + gamma*'
5402 PROC(30)='f + g -> f + gamma*'
5403 PROC(35)='f + gamma -> f + gamma*'
5404 ELSEIF(MSTP(43).EQ.2) THEN
5405 PROC(1)='f + fbar -> Z0'
5406 PROC(15)='f + fbar -> g + Z0'
5407 PROC(19)='f + fbar -> gamma + Z0'
5408 PROC(30)='f + g -> f + Z0'
5409 PROC(35)='f + gamma -> f + Z0'
5410 ELSEIF(MSTP(43).EQ.3) THEN
5411 PROC(1)='f + fbar -> gamma*/Z0'
5412 PROC(15)='f + fbar -> g + gamma*/Z0'
5413 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5414 PROC(30)='f + g -> f + gamma*/Z0'
5415 PROC(35)='f + gamma -> f + gamma*/Z0'
5416 ENDIF
5417
5418C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5419 IF(MSTP(44).EQ.1) THEN
5420 PROC(141)='f + fbar -> gamma*'
5421 ELSEIF(MSTP(44).EQ.2) THEN
5422 PROC(141)='f + fbar -> Z0'
5423 ELSEIF(MSTP(44).EQ.3) THEN
5424 PROC(141)='f + fbar -> Z''0'
5425 ELSEIF(MSTP(44).EQ.4) THEN
5426 PROC(141)='f + fbar -> gamma*/Z0'
5427 ELSEIF(MSTP(44).EQ.5) THEN
5428 PROC(141)='f + fbar -> gamma*/Z''0'
5429 ELSEIF(MSTP(44).EQ.6) THEN
5430 PROC(141)='f + fbar -> Z0/Z''0'
5431 ELSEIF(MSTP(44).EQ.7) THEN
5432 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5433 ENDIF
5434
5435C...Special cases in treatment of WW -> WW: redefine process name.
5436 IF(MSTP(45).EQ.1) THEN
5437 PROC(77)='W+ + W+ -> W+ + W+'
5438 ELSEIF(MSTP(45).EQ.2) THEN
5439 PROC(77)='W+ + W- -> W+ + W-'
5440 ELSEIF(MSTP(45).EQ.3) THEN
5441 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5442 ENDIF
5443
5444C...Format for error information.
5445 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5446 &'combination'/1X,'Execution stopped!')
5447
5448 RETURN
5449 END
5450
5451C*********************************************************************
5452
5453C...PYINBM
5454C...Identifies the two incoming particles and the choice of frame.
5455
5456 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5457
5458C...Double precision and integer declarations.
5459 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5460 IMPLICIT INTEGER(I-N)
5461 INTEGER PYK,PYCHGE,PYCOMP
5462
5463C...User process initialization commonblock.
5464 INTEGER MAXPUP
5465 PARAMETER (MAXPUP=100)
5466 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5467 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5468 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5469 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5470 &LPRUP(MAXPUP)
5471 SAVE /HEPRUP/
5472
5473C...Commonblocks.
5474 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5475 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5476 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5477 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5478 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5479 COMMON/PYINT1/MINT(400),VINT(400)
5480 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5481
5482C...Local arrays, character variables and data.
5483 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5484 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5485 DIMENSION LEN(3),KCDE(39),PM(2)
5486 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5487 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5488 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5489 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5490 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5491 &'nu_taubar ','pi+ ','pi- ','n0 ',
5492 &'nbar0 ','p+ ','pbar- ','gamma ',
5493 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5494 &'xi- ','xi0 ','omega- ','pi0 ',
5495 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5496 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5497 &'k+ ','k- ','ks0 ','kl0 '/
5498 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5499 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5500 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5501
5502C...Store initial energy. Default frame.
5503 VINT(290)=WIN
5504 MINT(111)=0
5505
5506C...Special user process initialization; convert to normal input.
5507 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5508 MINT(111)=11
5509 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5510 CALL PYNAME(IDBMUP(1),CHNAME)
5511 CHBEAM=CHNAME(1:12)
5512 CALL PYNAME(IDBMUP(2),CHNAME)
5513 CHTARG=CHNAME(1:12)
5514 ENDIF
5515
5516C...Convert character variables to lowercase and find their length.
5517 CHCOM(1)=CHFRAM
5518 CHCOM(2)=CHBEAM
5519 CHCOM(3)=CHTARG
5520 DO 130 I=1,3
5521 LEN(I)=12
5522 DO 110 LL=12,1,-1
5523 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5524 DO 100 LA=1,26
5525 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5526 & CHALP(1)(LA:LA)
5527 100 CONTINUE
5528 110 CONTINUE
5529 CHIDNT(I)=CHCOM(I)
5530
5531C...Fix up bar, underscore and charge in particle name (if needed).
5532 DO 120 LL=1,10
5533 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5534 CHTEMP=CHIDNT(I)
5535 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5536 ENDIF
5537 120 CONTINUE
5538 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5539 CHTEMP=CHIDNT(I)
5540 CHIDNT(I)='nu_'//CHTEMP(3:7)
5541 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5542 CHIDNT(I)(1:3)='n0 '
5543 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5544 CHIDNT(I)(1:5)='nbar0'
5545 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5546 CHIDNT(I)(1:3)='p+ '
5547 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5548 & CHIDNT(I)(1:2).EQ.'p-') THEN
5549 CHIDNT(I)(1:5)='pbar-'
5550 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5551 CHIDNT(I)(7:7)='0'
5552 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5553 CHIDNT(I)(1:7)='reggeon'
5554 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5555 CHIDNT(I)(1:7)='pomeron'
5556 ENDIF
5557 130 CONTINUE
5558
5559C...Identify free initialization.
5560 IF(CHCOM(1)(1:2).EQ.'no') THEN
5561 MINT(65)=1
5562 RETURN
5563 ENDIF
5564
5565C...Identify incoming beam and target particles.
5566 DO 160 I=1,2
5567 DO 140 J=1,39
5568 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5569 140 CONTINUE
5570 PM(I)=PYMASS(MINT(10+I))
5571 VINT(2+I)=PM(I)
5572 MINT(140+I)=0
5573 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5574 CHTEMP=CHIDNT(I+1)(7:12)//' '
5575 DO 150 J=1,12
5576 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5577 150 CONTINUE
5578 PM(I)=PYMASS(MINT(140+I))
5579 VINT(302+I)=PM(I)
5580 ENDIF
5581 160 CONTINUE
5582 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5583 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5584 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5585
5586C...Identify choice of frame and input energies.
5587 CHINIT=' '
5588
5589C...Events defined in the CM frame.
5590 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5591 MINT(111)=1
5592 S=WIN**2
5593 IF(MSTP(122).GE.1) THEN
5594 IF(CHCOM(2)(1:1).NE.'e') THEN
5595 LOFFS=(31-(LEN(2)+LEN(3)))/2
5596 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5597 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5598 & ' collider'//' '
5599 ELSE
5600 LOFFS=(30-(LEN(2)+LEN(3)))/2
5601 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5602 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5603 & ' collider'//' '
5604 ENDIF
5605 WRITE(MSTU(11),5200) CHINIT
5606 WRITE(MSTU(11),5300) WIN
5607 ENDIF
5608
5609C...Events defined in fixed target frame.
5610 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5611 MINT(111)=2
5612 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5613 IF(MSTP(122).GE.1) THEN
5614 LOFFS=(29-(LEN(2)+LEN(3)))/2
5615 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5616 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5617 & ' fixed target'//' '
5618 WRITE(MSTU(11),5200) CHINIT
5619 WRITE(MSTU(11),5400) WIN
5620 WRITE(MSTU(11),5500) SQRT(S)
5621 ENDIF
5622
5623C...Frame defined by user three-vectors.
5624 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5625 MINT(111)=3
5626 P(1,5)=PM(1)
5627 P(2,5)=PM(2)
5628 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5629 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5630 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5631 & (P(1,3)+P(2,3))**2
5632 IF(MSTP(122).GE.1) THEN
5633 LOFFS=(22-(LEN(2)+LEN(3)))/2
5634 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5635 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5636 & ' user configuration'//' '
5637 WRITE(MSTU(11),5200) CHINIT
5638 WRITE(MSTU(11),5600)
5639 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5640 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5641 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5642 ENDIF
5643
5644C...Frame defined by user four-vectors.
5645 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5646 MINT(111)=4
5647 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5648 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5649 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5650 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5651 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5652 & (P(1,3)+P(2,3))**2
5653 IF(MSTP(122).GE.1) THEN
5654 LOFFS=(22-(LEN(2)+LEN(3)))/2
5655 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5656 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5657 & ' user configuration'//' '
5658 WRITE(MSTU(11),5200) CHINIT
5659 WRITE(MSTU(11),5600)
5660 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5661 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5662 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5663 ENDIF
5664
5665C...Frame defined by user five-vectors.
5666 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5667 MINT(111)=5
5668 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5669 & (P(1,3)+P(2,3))**2
5670 IF(MSTP(122).GE.1) THEN
5671 LOFFS=(22-(LEN(2)+LEN(3)))/2
5672 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5673 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5674 & ' user configuration'//' '
5675 WRITE(MSTU(11),5200) CHINIT
5676 WRITE(MSTU(11),5600)
5677 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5678 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5679 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5680 ENDIF
5681
5682C...Frame defined by HEPRUP common block.
5683 ELSEIF(MINT(111).GE.11) THEN
5684 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5685 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5686 IF(MSTP(122).GE.1) THEN
5687 LOFFS=(22-(LEN(2)+LEN(3)))/2
5688 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5689 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5690 & ' user configuration'//' '
5691 WRITE(MSTU(11),5200) CHINIT
5692 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5693 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5694 ENDIF
5695
5696C...Unknown frame. Error for too low CM energy.
5697 ELSE
5698 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5699 CALL PYSTOP(7)
5700 ENDIF
5701 IF(S.LT.PARP(2)**2) THEN
5702 WRITE(MSTU(11),5900) SQRT(S)
5703 CALL PYSTOP(7)
5704 ENDIF
5705
5706C...Formats for initialization and error information.
5707 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5708 &1X,'Execution stopped!')
5709 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5710 &1X,'Execution stopped!')
5711 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5712 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5713 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5714 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5715 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5716 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5717 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5718 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5719 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5720 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5721 &1X,'Execution stopped!')
5722 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5723 &'generation.'/1X,'Execution stopped!')
5724 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5725 &'GeV beam energies',13X,'I')
5726
5727 RETURN
5728 END
5729
5730C*********************************************************************
5731
5732C...PYINKI
5733C...Sets up kinematics, including rotations and boosts to/from CM frame.
5734
5735 SUBROUTINE PYINKI(MODKI)
5736
5737C...Double precision and integer declarations.
5738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5739 IMPLICIT INTEGER(I-N)
5740 INTEGER PYK,PYCHGE,PYCOMP
5741
5742C...User process initialization commonblock.
5743 INTEGER MAXPUP
5744 PARAMETER (MAXPUP=100)
5745 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5746 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5747 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5748 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5749 &LPRUP(MAXPUP)
5750 SAVE /HEPRUP/
5751
5752C...Commonblocks.
5753 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5756 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5757 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5758 COMMON/PYINT1/MINT(400),VINT(400)
5759 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5760
5761C...Set initial flavour state.
5762 N=2
5763 DO 100 I=1,2
5764 K(I,1)=1
5765 K(I,2)=MINT(10+I)
5766 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5767 100 CONTINUE
5768
5769C...Reset boost. Do kinematics for various cases.
5770 DO 110 J=6,10
5771 VINT(J)=0D0
5772 110 CONTINUE
5773
5774C...Set up kinematics for events defined in CM frame.
5775 IF(MINT(111).EQ.1) THEN
5776 WIN=VINT(290)
5777 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5778 S=WIN**2
5779 P(1,5)=VINT(3)
5780 P(2,5)=VINT(4)
5781 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5782 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5783 P(1,1)=0D0
5784 P(1,2)=0D0
5785 P(2,1)=0D0
5786 P(2,2)=0D0
5787 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5788 & (4D0*S))
5789 P(2,3)=-P(1,3)
5790 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5791 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5792
5793C...Set up kinematics for fixed target events.
5794 ELSEIF(MINT(111).EQ.2) THEN
5795 WIN=VINT(290)
5796 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5797 P(1,5)=VINT(3)
5798 P(2,5)=VINT(4)
5799 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5800 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5801 P(1,1)=0D0
5802 P(1,2)=0D0
5803 P(2,1)=0D0
5804 P(2,2)=0D0
5805 P(1,3)=WIN
5806 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5807 P(2,3)=0D0
5808 P(2,4)=P(2,5)
5809 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5810 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5811 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5812
5813C...Set up kinematics for events in user-defined frame.
5814 ELSEIF(MINT(111).EQ.3) THEN
5815 P(1,5)=VINT(3)
5816 P(2,5)=VINT(4)
5817 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5818 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5819 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5820 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5821 DO 120 J=1,3
5822 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5823 120 CONTINUE
5824 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5825 VINT(7)=PYANGL(P(1,1),P(1,2))
5826 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5827 VINT(6)=PYANGL(P(1,3),P(1,1))
5828 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5829 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5830
5831C...Set up kinematics for events with user-defined four-vectors.
5832 ELSEIF(MINT(111).EQ.4) THEN
5833 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5834 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5835 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5836 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5837 DO 130 J=1,3
5838 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5839 130 CONTINUE
5840 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5841 VINT(7)=PYANGL(P(1,1),P(1,2))
5842 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5843 VINT(6)=PYANGL(P(1,3),P(1,1))
5844 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5845 S=(P(1,4)+P(2,4))**2
5846
5847C...Set up kinematics for events with user-defined five-vectors.
5848 ELSEIF(MINT(111).EQ.5) THEN
5849 DO 140 J=1,3
5850 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5851 140 CONTINUE
5852 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5853 VINT(7)=PYANGL(P(1,1),P(1,2))
5854 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5855 VINT(6)=PYANGL(P(1,3),P(1,1))
5856 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5857 S=(P(1,4)+P(2,4))**2
5858
5859C...Set up kinematics for events with external user processes.
5860 ELSEIF(MINT(111).GE.11) THEN
5861 P(1,5)=VINT(3)
5862 P(2,5)=VINT(4)
5863 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5864 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5865 P(1,1)=0D0
5866 P(1,2)=0D0
5867 P(2,1)=0D0
5868 P(2,2)=0D0
5869 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5870 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5871 P(1,4)=EBMUP(1)
5872 P(2,4)=EBMUP(2)
5873 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5874 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5875 S=(P(1,4)+P(2,4))**2
5876 ENDIF
5877
5878C...Return or error for too low CM energy.
5879 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5880 IF(MSTP(172).LE.1) THEN
5881 CALL PYERRM(23,
5882 & '(PYINKI:) too low invariant mass in this event')
5883 ELSE
5884 MSTI(61)=1
5885 RETURN
5886 ENDIF
5887 ENDIF
5888
5889C...Save information on incoming particles.
5890 VINT(1)=SQRT(S)
5891 VINT(2)=S
5892 IF(MINT(111).GE.4) THEN
5893 IF(MINT(141).EQ.0) THEN
5894 VINT(3)=P(1,5)
5895 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5896 ELSE
5897 VINT(303)=P(1,5)
5898 ENDIF
5899 IF(MINT(142).EQ.0) THEN
5900 VINT(4)=P(2,5)
5901 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5902 ELSE
5903 VINT(304)=P(2,5)
5904 ENDIF
5905 ENDIF
5906 VINT(5)=P(1,3)
5907 IF(MODKI.EQ.0) VINT(289)=S
5908 DO 150 J=1,5
5909 V(1,J)=0D0
5910 V(2,J)=0D0
5911 VINT(290+J)=P(1,J)
5912 VINT(295+J)=P(2,J)
5913 150 CONTINUE
5914
5915C...Store pT cut-off and related constants to be used in generation.
5916 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5917 IF(MSTP(82).LE.1) THEN
5918 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5919 ELSE
5920 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5921 ENDIF
5922 VINT(149)=4D0*PTMN**2/S
5923 VINT(154)=PTMN
5924
5925 RETURN
5926 END
5927
5928C*********************************************************************
5929
5930C...PYINPR
5931C...Selects partonic subprocesses to be included in the simulation.
5932
5933 SUBROUTINE PYINPR
5934
5935C...Double precision and integer declarations.
5936 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5937 IMPLICIT INTEGER(I-N)
5938 INTEGER PYK,PYCHGE,PYCOMP
5939
5940C...User process initialization commonblock.
5941 INTEGER MAXPUP
5942 PARAMETER (MAXPUP=100)
5943 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5944 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5945 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5946 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5947 &LPRUP(MAXPUP)
5948 SAVE /HEPRUP/
5949
5950C...Commonblocks and character variables.
5951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5952 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5953 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5954 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5955 COMMON/PYINT1/MINT(400),VINT(400)
5956 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5957 COMMON/PYINT6/PROC(0:500)
5958 CHARACTER PROC*28
5959 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5960 &/PYINT6/
5961 CHARACTER CHIPR*10
5962
5963C...Reset processes to be included.
5964 IF(MSEL.NE.0) THEN
5965 DO 100 I=1,500
5966 MSUB(I)=0
5967 100 CONTINUE
5968 ENDIF
5969
5970C...Set running pTmin scale.
5971 IF(MSTP(82).LE.1) THEN
5972 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5973 ELSE
5974 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5975 ENDIF
5976
5977C...Begin by assuming incoming photon to enter subprocess.
5978 IF(MINT(11).EQ.22) MINT(15)=22
5979 IF(MINT(12).EQ.22) MINT(16)=22
5980
5981C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5982 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5983 MSUB(10)=1
5984 MINT(123)=MINT(122)+1
5985
5986C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5987C...allow mixture.
5988C...Here also set a few parameters otherwise normally not touched.
5989 ELSEIF(MINT(121).GT.1) THEN
5990
5991C...Parton distributions dampened at small Q2; go to low energies,
5992C...alpha_s <1; no minimum pT cut-off a priori.
5993 IF(MSTP(18).EQ.2) THEN
5994 MSTP(57)=3
5995 PARP(2)=2D0
5996 PARU(115)=1D0
5997 CKIN(5)=0.2D0
5998 CKIN(6)=0.2D0
5999 ENDIF
6000
6001C...Define pT cut-off parameters and whether run involves low-pT.
6002 PTMVMD=PTMRUN
6003 VINT(154)=PTMVMD
6004 PTMDIR=PTMVMD
6005 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6006 PTMANO=PTMVMD
6007 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6008 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6009 IPTL=1
6010 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6011 IF(MSEL.EQ.2) IPTL=1
6012
6013C...Set up for p/gamma * gamma; real or virtual photons.
6014 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6015 & MSTP(14).EQ.30)) THEN
6016
6017C...Set up for p/VMD * VMD.
6018 IF(MINT(122).EQ.1) THEN
6019 MINT(123)=2
6020 MSUB(11)=1
6021 MSUB(12)=1
6022 MSUB(13)=1
6023 MSUB(28)=1
6024 MSUB(53)=1
6025 MSUB(68)=1
6026 IF(IPTL.EQ.1) MSUB(95)=1
6027 IF(MSEL.EQ.2) THEN
6028 MSUB(91)=1
6029 MSUB(92)=1
6030 MSUB(93)=1
6031 MSUB(94)=1
6032 ENDIF
6033 IF(IPTL.EQ.1) CKIN(3)=0D0
6034
6035C...Set up for p/VMD * direct gamma.
6036 ELSEIF(MINT(122).EQ.2) THEN
6037 MINT(123)=0
6038 IF(MINT(121).EQ.6) MINT(123)=5
6039 MSUB(131)=1
6040 MSUB(132)=1
6041 MSUB(135)=1
6042 MSUB(136)=1
6043 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6044
6045C...Set up for p/VMD * anomalous gamma.
6046 ELSEIF(MINT(122).EQ.3) THEN
6047 MINT(123)=3
6048 IF(MINT(121).EQ.6) MINT(123)=7
6049 MSUB(11)=1
6050 MSUB(12)=1
6051 MSUB(13)=1
6052 MSUB(28)=1
6053 MSUB(53)=1
6054 MSUB(68)=1
6055 IF(IPTL.EQ.1) MSUB(95)=1
6056 IF(MSEL.EQ.2) THEN
6057 MSUB(91)=1
6058 MSUB(92)=1
6059 MSUB(93)=1
6060 MSUB(94)=1
6061 ENDIF
6062 IF(IPTL.EQ.1) CKIN(3)=0D0
6063
6064C...Set up for DIS * p.
6065 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6066 & IABS(MINT(12)).GT.100)) THEN
6067 MINT(123)=8
6068 IF(IPTL.EQ.1) MSUB(99)=1
6069
6070C...Set up for direct * direct gamma (switch off leptons).
6071 ELSEIF(MINT(122).EQ.4) THEN
6072 MINT(123)=0
6073 MSUB(137)=1
6074 MSUB(138)=1
6075 MSUB(139)=1
6076 MSUB(140)=1
6077 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6078 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6079 110 CONTINUE
6080 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6081
6082C...Set up for direct * anomalous gamma.
6083 ELSEIF(MINT(122).EQ.5) THEN
6084 MINT(123)=6
6085 MSUB(131)=1
6086 MSUB(132)=1
6087 MSUB(135)=1
6088 MSUB(136)=1
6089 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6090
6091C...Set up for anomalous * anomalous gamma.
6092 ELSEIF(MINT(122).EQ.6) THEN
6093 MINT(123)=3
6094 MSUB(11)=1
6095 MSUB(12)=1
6096 MSUB(13)=1
6097 MSUB(28)=1
6098 MSUB(53)=1
6099 MSUB(68)=1
6100 IF(IPTL.EQ.1) MSUB(95)=1
6101 IF(MSEL.EQ.2) THEN
6102 MSUB(91)=1
6103 MSUB(92)=1
6104 MSUB(93)=1
6105 MSUB(94)=1
6106 ENDIF
6107 IF(IPTL.EQ.1) CKIN(3)=0D0
6108 ENDIF
6109
6110C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6111 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6112
6113C...Set up for direct * direct gamma (switch off leptons).
6114 IF(MINT(122).EQ.1) THEN
6115 MINT(123)=0
6116 MSUB(137)=1
6117 MSUB(138)=1
6118 MSUB(139)=1
6119 MSUB(140)=1
6120 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6121 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6122 120 CONTINUE
6123 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6124
6125C...Set up for direct * VMD and VMD * direct gamma.
6126 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6127 MINT(123)=5
6128 MSUB(131)=1
6129 MSUB(132)=1
6130 MSUB(135)=1
6131 MSUB(136)=1
6132 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6133
6134C...Set up for direct * anomalous and anomalous * direct gamma.
6135 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6136 MINT(123)=6
6137 MSUB(131)=1
6138 MSUB(132)=1
6139 MSUB(135)=1
6140 MSUB(136)=1
6141 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6142
6143C...Set up for VMD*VMD.
6144 ELSEIF(MINT(122).EQ.5) THEN
6145 MINT(123)=2
6146 MSUB(11)=1
6147 MSUB(12)=1
6148 MSUB(13)=1
6149 MSUB(28)=1
6150 MSUB(53)=1
6151 MSUB(68)=1
6152 IF(IPTL.EQ.1) MSUB(95)=1
6153 IF(MSEL.EQ.2) THEN
6154 MSUB(91)=1
6155 MSUB(92)=1
6156 MSUB(93)=1
6157 MSUB(94)=1
6158 ENDIF
6159 IF(IPTL.EQ.1) CKIN(3)=0D0
6160
6161C...Set up for VMD * anomalous and anomalous * VMD gamma.
6162 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6163 MINT(123)=7
6164 MSUB(11)=1
6165 MSUB(12)=1
6166 MSUB(13)=1
6167 MSUB(28)=1
6168 MSUB(53)=1
6169 MSUB(68)=1
6170 IF(IPTL.EQ.1) MSUB(95)=1
6171 IF(MSEL.EQ.2) THEN
6172 MSUB(91)=1
6173 MSUB(92)=1
6174 MSUB(93)=1
6175 MSUB(94)=1
6176 ENDIF
6177 IF(IPTL.EQ.1) CKIN(3)=0D0
6178
6179C...Set up for anomalous * anomalous gamma.
6180 ELSEIF(MINT(122).EQ.9) THEN
6181 MINT(123)=3
6182 MSUB(11)=1
6183 MSUB(12)=1
6184 MSUB(13)=1
6185 MSUB(28)=1
6186 MSUB(53)=1
6187 MSUB(68)=1
6188 IF(IPTL.EQ.1) MSUB(95)=1
6189 IF(MSEL.EQ.2) THEN
6190 MSUB(91)=1
6191 MSUB(92)=1
6192 MSUB(93)=1
6193 MSUB(94)=1
6194 ENDIF
6195 IF(IPTL.EQ.1) CKIN(3)=0D0
6196
6197C...Set up for DIS * VMD and VMD * DIS gamma.
6198 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6199 MINT(123)=8
6200 IF(IPTL.EQ.1) MSUB(99)=1
6201
6202C...Set up for DIS * anomalous and anomalous * DIS gamma.
6203 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6204 MINT(123)=9
6205 IF(IPTL.EQ.1) MSUB(99)=1
6206 ENDIF
6207
6208C...Set up for gamma* * p; virtual photons = dir, res.
6209 ELSEIF(MINT(121).EQ.2) THEN
6210
6211C...Set up for direct * p.
6212 IF(MINT(122).EQ.1) THEN
6213 MINT(123)=0
6214 MSUB(131)=1
6215 MSUB(132)=1
6216 MSUB(135)=1
6217 MSUB(136)=1
6218 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6219
6220C...Set up for resolved * p.
6221 ELSEIF(MINT(122).EQ.2) THEN
6222 MINT(123)=1
6223 MSUB(11)=1
6224 MSUB(12)=1
6225 MSUB(13)=1
6226 MSUB(28)=1
6227 MSUB(53)=1
6228 MSUB(68)=1
6229 IF(IPTL.EQ.1) MSUB(95)=1
6230 IF(MSEL.EQ.2) THEN
6231 MSUB(91)=1
6232 MSUB(92)=1
6233 MSUB(93)=1
6234 MSUB(94)=1
6235 ENDIF
6236 IF(IPTL.EQ.1) CKIN(3)=0D0
6237 ENDIF
6238
6239C...Set up for gamma* * gamma*; virtual photons = dir, res.
6240 ELSEIF(MINT(121).EQ.4) THEN
6241
6242C...Set up for direct * direct gamma (switch off leptons).
6243 IF(MINT(122).EQ.1) THEN
6244 MINT(123)=0
6245 MSUB(137)=1
6246 MSUB(138)=1
6247 MSUB(139)=1
6248 MSUB(140)=1
6249 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6250 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6251 130 CONTINUE
6252 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6253
6254C...Set up for direct * resolved and resolved * direct gamma.
6255 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6256 MINT(123)=5
6257 MSUB(131)=1
6258 MSUB(132)=1
6259 MSUB(135)=1
6260 MSUB(136)=1
6261 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6262
6263C...Set up for resolved * resolved gamma.
6264 ELSEIF(MINT(122).EQ.4) THEN
6265 MINT(123)=2
6266 MSUB(11)=1
6267 MSUB(12)=1
6268 MSUB(13)=1
6269 MSUB(28)=1
6270 MSUB(53)=1
6271 MSUB(68)=1
6272 IF(IPTL.EQ.1) MSUB(95)=1
6273 IF(MSEL.EQ.2) THEN
6274 MSUB(91)=1
6275 MSUB(92)=1
6276 MSUB(93)=1
6277 MSUB(94)=1
6278 ENDIF
6279 IF(IPTL.EQ.1) CKIN(3)=0D0
6280 ENDIF
6281
6282C...End of special set up for gamma-p and gamma-gamma.
6283 ENDIF
6284 CKIN(1)=2D0*CKIN(3)
6285 ENDIF
6286
6287C...Flavour information for individual beams.
6288 DO 140 I=1,2
6289 MINT(40+I)=1
6290 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6291 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6292 MINT(44+I)=MINT(40+I)
6293 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6294 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6295 140 CONTINUE
6296
6297C...If two real gammas, whereof one direct, pick the first.
6298C...For two virtual photons, keep requested order.
6299 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6300 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6301 MINT(41)=1
6302 MINT(45)=1
6303 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6304 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6305 MINT(41)=1
6306 MINT(45)=1
6307 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6308 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6309 MINT(42)=1
6310 MINT(46)=1
6311 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6312 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6313 MINT(41)=1
6314 MINT(45)=1
6315 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6316 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6317 MINT(42)=1
6318 MINT(46)=1
6319 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6320 MINT(41)=1
6321 MINT(45)=1
6322 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6323 MINT(42)=1
6324 MINT(46)=1
6325 ENDIF
6326 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6327 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6328 IF(MINT(11).EQ.22) THEN
6329 MINT(41)=1
6330 MINT(45)=1
6331 ELSE
6332 MINT(42)=1
6333 MINT(46)=1
6334 ENDIF
6335 ENDIF
6336 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6337 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6338 ENDIF
6339
6340C...Flavour information on combination of incoming particles.
6341 MINT(43)=2*MINT(41)+MINT(42)-2
6342 MINT(44)=MINT(43)
6343 IF(MINT(123).LE.0) THEN
6344 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6345 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6346 ELSEIF(MINT(123).LE.3) THEN
6347 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6348 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6349 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6350 MINT(43)=4
6351 MINT(44)=1
6352 ENDIF
6353 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6354 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6355 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6356 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6357 MINT(50)=0
6358 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6359 MINT(107)=0
6360 MINT(108)=0
6361 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6362 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6363 & MINT(107)=2
6364 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6365 & MINT(107)=3
6366 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6367 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6368 & MINT(122).EQ.10) MINT(108)=2
6369 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6370 & MINT(122).EQ.11) MINT(108)=3
6371 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6372 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6373 IF(MINT(122).GE.3) MINT(107)=1
6374 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6375 ELSEIF(MINT(121).EQ.2) THEN
6376 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6377 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6378 ELSE
6379 IF(MINT(11).EQ.22) THEN
6380 MINT(107)=MINT(123)
6381 IF(MINT(123).GE.4) MINT(107)=0
6382 IF(MINT(123).EQ.7) MINT(107)=2
6383 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6384 IF(MSTP(14).EQ.28) MINT(107)=2
6385 IF(MSTP(14).EQ.29) MINT(107)=3
6386 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6387 & MINT(107)=4
6388 ENDIF
6389 IF(MINT(12).EQ.22) THEN
6390 MINT(108)=MINT(123)
6391 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6392 IF(MINT(123).EQ.7) MINT(108)=3
6393 IF(MSTP(14).EQ.26) MINT(108)=2
6394 IF(MSTP(14).EQ.27) MINT(108)=3
6395 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6396 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6397 & MINT(108)=4
6398 ENDIF
6399 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6400 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6401 MINTTP=MINT(107)
6402 MINT(107)=MINT(108)
6403 MINT(108)=MINTTP
6404 ENDIF
6405 ENDIF
6406 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6407 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6408
6409C...Select default processes according to incoming beams
6410C...(already done for gamma-p and gamma-gamma with
6411C...MSTP(14) = 10, 20, 25 or 30).
6412 IF(MINT(121).GT.1) THEN
6413 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6414
6415 IF(MINT(43).EQ.1) THEN
6416C...Lepton + lepton -> gamma/Z0 or W.
6417 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6418 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6419
6420 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6421 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6422C...Unresolved photon + lepton: Compton scattering.
6423 MSUB(133)=1
6424 MSUB(134)=1
6425
6426 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6427 & .OR.MINT(12).EQ.22)) THEN
6428C...DIS as pure gamma* + f -> f process.
6429 MSUB(99)=1
6430
6431 ELSEIF(MINT(43).LE.3) THEN
6432C...Lepton + hadron: deep inelastic scattering.
6433 MSUB(10)=1
6434
6435 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6436 & MINT(12).EQ.22) THEN
6437C...Two unresolved photons: fermion pair production,
6438C...exclude lepton pairs.
6439 DO 150 ISUB=137,140
6440 MSUB(ISUB)=1
6441 150 CONTINUE
6442 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6443 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6444 160 CONTINUE
6445 PTMDIR=PTMRUN
6446 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6447 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6448 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6449
6450 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6451 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6452 & MINT(12).EQ.22)) THEN
6453C...Unresolved photon + hadron: photon-parton scattering.
6454 DO 170 ISUB=131,136
6455 MSUB(ISUB)=1
6456 170 CONTINUE
6457
6458 ELSEIF(MSEL.EQ.1) THEN
6459C...High-pT QCD processes:
6460 MSUB(11)=1
6461 MSUB(12)=1
6462 MSUB(13)=1
6463 MSUB(28)=1
6464 MSUB(53)=1
6465 MSUB(68)=1
6466 PTMN=PTMRUN
6467 VINT(154)=PTMN
6468 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6469 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6470
6471 ELSE
6472C...All QCD processes:
6473 MSUB(11)=1
6474 MSUB(12)=1
6475 MSUB(13)=1
6476 MSUB(28)=1
6477 MSUB(53)=1
6478 MSUB(68)=1
6479 MSUB(91)=1
6480 MSUB(92)=1
6481 MSUB(93)=1
6482 MSUB(94)=1
6483 MSUB(95)=1
6484 ENDIF
6485
6486 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6487C...Heavy quark production.
6488 MSUB(81)=1
6489 MSUB(82)=1
6490 MSUB(84)=1
6491 DO 180 J=1,MIN(8,MDCY(21,3))
6492 MDME(MDCY(21,2)+J-1,1)=0
6493 180 CONTINUE
6494 MDME(MDCY(21,2)+MSEL-1,1)=1
6495 MSUB(85)=1
6496 DO 190 J=1,MIN(12,MDCY(22,3))
6497 MDME(MDCY(22,2)+J-1,1)=0
6498 190 CONTINUE
6499 MDME(MDCY(22,2)+MSEL-1,1)=1
6500
6501 ELSEIF(MSEL.EQ.10) THEN
6502C...Prompt photon production:
6503 MSUB(14)=1
6504 MSUB(18)=1
6505 MSUB(29)=1
6506
6507 ELSEIF(MSEL.EQ.11) THEN
6508C...Z0/gamma* production:
6509 MSUB(1)=1
6510
6511 ELSEIF(MSEL.EQ.12) THEN
6512C...W+/- production:
6513 MSUB(2)=1
6514
6515 ELSEIF(MSEL.EQ.13) THEN
6516C...Z0 + jet:
6517 MSUB(15)=1
6518 MSUB(30)=1
6519
6520 ELSEIF(MSEL.EQ.14) THEN
6521C...W+/- + jet:
6522 MSUB(16)=1
6523 MSUB(31)=1
6524
6525 ELSEIF(MSEL.EQ.15) THEN
6526C...Z0 & W+/- pair production:
6527 MSUB(19)=1
6528 MSUB(20)=1
6529 MSUB(22)=1
6530 MSUB(23)=1
6531 MSUB(25)=1
6532
6533 ELSEIF(MSEL.EQ.16) THEN
6534C...h0 production:
6535 MSUB(3)=1
6536 MSUB(102)=1
6537 MSUB(103)=1
6538 MSUB(123)=1
6539 MSUB(124)=1
6540
6541 ELSEIF(MSEL.EQ.17) THEN
6542C...h0 & Z0 or W+/- pair production:
6543 MSUB(24)=1
6544 MSUB(26)=1
6545
6546 ELSEIF(MSEL.EQ.18) THEN
6547C...h0 production; interesting processes in e+e-.
6548 MSUB(24)=1
6549 MSUB(103)=1
6550 MSUB(123)=1
6551 MSUB(124)=1
6552
6553 ELSEIF(MSEL.EQ.19) THEN
6554C...h0, H0 and A0 production; interesting processes in e+e-.
6555 MSUB(24)=1
6556 MSUB(103)=1
6557 MSUB(123)=1
6558 MSUB(124)=1
6559 MSUB(153)=1
6560 MSUB(171)=1
6561 MSUB(173)=1
6562 MSUB(174)=1
6563 MSUB(158)=1
6564 MSUB(176)=1
6565 MSUB(178)=1
6566 MSUB(179)=1
6567
6568 ELSEIF(MSEL.EQ.21) THEN
6569C...Z'0 production:
6570 MSUB(141)=1
6571
6572 ELSEIF(MSEL.EQ.22) THEN
6573C...W'+/- production:
6574 MSUB(142)=1
6575
6576 ELSEIF(MSEL.EQ.23) THEN
6577C...H+/- production:
6578 MSUB(143)=1
6579
6580 ELSEIF(MSEL.EQ.24) THEN
6581C...R production:
6582 MSUB(144)=1
6583
6584 ELSEIF(MSEL.EQ.25) THEN
6585C...LQ (leptoquark) production.
6586 MSUB(145)=1
6587 MSUB(162)=1
6588 MSUB(163)=1
6589 MSUB(164)=1
6590
6591 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6592C...Production of one heavy quark (W exchange):
6593 MSUB(83)=1
6594 DO 200 J=1,MIN(8,MDCY(21,3))
6595 MDME(MDCY(21,2)+J-1,1)=0
6596 200 CONTINUE
6597 MDME(MDCY(21,2)+MSEL-31,1)=1
6598
6599CMRENNA++Define SUSY alternatives.
6600 ELSEIF(MSEL.EQ.39) THEN
6601C...Turn on all SUSY processes.
6602 IF(MINT(43).EQ.4) THEN
6603C...Hadron-hadron processes.
6604 DO 210 I=201,301
6605 IF(ISET(I).GE.0) MSUB(I)=1
6606 210 CONTINUE
6607 ELSEIF(MINT(43).EQ.1) THEN
6608C...Lepton-lepton processes: QED production of squarks.
6609 DO 220 I=201,214
6610 MSUB(I)=1
6611 220 CONTINUE
6612 MSUB(210)=0
6613 MSUB(211)=0
6614 MSUB(212)=0
6615 DO 230 I=216,228
6616 MSUB(I)=1
6617 230 CONTINUE
6618 DO 240 I=261,263
6619 MSUB(I)=1
6620 240 CONTINUE
6621 MSUB(277)=1
6622 MSUB(278)=1
6623 ENDIF
6624
6625 ELSEIF(MSEL.EQ.40) THEN
6626C...Gluinos and squarks.
6627 IF(MINT(43).EQ.4) THEN
6628 MSUB(243)=1
6629 MSUB(244)=1
6630 MSUB(258)=1
6631 MSUB(259)=1
6632 MSUB(261)=1
6633 MSUB(262)=1
6634 MSUB(264)=1
6635 MSUB(265)=1
6636 DO 250 I=271,296
6637 MSUB(I)=1
6638 250 CONTINUE
6639 ELSEIF(MINT(43).EQ.1) THEN
6640 MSUB(277)=1
6641 MSUB(278)=1
6642 ENDIF
6643
6644 ELSEIF(MSEL.EQ.41) THEN
6645C...Stop production.
6646 MSUB(261)=1
6647 MSUB(262)=1
6648 MSUB(263)=1
6649 IF(MINT(43).EQ.4) THEN
6650 MSUB(264)=1
6651 MSUB(265)=1
6652 ENDIF
6653
6654 ELSEIF(MSEL.EQ.42) THEN
6655C...Slepton production.
6656 DO 260 I=201,214
6657 MSUB(I)=1
6658 260 CONTINUE
6659 IF(MINT(43).NE.4) THEN
6660 MSUB(210)=0
6661 MSUB(211)=0
6662 MSUB(212)=0
6663 ENDIF
6664
6665 ELSEIF(MSEL.EQ.43) THEN
6666C...Neutralino/Chargino + Gluino/Squark.
6667 IF(MINT(43).EQ.4) THEN
6668 DO 270 I=237,242
6669 MSUB(I)=1
6670 270 CONTINUE
6671 DO 280 I=246,254
6672 MSUB(I)=1
6673 280 CONTINUE
6674 MSUB(256)=1
6675 ENDIF
6676
6677 ELSEIF(MSEL.EQ.44) THEN
6678C...Neutralino/Chargino pair production.
6679 IF(MINT(43).EQ.4) THEN
6680 DO 290 I=216,236
6681 MSUB(I)=1
6682 290 CONTINUE
6683 ELSEIF(MINT(43).EQ.1) THEN
6684 DO 300 I=216,228
6685 MSUB(I)=1
6686 300 CONTINUE
6687 ENDIF
6688
6689 ELSEIF(MSEL.EQ.45) THEN
6690C...Sbottom production.
6691 MSUB(287)=1
6692 MSUB(288)=1
6693 IF(MINT(43).EQ.4) THEN
6694 DO 310 I=281,296
6695 MSUB(I)=1
6696 310 CONTINUE
6697 ENDIF
6698
6699 ELSEIF(MSEL.EQ.50) THEN
6700C...Pair production of technipions and gauge bosons.
6701 DO 320 I=361,368
6702 MSUB(I)=1
6703 320 CONTINUE
6704 IF(MINT(43).EQ.4) THEN
6705 DO 330 I=370,377
6706 MSUB(I)=1
6707 330 CONTINUE
6708 ENDIF
6709
6710 ELSEIF(MSEL.EQ.51) THEN
6711C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6712 DO 340 I=381,386
6713 MSUB(I)=1
6714 340 CONTINUE
6715
6716 ELSEIF(MSEL.EQ.61) THEN
6717C...Charmonium production in colour octet model, with recoiling parton.
6718 DO 342 I=421,439
6719 MSUB(I)=1
6720 342 CONTINUE
6721
6722 ELSEIF(MSEL.EQ.62) THEN
6723C...Bottomonium production in colour octet model, with recoiling parton.
6724 DO 344 I=461,479
6725 MSUB(I)=1
6726 344 CONTINUE
6727
6728 ELSEIF(MSEL.EQ.63) THEN
6729C...Charmonium and bottomonium production in colour octet model.
6730 DO 346 I=421,439
6731 MSUB(I)=1
6732 MSUB(I+40)=1
6733 346 CONTINUE
6734 ENDIF
6735
6736C...Find heaviest new quark flavour allowed in processes 81-84.
6737 KFLQM=1
6738 DO 350 I=1,MIN(8,MDCY(21,3))
6739 IDC=I+MDCY(21,2)-1
6740 IF(MDME(IDC,1).LE.0) GOTO 350
6741 KFLQM=I
6742 350 CONTINUE
6743 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6744 &KFLQM=MSTP(7)
6745 MINT(55)=KFLQM
6746 KFPR(81,1)=KFLQM
6747 KFPR(81,2)=KFLQM
6748 KFPR(82,1)=KFLQM
6749 KFPR(82,2)=KFLQM
6750 KFPR(83,1)=KFLQM
6751 KFPR(84,1)=KFLQM
6752 KFPR(84,2)=KFLQM
6753
6754C...Find heaviest new fermion flavour allowed in process 85.
6755 KFLFM=1
6756 DO 360 I=1,MIN(12,MDCY(22,3))
6757 IDC=I+MDCY(22,2)-1
6758 IF(MDME(IDC,1).LE.0) GOTO 360
6759 KFLFM=KFDP(IDC,1)
6760 360 CONTINUE
6761 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6762 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6763 MINT(56)=KFLFM
6764 KFPR(85,1)=KFLFM
6765 KFPR(85,2)=KFLFM
6766
6767C...Import relevant information on external user processes.
6768 IF(MINT(111).GE.11) THEN
6769 IPYPR=0
6770 DO 390 IUP=1,NPRUP
6771C...Find next empty PYTHIA process number slot and enable it.
6772 370 IPYPR=IPYPR+1
6773 IF(IPYPR.GT.500) CALL PYERRM(26,
6774 & '(PYINPR.) no more empty slots for user processes')
6775 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6776 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6777 ISET(IPYPR)=11
6778C...Overwrite KFPR with references back to process number and ID.
6779 KFPR(IPYPR,1)=IUP
6780 KFPR(IPYPR,2)=LPRUP(IUP)
6781C...Process title.
6782 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6783 ICHIN=1
6784 DO 380 ICH=1,9
6785 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6786 380 CONTINUE
6787 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6788C...Switch on process.
6789 MSUB(IPYPR)=1
6790 390 CONTINUE
6791 ENDIF
6792
6793 RETURN
6794 END
6795
6796C*********************************************************************
6797
6798C...PYXTOT
6799C...Parametrizes total, elastic and diffractive cross-sections
6800C...for different energies and beams. Donnachie-Landshoff for
6801C...total and Schuler-Sjostrand for elastic and diffractive.
6802C...Process code IPROC:
6803C...= 1 : p + p;
6804C...= 2 : pbar + p;
6805C...= 3 : pi+ + p;
6806C...= 4 : pi- + p;
6807C...= 5 : pi0 + p;
6808C...= 6 : phi + p;
6809C...= 7 : J/psi + p;
6810C...= 11 : rho + rho;
6811C...= 12 : rho + phi;
6812C...= 13 : rho + J/psi;
6813C...= 14 : phi + phi;
6814C...= 15 : phi + J/psi;
6815C...= 16 : J/psi + J/psi;
6816C...= 21 : gamma + p (DL);
6817C...= 22 : gamma + p (VDM).
6818C...= 23 : gamma + pi (DL);
6819C...= 24 : gamma + pi (VDM);
6820C...= 25 : gamma + gamma (DL);
6821C...= 26 : gamma + gamma (VDM).
6822
6823 SUBROUTINE PYXTOT
6824
6825C...Double precision and integer declarations.
6826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6827 IMPLICIT INTEGER(I-N)
6828 INTEGER PYK,PYCHGE,PYCOMP
6829C...Commonblocks.
6830 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6831 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6832 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6833 COMMON/PYINT1/MINT(400),VINT(400)
6834 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6835 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6836 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6837C...Local arrays.
6838 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6839 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6840 &CEFFD(10,9),SIGTMP(6,0:5)
6841
6842C...Common constants.
6843 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6844 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6845 &FACDD/0.0084D0/
6846
6847C...Number of multiple processes to be evaluated (= 0 : undefined).
6848 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6849C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6850 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6851 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6852 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6853 DATA YPAR/
6854 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6855 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6856 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6857
6858C...Beam and target hadron class:
6859C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6860 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6861 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6862C...Characteristic class masses, slope parameters, beta = sqrt(X).
6863 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6864 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6865 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6866
6867C...Fitting constants used in parametrizations of diffractive results.
6868 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6869 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6870 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6871 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6872 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6873 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6874 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6875 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6876 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6877 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6878 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6879 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6880 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6881 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6882 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6883 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6884 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6885 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6886 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6887 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6888 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6889 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6890 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6891 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6892 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6893 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6894 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6895 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6896 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6897
6898C...Parameters. Combinations of the energy.
6899 AEM=PARU(101)
6900 PMTH=PARP(102)
6901 S=VINT(2)
6902 SRT=VINT(1)
6903 SEPS=S**EPS
6904 SETA=S**ETA
6905 SLOG=LOG(S)
6906
6907C...Ratio of gamma/pi (for rescaling in parton distributions).
6908 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6909 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6910 VINT(317)=1D0
6911 IF(MINT(50).NE.1) RETURN
6912
6913C...Order flavours of incoming particles: KF1 < KF2.
6914 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6915 KF1=IABS(MINT(11))
6916 KF2=IABS(MINT(12))
6917 IORD=1
6918 ELSE
6919 KF1=IABS(MINT(12))
6920 KF2=IABS(MINT(11))
6921 IORD=2
6922 ENDIF
6923 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6924
6925C...Find process number (for lookup tables).
6926 IF(KF1.GT.1000) THEN
6927 IPROC=1
6928 IF(ISGN12.LT.0) IPROC=2
6929 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6930 IPROC=3
6931 IF(ISGN12.LT.0) IPROC=4
6932 IF(KF1.EQ.111) IPROC=5
6933 ELSEIF(KF1.GT.100) THEN
6934 IPROC=11
6935 ELSEIF(KF2.GT.1000) THEN
6936 IPROC=21
6937 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6938 ELSEIF(KF2.GT.100) THEN
6939 IPROC=23
6940 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6941 ELSE
6942 IPROC=25
6943 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6944 ENDIF
6945
6946C... Number of multiple processes to be stored; beam/target side.
6947 NPR=NPROC(IPROC)
6948 MINT(101)=1
6949 MINT(102)=1
6950 IF(NPR.EQ.3) THEN
6951 MINT(100+IORD)=4
6952 ELSEIF(NPR.EQ.6) THEN
6953 MINT(101)=4
6954 MINT(102)=4
6955 ENDIF
6956 N1=0
6957 IF(MINT(101).EQ.4) N1=4
6958 N2=0
6959 IF(MINT(102).EQ.4) N2=4
6960
6961C...Do not do any more for user-set or undefined cross-sections.
6962 IF(MSTP(31).LE.0) RETURN
6963 IF(NPR.EQ.0) CALL PYERRM(26,
6964 &'(PYXTOT:) cross section for this process not yet implemented')
6965
6966C...Parameters. Combinations of the energy.
6967 AEM=PARU(101)
6968 PMTH=PARP(102)
6969 S=VINT(2)
6970 SRT=VINT(1)
6971 SEPS=S**EPS
6972 SETA=S**ETA
6973 SLOG=LOG(S)
6974
6975C...Loop over multiple processes (for VDM).
6976 DO 110 I=1,NPR
6977 IF(NPR.EQ.1) THEN
6978 IPR=IPROC
6979 ELSEIF(NPR.EQ.3) THEN
6980 IPR=I+4
6981 IF(KF2.LT.1000) IPR=I+10
6982 ELSEIF(NPR.EQ.6) THEN
6983 IPR=I+10
6984 ENDIF
6985
6986C...Evaluate hadron species, mass, slope contribution and fit number.
6987 IHA=IHADA(IPR)
6988 IHB=IHADB(IPR)
6989 PMA=PMHAD(IHA)
6990 PMB=PMHAD(IHB)
6991 BHA=BHAD(IHA)
6992 BHB=BHAD(IHB)
6993 ISD=IFITSD(IPR)
6994 IDD=IFITDD(IPR)
6995
6996C...Skip if energy too low relative to masses.
6997 DO 100 J=0,5
6998 SIGTMP(I,J)=0D0
6999 100 CONTINUE
7000 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7001
7002C...Total cross-section. Elastic slope parameter and cross-section.
7003 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7004 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7005 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7006
7007C...Diffractive scattering A + B -> X + B.
7008 BSD=2D0*BHB
7009 SQML=(PMA+PMTH)**2
7010 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7011 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7012 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7013 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7014 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7015 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7016 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7017
7018C...Diffractive scattering A + B -> A + X.
7019 BSD=2D0*BHA
7020 SQML=(PMB+PMTH)**2
7021 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7022 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7023 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7024 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7025 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7026 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7027 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7028
7029C...Order single diffractive correctly.
7030 IF(IORD.EQ.2) THEN
7031 SIGSAV=SIGTMP(I,2)
7032 SIGTMP(I,2)=SIGTMP(I,3)
7033 SIGTMP(I,3)=SIGSAV
7034 ENDIF
7035
7036C...Double diffractive scattering A + B -> X1 + X2.
7037 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7038 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7039 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7040 IF(YEFF.LE.0) SUM1=0D0
7041 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7042 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7043 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7044 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7045 & (2D0*ALP)
7046 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7047 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7048 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7049 & (2D0*ALP)
7050 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7051 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7052 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7053 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7054 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7055
7056C...Non-diffractive by unitarity.
7057 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7058 & SIGTMP(I,4)
7059 110 CONTINUE
7060
7061C...Put temporary results in output array: only one process.
7062 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7063 DO 120 J=0,5
7064 SIGT(0,0,J)=SIGTMP(1,J)
7065 120 CONTINUE
7066
7067C...Beam multiple processes.
7068 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7069 IF(MINT(107).EQ.2) THEN
7070 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7071 ELSE
7072 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7073 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7074 ENDIF
7075 IF(MSTP(20).GT.0) THEN
7076 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7077 ENDIF
7078 DO 140 I=1,4
7079 IF(MINT(107).EQ.2) THEN
7080 CONV=(AEM/PARP(160+I))*VINT(317)
7081 ELSEIF(VINT(154).GT.PARP(15)) THEN
7082 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7083 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7084 ELSE
7085 CONV=0D0
7086 ENDIF
7087 I1=MAX(1,I-1)
7088 DO 130 J=0,5
7089 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7090 130 CONTINUE
7091 140 CONTINUE
7092 DO 150 J=0,5
7093 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7094 150 CONTINUE
7095
7096C...Target multiple processes.
7097 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7098 IF(MINT(108).EQ.2) THEN
7099 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7100 ELSE
7101 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7102 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7103 ENDIF
7104 IF(MSTP(20).GT.0) THEN
7105 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7106 ENDIF
7107 DO 170 I=1,4
7108 IF(MINT(108).EQ.2) THEN
7109 CONV=(AEM/PARP(160+I))*VINT(317)
7110 ELSEIF(VINT(154).GT.PARP(15)) THEN
7111 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7112 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7113 ELSE
7114 CONV=0D0
7115 ENDIF
7116 IV=MAX(1,I-1)
7117 DO 160 J=0,5
7118 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7119 160 CONTINUE
7120 170 CONTINUE
7121 DO 180 J=0,5
7122 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7123 180 CONTINUE
7124
7125C...Both beam and target multiple processes.
7126 ELSE
7127 IF(MINT(107).EQ.2) THEN
7128 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7129 ELSE
7130 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7131 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7132 ENDIF
7133 IF(MINT(108).EQ.2) THEN
7134 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7135 ELSE
7136 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7137 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7138 ENDIF
7139 IF(MSTP(20).GT.0) THEN
7140 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7141 & VINT(308)))**MSTP(20)
7142 ENDIF
7143 DO 210 I1=1,4
7144 DO 200 I2=1,4
7145 IF(MINT(107).EQ.2) THEN
7146 CONV=(AEM/PARP(160+I1))*VINT(317)
7147 ELSEIF(VINT(154).GT.PARP(15)) THEN
7148 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7149 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7150 ELSE
7151 CONV=0D0
7152 ENDIF
7153 IF(MINT(108).EQ.2) THEN
7154 CONV=CONV*(AEM/PARP(160+I2))
7155 ELSEIF(VINT(154).GT.PARP(15)) THEN
7156 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7157 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7158 ELSE
7159 CONV=0D0
7160 ENDIF
7161 IF(I1.LE.2) THEN
7162 IV=MAX(1,I2-1)
7163 ELSEIF(I2.LE.2) THEN
7164 IV=MAX(1,I1-1)
7165 ELSEIF(I1.EQ.I2) THEN
7166 IV=2*I1-2
7167 ELSE
7168 IV=5
7169 ENDIF
7170 DO 190 J=0,5
7171 JV=J
7172 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7173 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7174 190 CONTINUE
7175 200 CONTINUE
7176 210 CONTINUE
7177 DO 230 J=0,5
7178 DO 220 I=1,4
7179 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7180 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7181 220 CONTINUE
7182 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7183 230 CONTINUE
7184 ENDIF
7185
7186C...Scale up uniformly for Donnachie-Landshoff parametrization.
7187 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7188 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7189 DO 260 I1=0,N1
7190 DO 250 I2=0,N2
7191 DO 240 J=0,5
7192 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7193 240 CONTINUE
7194 250 CONTINUE
7195 260 CONTINUE
7196 ENDIF
7197
7198 RETURN
7199 END
7200
7201C*********************************************************************
7202
7203C...PYMAXI
7204C...Finds optimal set of coefficients for kinematical variable selection
7205C...and the maximum of the part of the differential cross-section used
7206C...in the event weighting.
7207
7208 SUBROUTINE PYMAXI
7209
7210C...Double precision and integer declarations.
7211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7212 IMPLICIT INTEGER(I-N)
7213 INTEGER PYK,PYCHGE,PYCOMP
7214C...Parameter statement to help give large particle numbers.
7215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7216 &KEXCIT=4000000,KDIMEN=5000000)
7217
7218C...User process initialization commonblock.
7219 INTEGER MAXPUP
7220 PARAMETER (MAXPUP=100)
7221 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7222 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7223 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7224 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7225 &LPRUP(MAXPUP)
7226 SAVE /HEPRUP/
7227
7228C...Commonblocks.
7229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7230 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7231 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7232 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7233 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7234 COMMON/PYINT1/MINT(400),VINT(400)
7235 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7236 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7237 COMMON/PYINT4/MWID(500),WIDS(500,5)
7238 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7239 COMMON/PYINT6/PROC(0:500)
7240 CHARACTER PROC*28
7241 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7242 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7243 COMMON/PYTCCO/COEFX(194:380,2)
7244 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7245 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7246 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7247 &/PYTCSM/,/TCPARA/
7248C...Local arrays, character variables and data.
7249 LOGICAL IOK
7250 CHARACTER CVAR(4)*4
7251 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7252 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7253 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7254 &IQ(9),IP(9)
7255 DATA CVAR/'tau ','tau''','y* ','cth '/
7256 DATA SIGSSM/3*0D0/
7257
7258C...Initial values and loop over subprocesses.
7259 NPOSI=0
7260 VINT(143)=1D0
7261 VINT(144)=1D0
7262 XSEC(0,1)=0D0
7263 ITECH=0
7264 DO 460 ISUB=1,500
7265 MINT(1)=ISUB
7266 MINT(51)=0
7267
7268C...Find maximum weight factors for photon flux.
7269 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7270 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7271 ENDIF
7272
7273C...Select subprocess to study: skip cases not applicable.
7274 IF(ISET(ISUB).EQ.11) THEN
7275 IF(MSUB(ISUB).NE.1) GOTO 460
7276C...User process intialization: cross section model dependent.
7277 IF(IABS(IDWTUP).EQ.1) THEN
7278 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7279 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7280 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7281 ELSE
7282 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7283 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7284 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7285 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7286 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7287 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7288 ENDIF
7289 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7290 & WTGAGA*XSEC(ISUB,1)
7291 NPOSI=NPOSI+1
7292 GOTO 450
7293 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7294 CALL PYSIGH(NCHN,SIGS)
7295 XSEC(ISUB,1)=SIGS
7296 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7297 & WTGAGA*XSEC(ISUB,1)
7298 IF(MSUB(ISUB).NE.1) GOTO 460
7299 NPOSI=NPOSI+1
7300 GOTO 450
7301 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7302 CALL PYSIGH(NCHN,SIGS)
7303 XSEC(ISUB,1)=SIGS
7304 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7305 & WTGAGA*XSEC(ISUB,1)
7306 IF(XSEC(ISUB,1).EQ.0D0) THEN
7307 MSUB(ISUB)=0
7308 ELSE
7309 NPOSI=NPOSI+1
7310 ENDIF
7311 GOTO 450
7312 ELSEIF(ISUB.EQ.96) THEN
7313 IF(MINT(50).EQ.0) GOTO 460
7314 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7315 & GOTO 460
7316 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7317 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7318 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7319 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7320 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7321 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7322 ELSE
7323 IF(MSUB(ISUB).NE.1) GOTO 460
7324 ENDIF
7325 ISTSB=ISET(ISUB)
7326 IF(ISUB.EQ.96) ISTSB=2
7327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7328 MWTXS=0
7329 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7330 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7331
7332C...Find resonances (explicit or implicit in cross-section).
7333 MINT(72)=0
7334 KFR1=0
7335 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7336 KFR1=KFPR(ISUB,1)
7337 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7338 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7339 KFR1=23
7340 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7341 & .OR.ISUB.EQ.177) THEN
7342 KFR1=24
7343 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7344 KFR1=25
7345 IF(MSTP(46).EQ.5) THEN
7346 KFR1=89
7347 PMAS(89,1)=PARP(45)
7348 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7349 ENDIF
7350 ENDIF
7351 CKMX=CKIN(2)
7352 IF(CKMX.LE.0D0) CKMX=VINT(1)
7353 KCR1=PYCOMP(KFR1)
7354 IF(KFR1.NE.0) THEN
7355 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7356 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7357 ENDIF
7358 IF(KFR1.NE.0) THEN
7359 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7360 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7361 MINT(72)=1
7362 MINT(73)=KFR1
7363 VINT(73)=TAUR1
7364 VINT(74)=GAMR1
7365 ENDIF
7366 KFR2=0
7367 KFR3=0
7368 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7369 $ (ISUB.GE.361.AND.ISUB.LE.380))
7370 $ THEN
7371 KFR2=23
7372 IF(ISUB.EQ.141) THEN
7373 KCR2=PYCOMP(KFR2)
7374 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7375 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7376 KFR2=0
7377 ELSE
7378 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7379 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7380 MINT(72)=2
7381 MINT(74)=KFR2
7382 VINT(75)=TAUR2
7383 VINT(76)=GAMR2
7384 ENDIF
7385 ELSEIF(ITECH.EQ.0) THEN
7386 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7387 ITECH=1
7388 KFR1=KTECHN+113
7389 KCR1=PYCOMP(KFR1)
7390 KFR2=KTECHN+223
7391 KCR2=PYCOMP(KFR2)
7392 KFR3=KTECHN+115
7393 KCR3=PYCOMP(KFR3)
7394 IRES=0
7395C...Order the resonances
7396 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7397 KCT=KCR3
7398 KCR3=KCR2
7399 KCR2=KCT
7400 ENDIF
7401 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7402 KCT=KCR3
7403 KCR3=KCR1
7404 KCR1=KCT
7405 ENDIF
7406 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7407 KCT=KCR2
7408 KCR2=KCR1
7409 KCR1=KCT
7410 ENDIF
7411 DO 101 I=1,3
7412 IF(I.EQ.1) THEN
7413 SHN0=PMAS(KCR1,1)**2
7414 ELSEIF(I.EQ.2) THEN
7415 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7416 SHN0=PMAS(KCR2,1)**2
7417 ELSEIF(I.EQ.3) THEN
7418 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7419 SHN0=PMAS(KCR3,1)**2
7420 ENDIF
7421 AEM=PYALEM(SHN0)
7422 FAR=SQRT(AEM/ALPRHT)
7423 SHN=SHN0*(1D0-FAR)
7424 CALL PYTECM(SHN,S1,WIDO,1)
7425 RES=SHN-S1
7426 SHN=S1*.99D0
7427 SHSTEP=2D0
7428 102 SHN=SHN+SHSTEP
7429 CALL PYTECM(SHN,S1,WIDO,1)
7430 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7431 IOK=.FALSE.
7432 IF(IRES.GT.0) THEN
7433 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7434 ELSEIF(IRES.EQ.0) THEN
7435 IOK=.TRUE.
7436 ENDIF
7437 IF(IOK) THEN
7438 IRES=IRES+1
7439 XMAS(IRES)=SQRT(S1)
7440 XWID(IRES)=WIDO
7441 ENDIF
7442 ENDIF
7443 RES=SHN-S1
7444 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7445 101 CONTINUE
7446 JRES=0
7447 KFR1=KTECHN+213
7448 KCR1=PYCOMP(KFR1)
7449 KFR2=KTECHN+215
7450 KCR2=PYCOMP(KFR2)
7451 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7452 KCT=KCR2
7453 KCR2=KCR1
7454 KCR1=KCT
7455 ENDIF
7456 DO 103 I=1,2
7457 IF(I.EQ.1) THEN
7458 SHN0=PMAS(KCR1,1)**2
7459 ELSEIF(I.EQ.2) THEN
7460 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7461 SHN0=PMAS(KCR2,1)**2
7462 ENDIF
7463 AEM=PYALEM(SHN0)
7464 FAR=SQRT(AEM/ALPRHT)
7465 SHN=SHN0*(1D0-FAR)
7466 CALL PYTECM(SHN,S1,WIDO,2)
7467 RES=SHN-S1
7468 SHN=S1*.99D0
7469 SHSTEP=2D0
7470 104 SHN=SHN+SHSTEP
7471 CALL PYTECM(SHN,S1,WIDO,2)
7472 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7473 IOK=.FALSE.
7474 IF(JRES.GT.0) THEN
7475 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7476 ELSEIF(JRES.EQ.0) THEN
7477 IOK=.TRUE.
7478 ENDIF
7479 IF(IOK) THEN
7480 JRES=JRES+1
7481 YMAS(JRES)=SQRT(S1)
7482 YWID(JRES)=WIDO
7483 ENDIF
7484 ENDIF
7485 RES=SHN-S1
7486 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7487 103 CONTINUE
7488 ENDIF
7489 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7490 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7491 MINT(72)=IRES
7492 IF(IRES.GE.1) THEN
7493 VINT(73)=XMAS(1)**2/VINT(2)
7494 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7495 TAUR1=VINT(73)
7496 GAMR1=VINT(74)
7497 XM1=XMAS(1)
7498 XG1=XWID(1)
7499 KFR1=1
7500 ENDIF
7501 IF(IRES.GE.2) THEN
7502 VINT(75)=XMAS(2)**2/VINT(2)
7503 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7504 TAUR2=VINT(75)
7505 GAMR2=VINT(76)
7506 XM2=XMAS(2)
7507 XG2=XWID(2)
7508 KFR2=2
7509 ENDIF
7510 IF(IRES.EQ.3) THEN
7511 VINT(77)=XMAS(3)**2/VINT(2)
7512 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7513 TAUR3=VINT(77)
7514 GAMR3=VINT(78)
7515 XM3=XMAS(3)
7516 XG3=XWID(3)
7517 KFR3=3
7518 ENDIF
7519C...Charged current: rho+- and a+-
7520 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7521 MINT(72)=IRES
7522 IF(JRES.GE.1) THEN
7523 VINT(73)=YMAS(1)**2/VINT(2)
7524 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7525 KFR1=1
7526 TAUR1=VINT(73)
7527 GAMR1=VINT(74)
7528 XM1=YMAS(1)
7529 XG1=YWID(1)
7530 ENDIF
7531 IF(JRES.GE.2) THEN
7532 VINT(75)=YMAS(2)**2/VINT(2)
7533 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7534 KFR2=2
7535 TAUR2=VINT(73)
7536 GAMR2=VINT(74)
7537 XM2=YMAS(2)
7538 XG2=YWID(2)
7539 ENDIF
7540 KFR3=0
7541 ENDIF
7542 IF(ISUB.NE.141) THEN
7543 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7544 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7545 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7546 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7547 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7548 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7549 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7550
7551 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7552 MINT(72)=2
7553 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7554 MINT(72)=2
7555 MINT(74)=KFR3
7556 VINT(75)=TAUR3
7557 VINT(76)=GAMR3
7558 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7559 MINT(72)=2
7560 MINT(73)=KFR2
7561 VINT(73)=TAUR2
7562 VINT(74)=GAMR2
7563 MINT(74)=KFR3
7564 VINT(75)=TAUR3
7565 VINT(76)=GAMR3
7566 ELSEIF(KFR1.NE.0) THEN
7567 MINT(72)=1
7568 ELSEIF(KFR2.NE.0) THEN
7569 MINT(72)=1
7570 MINT(73)=KFR2
7571 VINT(73)=TAUR2
7572 VINT(74)=GAMR2
7573 ELSEIF(KFR3.NE.0) THEN
7574 MINT(72)=1
7575 MINT(73)=KFR3
7576 VINT(73)=TAUR3
7577 VINT(74)=GAMR3
7578 ELSE
7579 MINT(72)=0
7580 ENDIF
7581 ELSE
7582 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7583
7584 ELSEIF(KFR2.NE.0) THEN
7585 KFR1=KFR2
7586 TAUR1=TAUR2
7587 GAMR1=GAMR2
7588 MINT(72)=1
7589 MINT(73)=KFR1
7590 VINT(73)=TAUR1
7591 VINT(74)=GAMR1
7592 KFR2=0
7593 ELSE
7594 MINT(72)=0
7595 ENDIF
7596 ENDIF
7597 ENDIF
7598
7599C...Find product masses and minimum pT of process.
7600 SQM3=0D0
7601 SQM4=0D0
7602 MINT(71)=0
7603 VINT(71)=CKIN(3)
7604 VINT(80)=1D0
7605 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7606 NBW=0
7607 DO 110 I=1,2
7608 PMMN(I)=0D0
7609 IF(KFPR(ISUB,I).EQ.0) THEN
7610 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7611 & PARP(41)) THEN
7612 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7613 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7614 ELSE
7615 NBW=NBW+1
7616C...This prevents SUSY/t particles from becoming too light.
7617 KFLW=KFPR(ISUB,I)
7618 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7619 KCW=PYCOMP(KFLW)
7620 PMMN(I)=PMAS(KCW,1)
7621 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7622 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7623 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7624 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7625 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7626 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7627 PMMN(I)=MIN(PMMN(I),PMSUM)
7628 ENDIF
7629 100 CONTINUE
7630 ELSEIF(KFLW.EQ.6) THEN
7631 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7632 ENDIF
7633 ENDIF
7634 110 CONTINUE
7635 IF(NBW.GE.1) THEN
7636 CKIN41=CKIN(41)
7637 CKIN43=CKIN(43)
7638 CKIN(41)=MAX(PMMN(1),CKIN(41))
7639 CKIN(43)=MAX(PMMN(2),CKIN(43))
7640 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7641 CKIN(41)=CKIN41
7642 CKIN(43)=CKIN43
7643 IF(MINT(51).EQ.1) THEN
7644 WRITE(MSTU(11),5100) ISUB
7645 MSUB(ISUB)=0
7646 GOTO 460
7647 ENDIF
7648 SQM3=PQM3**2
7649 SQM4=PQM4**2
7650 ENDIF
7651 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7652 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7653 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7654 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7655 ELSEIF(ISUB.EQ.96) THEN
7656 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7657 ENDIF
7658 ENDIF
7659 VINT(63)=SQM3
7660 VINT(64)=SQM4
7661
7662C...Prepare for additional variable choices in 2 -> 3.
7663 IF(ISTSB.EQ.5) THEN
7664 VINT(201)=0D0
7665 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7666 VINT(206)=VINT(201)
7667 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7668 VINT(204)=PMAS(23,1)
7669 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7670 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7671 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7672 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7673 & VINT(204)=VINT(201)
7674 VINT(209)=VINT(204)
7675 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7676 ENDIF
7677
7678C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7679 IPEAK7=0
7680 NPTS(1)=2+2*MINT(72)
7681 IF(MINT(47).EQ.1) THEN
7682 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7683 ELSEIF(MINT(47).GE.5) THEN
7684 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7685 NPTS(1)=NPTS(1)+1
7686 IPEAK7=1
7687 ENDIF
7688 ENDIF
7689 NPTS(2)=1
7690 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7691 IF(MINT(47).GE.2) NPTS(2)=2
7692 IF(MINT(47).GE.5) NPTS(2)=3
7693 ENDIF
7694 NPTS(3)=1
7695 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7696 NPTS(3)=3
7697 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7698 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7699 ENDIF
7700 NPTS(4)=1
7701 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7702 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7703
7704C...Reset coefficients of cross-section weighting.
7705 DO 120 J=1,20
7706 COEF(ISUB,J)=0D0
7707 120 CONTINUE
7708 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7709 & .AND.ISUB.LE.380)) THEN
7710 DO 125 J=1,2
7711 COEFX(ISUB,J)=0D0
7712 125 CONTINUE
7713 ENDIF
7714 COEF(ISUB,1)=1D0
7715 COEF(ISUB,8)=0.5D0
7716 COEF(ISUB,9)=0.5D0
7717 COEF(ISUB,13)=1D0
7718 COEF(ISUB,18)=1D0
7719 MCTH=0
7720 MTAUP=0
7721 METAUP=0
7722 VINT(23)=0D0
7723 VINT(26)=0D0
7724 SIGSAM=0D0
7725
7726C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7727C...in grid of phase space points.
7728 CALL PYKLIM(1)
7729 METAU=MINT(51)
7730 NACC=0
7731 DO 150 ITRY=1,NTRY
7732 MINT(51)=0
7733 IF(METAU.EQ.1) GOTO 150
7734 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7735 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7736 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7737 MTAU=7
7738 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7739 MTAU=MTAU+1
7740 ENDIF
7741 RTAU=0.5D0
7742C...Special case when both resonances have same mass,
7743C...as is often the case in process 194.
7744c IF(MINT(72).GE.2) THEN
7745c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7746c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7747c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7748c RTAU=0.4D0
7749c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7750c RTAU=0.6D0
7751c ENDIF
7752c ENDIF
7753c ENDIF
7754 CALL PYKMAP(1,MTAU,RTAU)
7755 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7756 METAUP=MINT(51)
7757 ENDIF
7758 IF(METAUP.EQ.1) GOTO 150
7759 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7760 & .EQ.0) THEN
7761 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7762 CALL PYKMAP(4,MTAUP,0.5D0)
7763 ENDIF
7764 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7765 CALL PYKLIM(2)
7766 MEYST=MINT(51)
7767 ENDIF
7768 IF(MEYST.EQ.1) GOTO 150
7769 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7770 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7771 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7772 CALL PYKMAP(2,MYST,0.5D0)
7773 CALL PYKLIM(3)
7774 MECTH=MINT(51)
7775 ENDIF
7776 IF(MECTH.EQ.1) GOTO 150
7777 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7778 MCTH=1+MOD(ITRY-1,NPTS(4))
7779 CALL PYKMAP(3,MCTH,0.5D0)
7780 ENDIF
7781 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7782
7783C...Store position and limits.
7784 MINT(51)=0
7785 CALL PYKLIM(0)
7786 IF(MINT(51).EQ.1) GOTO 150
7787 NACC=NACC+1
7788 MVARPT(NACC,1)=MTAU
7789 MVARPT(NACC,2)=MTAUP
7790 MVARPT(NACC,3)=MYST
7791 MVARPT(NACC,4)=MCTH
7792 DO 130 J=1,30
7793 VINTPT(NACC,J)=VINT(10+J)
7794 130 CONTINUE
7795
7796C...Normal case: calculate cross-section.
7797 IF(ISTSB.NE.5) THEN
7798 CALL PYSIGH(NCHN,SIGS)
7799 IF(MWTXS.EQ.1) THEN
7800 CALL PYEVWT(WTXS)
7801 SIGS=WTXS*SIGS
7802 ENDIF
7803
7804C..2 -> 3: find highest value out of a number of tries.
7805 ELSE
7806 SIGS=0D0
7807 DO 140 IKIN3=1,MSTP(129)
7808 CALL PYKMAP(5,0,0D0)
7809 IF(MINT(51).EQ.1) GOTO 140
7810 CALL PYSIGH(NCHN,SIGTMP)
7811 IF(MWTXS.EQ.1) THEN
7812 CALL PYEVWT(WTXS)
7813 SIGTMP=WTXS*SIGTMP
7814 ENDIF
7815 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7816 140 CONTINUE
7817 ENDIF
7818
7819C...Store cross-section.
7820 SIGSPT(NACC)=SIGS
7821 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7822 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7823 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7824 150 CONTINUE
7825 IF(NACC.EQ.0) THEN
7826 WRITE(MSTU(11),5100) ISUB
7827 MSUB(ISUB)=0
7828 GOTO 460
7829 ELSEIF(SIGSAM.EQ.0D0) THEN
7830 WRITE(MSTU(11),5300) ISUB
7831 MSUB(ISUB)=0
7832 GOTO 460
7833 ENDIF
7834 IF(ISUB.NE.96) NPOSI=NPOSI+1
7835
7836C...Calculate integrals in tau over maximal phase space limits.
7837 TAUMIN=VINT(11)
7838 TAUMAX=VINT(31)
7839 ATAU1=LOG(TAUMAX/TAUMIN)
7840 IF(NPTS(1).GE.2) THEN
7841 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7842 ENDIF
7843 IF(NPTS(1).GE.4) THEN
7844 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7845 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7846 & GAMR1
7847 ENDIF
7848 IF(NPTS(1).GE.6) THEN
7849 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7850 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7851 & GAMR2
7852 ENDIF
7853 IF(NPTS(1).GE.8) THEN
7854 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7855 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7856 & GAMR3
7857 ENDIF
7858 IF(IPEAK7.EQ.1) THEN
7859 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7860 ENDIF
7861
7862C...Reset. Sum up cross-sections in points calculated.
7863 DO 320 IVAR=1,4
7864 IF(NPTS(IVAR).EQ.1) GOTO 320
7865 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7866 NBIN=NPTS(IVAR)
7867 DO 170 J1=1,NBIN
7868 NAREL(J1)=0
7869 WTREL(J1)=0D0
7870 COEFU(J1)=0D0
7871 DO 160 J2=1,NBIN
7872 WTMAT(J1,J2)=0D0
7873 160 CONTINUE
7874 170 CONTINUE
7875 DO 180 IACC=1,NACC
7876 IBIN=MVARPT(IACC,IVAR)
7877 IF(IVAR.EQ.1) THEN
7878 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7879 IBIN=IBIN-1
7880 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7881 IBIN=3+2*MINT(72)
7882 ENDIF
7883 ENDIF
7884 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7885 NAREL(IBIN)=NAREL(IBIN)+1
7886 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7887
7888C...Sum up tau cross-section pieces in points used.
7889 IF(IVAR.EQ.1) THEN
7890 TAU=VINTPT(IACC,11)
7891 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7892 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7893 IF(NBIN.GE.4) THEN
7894 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7895 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7896 & ((TAU-TAUR1)**2+GAMR1**2)
7897 ENDIF
7898 IF(NBIN.GE.6) THEN
7899 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7900 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7901 & ((TAU-TAUR2)**2+GAMR2**2)
7902 ENDIF
7903 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7904 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7905 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7906 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7907 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7908 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7909 ENDIF
7910 IF(MINT(72).EQ.3) THEN
7911 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7912 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7913 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7914 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7915 ENDIF
7916C...Sum up tau' cross-section pieces in points used.
7917 ELSEIF(IVAR.EQ.2) THEN
7918 TAU=VINTPT(IACC,11)
7919 TAUP=VINTPT(IACC,16)
7920 TAUPMN=VINTPT(IACC,6)
7921 TAUPMX=VINTPT(IACC,26)
7922 ATAUP1=LOG(TAUPMX/TAUPMN)
7923 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7924 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7925 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7926 & (1D0-TAU/TAUP)**3/TAUP
7927 IF(NBIN.GE.3) THEN
7928 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7929 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7930 & TAUP/MAX(2D-10,1D0-TAUP)
7931 ENDIF
7932
7933C...Sum up y* cross-section pieces in points used.
7934 ELSEIF(IVAR.EQ.3) THEN
7935 YST=VINTPT(IACC,12)
7936 YSTMIN=VINTPT(IACC,2)
7937 YSTMAX=VINTPT(IACC,22)
7938 AYST0=YSTMAX-YSTMIN
7939 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7940 AYST2=AYST1
7941 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7942 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7943 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7944 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7945 IF(MINT(45).EQ.3) THEN
7946 TAUE=VINTPT(IACC,11)
7947 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7948 YST0=-0.5D0*LOG(TAUE)
7949 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7950 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7951 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7952 & MAX(1D-10,1D0-EXP(YST-YST0))
7953 ENDIF
7954 IF(MINT(46).EQ.3) THEN
7955 TAUE=VINTPT(IACC,11)
7956 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7957 YST0=-0.5D0*LOG(TAUE)
7958 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7959 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7960 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7961 & MAX(1D-10,1D0-EXP(-YST-YST0))
7962 ENDIF
7963
7964C...Sum up cos(theta-hat) cross-section pieces in points used.
7965 ELSE
7966 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7967 RSQM=1D0+RM34
7968 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7969 CTHMIN=-CTHMAX
7970 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7971 & (TAUMAX*VINT(2)))
7972 ACTH1=CTHMAX-CTHMIN
7973 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7974 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7975 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7976 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7977 CTH=VINTPT(IACC,13)
7978 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7979 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7980 & MAX(RM34,RSQM-CTH)
7981 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7982 & MAX(RM34,RSQM+CTH)
7983 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7984 & MAX(RM34,RSQM-CTH)**2
7985 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7986 & MAX(RM34,RSQM+CTH)**2
7987 ENDIF
7988 180 CONTINUE
7989
7990C...Check that equation system solvable.
7991 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7992 MSOLV=1
7993 WTRELS=0D0
7994 DO 190 IBIN=1,NBIN
7995 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
7996 & IRED=1,NBIN),WTREL(IBIN)
7997 IF(NAREL(IBIN).EQ.0) MSOLV=0
7998 WTRELS=WTRELS+WTREL(IBIN)
7999 190 CONTINUE
8000 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8001
8002C...Solve to find relative importance of cross-section pieces.
8003 IF(MSOLV.EQ.1) THEN
8004 DO 200 IBIN=1,NBIN
8005 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8006 WTRSAV(IBIN)=WTREL(IBIN)
8007 200 CONTINUE
8008C...Auxiliary vectors to record order of permutations
8009 DO I=1,NBIN
8010 IP(I) = I
8011 IQ(I) = I
8012 ENDDO
8013 DO 230 IRED=1,NBIN-1
8014 MROW=IRED
8015 RESMAX=ABS(WTREL(MROW))
8016C...Find row with largest residual
8017 DO JBIN=IRED+1,NBIN
8018 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8019 MROW=JBIN
8020 RESMAX=ABS(WTREL(MROW))
8021 ENDIF
8022 ENDDO
8023 IF(RESMAX.LT.1D-20) THEN
8024 MSOLV=0
8025 GOTO 260
8026 ENDIF
8027 MCOL = IRED
8028 AMAX = ABS(WTMAT(MROW,MCOL))
8029C...Find column with largest entry
8030 DO JBIN=IRED+1,NBIN
8031 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8032 MCOL = JBIN
8033 AMAX = ABS(WTMAT(MROW,MCOL))
8034 ENDIF
8035 ENDDO
8036C...Swap rows if necessary
8037 IF(MROW.NE.IRED) THEN
8038 DO JBIN=1,NBIN
8039 TMPE=WTMAT(IRED,JBIN)
8040 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8041 WTMAT(MROW,JBIN)=TMPE
8042 ENDDO
8043 TMPE=WTREL(IRED)
8044 WTREL(IRED)=WTREL(MROW)
8045 WTREL(MROW)=TMPE
8046 MTMP=IQ(IRED)
8047 IQ(IRED)=IQ(MROW)
8048 IQ(MROW)=MTMP
8049 ENDIF
8050C...Swap columns if necessary
8051 IF(MCOL.NE.IRED) THEN
8052 DO JBIN=1,NBIN
8053 TMPE=WTMAT(JBIN,IRED)
8054 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8055 WTMAT(JBIN,MCOL)=TMPE
8056 ENDDO
8057 MTMP=IP(IRED)
8058 IP(IRED)=IP(MCOL)
8059 IP(MCOL)=MTMP
8060 ENDIF
8061C...Begin eliminating equations
8062 DO 220 IBIN=IRED+1,NBIN
8063 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8064 MSOLV=0
8065 GOTO 260
8066 ENDIF
8067C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8068 RQTU=WTMAT(IBIN,IRED)
8069 RQTL=WTMAT(IRED,IRED)
8070C...Switch order of operations
8071 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8072 $ (WTREL(IRED)/RQTL)
8073 DO 210 ICOE=IRED,NBIN
8074 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8075 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8076 210 CONTINUE
8077 220 CONTINUE
8078 230 CONTINUE
8079 DO 250 IRED=NBIN,1,-1
8080 DO 240 ICOE=IRED+1,NBIN
8081 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8082 240 CONTINUE
8083 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8084 MSOLV=0
8085 GOTO 260
8086 ENDIF
8087 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8088 TEMPC(IRED)=COEFU(IRED)
8089 250 CONTINUE
8090C...Return to original order
8091 DO IBIN=1,NBIN
8092 MTMP=IP(IBIN)
8093 COEFU(MTMP)=TEMPC(IBIN)
8094 ENDDO
8095 ENDIF
8096
8097C...Share evenly if failure.
8098 260 IF(MSOLV.EQ.0) THEN
8099 DO 270 IBIN=1,NBIN
8100 COEFU(IBIN)=1D0
8101 WTRELN(IBIN)=0.1D0
8102 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8103 & WTRSAV(IBIN)/WTRELS)
8104 270 CONTINUE
8105 ENDIF
8106
8107C...Normalize coefficients, with piece shared democratically.
8108 COEFSU=0D0
8109 WTRELS=0D0
8110 DO 280 IBIN=1,NBIN
8111 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8112 COEFSU=COEFSU+COEFU(IBIN)
8113 WTRELS=WTRELS+WTRELN(IBIN)
8114 280 CONTINUE
8115 IF(COEFSU.GT.0D0) THEN
8116 DO 290 IBIN=1,NBIN
8117 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8118 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8119 290 CONTINUE
8120 ELSE
8121 DO 300 IBIN=1,NBIN
8122 COEFO(IBIN)=1D0/NBIN
8123 300 CONTINUE
8124 ENDIF
8125 IF(IVAR.EQ.1) IOFF=0
8126 IF(IVAR.EQ.2) IOFF=17
8127 IF(IVAR.EQ.3) IOFF=7
8128 IF(IVAR.EQ.4) IOFF=12
8129 DO 310 IBIN=1,NBIN
8130 ICOF=IOFF+IBIN
8131 IF(IVAR.EQ.1) THEN
8132 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8133 ICOF=7
8134 ENDIF
8135 ENDIF
8136 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8137 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8138 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8139 ELSE
8140 COEF(ISUB,ICOF)=COEFO(IBIN)
8141 ENDIF
8142 310 CONTINUE
8143
8144 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8145 & (COEFO(IBIN),IBIN=1,NBIN)
8146
8147 320 CONTINUE
8148
8149C...Find two most promising maxima among points previously determined.
8150 DO 330 J=1,4
8151 IACCMX(J)=0
8152 SIGSMX(J)=0D0
8153 330 CONTINUE
8154 NMAX=0
8155 DO 390 IACC=1,NACC
8156 DO 340 J=1,30
8157 VINT(10+J)=VINTPT(IACC,J)
8158 340 CONTINUE
8159 IF(ISTSB.NE.5) THEN
8160 CALL PYSIGH(NCHN,SIGS)
8161 IF(MWTXS.EQ.1) THEN
8162 CALL PYEVWT(WTXS)
8163 SIGS=WTXS*SIGS
8164 ENDIF
8165 ELSE
8166 SIGS=0D0
8167 DO 350 IKIN3=1,MSTP(129)
8168 CALL PYKMAP(5,0,0D0)
8169 IF(MINT(51).EQ.1) GOTO 350
8170 CALL PYSIGH(NCHN,SIGTMP)
8171 IF(MWTXS.EQ.1) THEN
8172 CALL PYEVWT(WTXS)
8173 SIGTMP=WTXS*SIGTMP
8174 ENDIF
8175 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8176 350 CONTINUE
8177 ENDIF
8178 IEQ=0
8179 DO 360 IMV=1,NMAX
8180 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8181 360 CONTINUE
8182 IF(IEQ.EQ.0) THEN
8183 DO 370 IMV=NMAX,1,-1
8184 IIN=IMV+1
8185 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8186 IACCMX(IMV+1)=IACCMX(IMV)
8187 SIGSMX(IMV+1)=SIGSMX(IMV)
8188 370 CONTINUE
8189 IIN=1
8190 380 IACCMX(IIN)=IACC
8191 SIGSMX(IIN)=SIGS
8192 IF(NMAX.LE.1) NMAX=NMAX+1
8193 ENDIF
8194 390 CONTINUE
8195
8196C...Read out starting position for search.
8197 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8198 SIGSAM=SIGSMX(1)
8199 DO 440 IMAX=1,NMAX
8200 IACC=IACCMX(IMAX)
8201 MTAU=MVARPT(IACC,1)
8202 MTAUP=MVARPT(IACC,2)
8203 MYST=MVARPT(IACC,3)
8204 MCTH=MVARPT(IACC,4)
8205 VTAU=0.5D0
8206 VYST=0.5D0
8207 VCTH=0.5D0
8208 VTAUP=0.5D0
8209
8210C...Starting point and step size in parameter space.
8211 DO 430 IRPT=1,2
8212 DO 420 IVAR=1,4
8213 IF(NPTS(IVAR).EQ.1) GOTO 420
8214 IF(IVAR.EQ.1) VVAR=VTAU
8215 IF(IVAR.EQ.2) VVAR=VTAUP
8216 IF(IVAR.EQ.3) VVAR=VYST
8217 IF(IVAR.EQ.4) VVAR=VCTH
8218 IF(IVAR.EQ.1) MVAR=MTAU
8219 IF(IVAR.EQ.2) MVAR=MTAUP
8220 IF(IVAR.EQ.3) MVAR=MYST
8221 IF(IVAR.EQ.4) MVAR=MCTH
8222 IF(IRPT.EQ.1) VDEL=0.1D0
8223 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8224 & 0.98D0-VVAR))
8225 IF(IRPT.EQ.1) VMAR=0.02D0
8226 IF(IRPT.EQ.2) VMAR=0.002D0
8227 IMOV0=1
8228 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8229 DO 410 IMOV=IMOV0,8
8230
8231C...Define new point in parameter space.
8232 IF(IMOV.EQ.0) THEN
8233 INEW=2
8234 VNEW=VVAR
8235 ELSEIF(IMOV.EQ.1) THEN
8236 INEW=3
8237 VNEW=VVAR+VDEL
8238 ELSEIF(IMOV.EQ.2) THEN
8239 INEW=1
8240 VNEW=VVAR-VDEL
8241 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8242 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8243 VVAR=VVAR+VDEL
8244 SIGSSM(1)=SIGSSM(2)
8245 SIGSSM(2)=SIGSSM(3)
8246 INEW=3
8247 VNEW=VVAR+VDEL
8248 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8249 & VVAR-2D0*VDEL.GT.VMAR) THEN
8250 VVAR=VVAR-VDEL
8251 SIGSSM(3)=SIGSSM(2)
8252 SIGSSM(2)=SIGSSM(1)
8253 INEW=1
8254 VNEW=VVAR-VDEL
8255 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8256 VDEL=0.5D0*VDEL
8257 VVAR=VVAR+VDEL
8258 SIGSSM(1)=SIGSSM(2)
8259 INEW=2
8260 VNEW=VVAR
8261 ELSE
8262 VDEL=0.5D0*VDEL
8263 VVAR=VVAR-VDEL
8264 SIGSSM(3)=SIGSSM(2)
8265 INEW=2
8266 VNEW=VVAR
8267 ENDIF
8268
8269C...Convert to relevant variables and find derived new limits.
8270 ILERR=0
8271 IF(IVAR.EQ.1) THEN
8272 VTAU=VNEW
8273 CALL PYKMAP(1,MTAU,VTAU)
8274 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8275 CALL PYKLIM(4)
8276 IF(MINT(51).EQ.1) ILERR=1
8277 ENDIF
8278 ENDIF
8279 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8280 & ILERR.EQ.0) THEN
8281 IF(IVAR.EQ.2) VTAUP=VNEW
8282 CALL PYKMAP(4,MTAUP,VTAUP)
8283 ENDIF
8284 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8285 CALL PYKLIM(2)
8286 IF(MINT(51).EQ.1) ILERR=1
8287 ENDIF
8288 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8289 IF(IVAR.EQ.3) VYST=VNEW
8290 CALL PYKMAP(2,MYST,VYST)
8291 CALL PYKLIM(3)
8292 IF(MINT(51).EQ.1) ILERR=1
8293 ENDIF
8294 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8295 & ILERR.EQ.0) THEN
8296 IF(IVAR.EQ.4) VCTH=VNEW
8297 CALL PYKMAP(3,MCTH,VCTH)
8298 ENDIF
8299 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8300
8301C...Evaluate cross-section. Save new maximum. Final maximum.
8302 IF(ILERR.NE.0) THEN
8303 SIGS=0.
8304 ELSEIF(ISTSB.NE.5) THEN
8305 CALL PYSIGH(NCHN,SIGS)
8306 IF(MWTXS.EQ.1) THEN
8307 CALL PYEVWT(WTXS)
8308 SIGS=WTXS*SIGS
8309 ENDIF
8310 ELSE
8311 SIGS=0D0
8312 DO 400 IKIN3=1,MSTP(129)
8313 CALL PYKMAP(5,0,0D0)
8314 IF(MINT(51).EQ.1) GOTO 400
8315 CALL PYSIGH(NCHN,SIGTMP)
8316 IF(MWTXS.EQ.1) THEN
8317 CALL PYEVWT(WTXS)
8318 SIGTMP=WTXS*SIGTMP
8319 ENDIF
8320 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8321 400 CONTINUE
8322 ENDIF
8323 SIGSSM(INEW)=SIGS
8324 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8325 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8326 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8327 410 CONTINUE
8328 420 CONTINUE
8329 430 CONTINUE
8330 440 CONTINUE
8331 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8332 XSEC(ISUB,1)=1.05D0*SIGSAM
8333C...Add extra headroom for UED
8334 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8335 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8336 & WTGAGA*XSEC(ISUB,1)
8337 450 CONTINUE
8338 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8339 & PARP(174)*XSEC(ISUB,1)
8340 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8341 460 CONTINUE
8342 MINT(51)=0
8343
8344C...Print summary table.
8345 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8346 IF(MSTP(127).NE.1) THEN
8347 WRITE(MSTU(11),5900)
8348 CALL PYSTOP(1)
8349 ELSE
8350 WRITE(MSTU(11),6400)
8351 MSTI(53)=1
8352 ENDIF
8353 ENDIF
8354 IF(MSTP(122).GE.1) THEN
8355 WRITE(MSTU(11),6000)
8356 WRITE(MSTU(11),6100)
8357 DO 470 ISUB=1,500
8358 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8359 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8360 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8361 & GOTO 470
8362 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8363 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8364 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8365 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8366 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8367 470 CONTINUE
8368 WRITE(MSTU(11),6300)
8369 ENDIF
8370
8371C...Format statements for maximization results.
8372 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8373 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8374 &'cth',9X,'tau''',7X,'sigma')
8375 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8376 &'phase space.'/1X,'Process switched off!')
8377 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8378 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8379 &'cross-section.'/1X,'Process switched off!')
8380 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8381 5500 FORMAT(1X,1P,10D11.3)
8382 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8383 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8384 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8385 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8386 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8387 &'cross-section.'/1X,'Execution stopped!')
8388 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8389 &'cross-section maximum search',1X,8('*'))
8390 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8391 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8392 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8393 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8394 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8395 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8396 &'cross-section.'/
8397 &1X,'Execution will stop if you try to generate events.')
8398
8399 RETURN
8400 END
8401
8402C*********************************************************************
8403
8404C...PYPILE
8405C...Initializes multiplicity distribution and selects mutliplicity
8406C...of pileup events, i.e. several events occuring at the same
8407C...beam crossing.
8408
8409 SUBROUTINE PYPILE(MPILE)
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/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8417 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8418 COMMON/PYINT1/MINT(400),VINT(400)
8419 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8420 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8421C...Local arrays and saved variables.
8422 DIMENSION WTI(0:200)
8423 SAVE IMIN,IMAX,WTI,WTS
8424
8425C...Sum of allowed cross-sections for pileup events.
8426 IF(MPILE.EQ.1) THEN
8427 VINT(131)=SIGT(0,0,5)
8428 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8429 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8430 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8431 IF(MSTP(133).LE.0) RETURN
8432
8433C...Initialize multiplicity distribution at maximum.
8434 XNAVE=VINT(131)*PARP(131)
8435 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8436 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8437 WTI(INAVE)=1D0
8438 WTS=WTI(INAVE)
8439 WTN=WTI(INAVE)*INAVE
8440
8441C...Find shape of multiplicity distribution below maximum.
8442 IMIN=INAVE
8443 DO 100 I=INAVE-1,1,-1
8444 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8445 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8446 IF(WTI(I).LT.1D-6) GOTO 110
8447 WTS=WTS+WTI(I)
8448 WTN=WTN+WTI(I)*I
8449 IMIN=I
8450 100 CONTINUE
8451
8452C...Find shape of multiplicity distribution above maximum.
8453 110 IMAX=INAVE
8454 DO 120 I=INAVE+1,200
8455 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8456 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8457 IF(WTI(I).LT.1D-6) GOTO 130
8458 WTS=WTS+WTI(I)
8459 WTN=WTN+WTI(I)*I
8460 IMAX=I
8461 120 CONTINUE
8462 130 VINT(132)=XNAVE
8463 VINT(133)=WTN/WTS
8464 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8465 & WTS/(WTS+WTI(1)/XNAVE)
8466 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8467 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8468
8469C...Pick multiplicity of pileup events.
8470 ELSE
8471 IF(MSTP(133).LE.0) THEN
8472 MINT(81)=MAX(1,MSTP(134))
8473 ELSE
8474 WTR=WTS*PYR(0)
8475 DO 140 I=IMIN,IMAX
8476 MINT(81)=I
8477 WTR=WTR-WTI(I)
8478 IF(WTR.LE.0D0) GOTO 150
8479 140 CONTINUE
8480 150 CONTINUE
8481 ENDIF
8482 ENDIF
8483
8484C...Format statement for error message.
8485 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8486 &'crossing too large, ',1P,D12.4)
8487
8488 RETURN
8489 END
8490
8491C*********************************************************************
8492
8493C...PYSAVE
8494C...Saves and restores parameter and cross section values for the
8495C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8496C...Also makes random choice between alternatives.
8497
8498 SUBROUTINE PYSAVE(ISAVE,IGA)
8499
8500C...Double precision and integer declarations.
8501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8502 IMPLICIT INTEGER(I-N)
8503 INTEGER PYK,PYCHGE,PYCOMP
8504C...Commonblocks.
8505 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8506 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8507 COMMON/PYINT1/MINT(400),VINT(400)
8508 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8509 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8510 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8511 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8512C...Local arrays and saved variables.
8513 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8514 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8515 &INTCP(15,20),RECP(15,20)
8516 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8517
8518C...Save list of subprocesses and cross-section information.
8519 IF(ISAVE.EQ.1) THEN
8520 ICP=0
8521 DO 120 I=1,500
8522 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8523 ICP=ICP+1
8524 NSUBCP(IGA,ICP)=I
8525 MSUBCP(IGA,ICP)=MSUB(I)
8526 DO 100 J=1,20
8527 COEFCP(IGA,ICP,J)=COEF(I,J)
8528 100 CONTINUE
8529 DO 110 J=1,3
8530 NGENCP(IGA,ICP,J)=NGEN(I,J)
8531 XSECCP(IGA,ICP,J)=XSEC(I,J)
8532 110 CONTINUE
8533 120 CONTINUE
8534 NCP(IGA)=ICP
8535 DO 130 J=1,3
8536 NGENCP(IGA,0,J)=NGEN(0,J)
8537 XSECCP(IGA,0,J)=XSEC(0,J)
8538 130 CONTINUE
8539 DO 160 I1=0,6
8540 DO 150 I2=0,6
8541 DO 140 J=0,5
8542 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8543 140 CONTINUE
8544 150 CONTINUE
8545 160 CONTINUE
8546
8547C...Save various common process variables.
8548 DO 170 J=1,10
8549 INTCP(IGA,J)=MINT(40+J)
8550 170 CONTINUE
8551 INTCP(IGA,11)=MINT(101)
8552 INTCP(IGA,12)=MINT(102)
8553 INTCP(IGA,13)=MINT(107)
8554 INTCP(IGA,14)=MINT(108)
8555 INTCP(IGA,15)=MINT(123)
8556 RECP(IGA,1)=CKIN(3)
8557 RECP(IGA,2)=VINT(318)
8558
8559C...Save cross-section information only.
8560 ELSEIF(ISAVE.EQ.2) THEN
8561 DO 190 ICP=1,NCP(IGA)
8562 I=NSUBCP(IGA,ICP)
8563 DO 180 J=1,3
8564 NGENCP(IGA,ICP,J)=NGEN(I,J)
8565 XSECCP(IGA,ICP,J)=XSEC(I,J)
8566 180 CONTINUE
8567 190 CONTINUE
8568 DO 200 J=1,3
8569 NGENCP(IGA,0,J)=NGEN(0,J)
8570 XSECCP(IGA,0,J)=XSEC(0,J)
8571 200 CONTINUE
8572
8573C...Choose between allowed alternatives.
8574 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8575 IF(ISAVE.EQ.4) THEN
8576 XSUMCP=0D0
8577 DO 210 IG=1,MINT(121)
8578 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8579 210 CONTINUE
8580 XSUMCP=XSUMCP*PYR(0)
8581 DO 220 IG=1,MINT(121)
8582 IGA=IG
8583 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8584 IF(XSUMCP.LE.0D0) GOTO 230
8585 220 CONTINUE
8586 230 CONTINUE
8587 ENDIF
8588
8589C...Restore cross-section information.
8590 DO 240 I=1,500
8591 MSUB(I)=0
8592 240 CONTINUE
8593 DO 270 ICP=1,NCP(IGA)
8594 I=NSUBCP(IGA,ICP)
8595 MSUB(I)=MSUBCP(IGA,ICP)
8596 DO 250 J=1,20
8597 COEF(I,J)=COEFCP(IGA,ICP,J)
8598 250 CONTINUE
8599 DO 260 J=1,3
8600 NGEN(I,J)=NGENCP(IGA,ICP,J)
8601 XSEC(I,J)=XSECCP(IGA,ICP,J)
8602 260 CONTINUE
8603 270 CONTINUE
8604 DO 280 J=1,3
8605 NGEN(0,J)=NGENCP(IGA,0,J)
8606 XSEC(0,J)=XSECCP(IGA,0,J)
8607 280 CONTINUE
8608 DO 310 I1=0,6
8609 DO 300 I2=0,6
8610 DO 290 J=0,5
8611 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8612 290 CONTINUE
8613 300 CONTINUE
8614 310 CONTINUE
8615
8616C...Restore various common process variables.
8617 DO 320 J=1,10
8618 MINT(40+J)=INTCP(IGA,J)
8619 320 CONTINUE
8620 MINT(101)=INTCP(IGA,11)
8621 MINT(102)=INTCP(IGA,12)
8622 MINT(107)=INTCP(IGA,13)
8623 MINT(108)=INTCP(IGA,14)
8624 MINT(123)=INTCP(IGA,15)
8625 CKIN(3)=RECP(IGA,1)
8626 CKIN(1)=2D0*CKIN(3)
8627 VINT(318)=RECP(IGA,2)
8628
8629C...Sum up cross-section info (for PYSTAT).
8630 ELSEIF(ISAVE.EQ.5) THEN
8631 DO 330 I=1,500
8632 MSUB(I)=0
8633 NGEN(I,1)=0
8634 NGEN(I,3)=0
8635 XSEC(I,3)=0D0
8636 330 CONTINUE
8637 NGEN(0,1)=0
8638 NGEN(0,2)=0
8639 NGEN(0,3)=0
8640 XSEC(0,3)=0
8641 DO 350 IG=1,MINT(121)
8642 DO 340 ICP=1,NCP(IG)
8643 I=NSUBCP(IG,ICP)
8644 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8645 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8646 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8647 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8648 340 CONTINUE
8649 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8650 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8651 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8652 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8653 350 CONTINUE
8654 ENDIF
8655
8656 RETURN
8657 END
8658
8659C*********************************************************************
8660
8661C...PYGAGA
8662C...For lepton beams it gives photon-hadron or photon-photon systems
8663C...to be treated with the ordinary machinery and combines this with a
8664C...description of the lepton -> lepton + photon branching.
8665
8666 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8667
8668C...Double precision and integer declarations.
8669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8670 IMPLICIT INTEGER(I-N)
8671 INTEGER PYK,PYCHGE,PYCOMP
8672C...Commonblocks.
8673 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8674 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8675 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8676 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8677 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8678 COMMON/PYINT1/MINT(400),VINT(400)
8679 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8680 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8681 &/PYINT5/
8682C...Local variables and data statement.
8683 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8684 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8685 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8686 DATA EPS/1D-4/
8687
8688C...Initialize generation of photons inside leptons.
8689 IF(IGAGA.EQ.1) THEN
8690
8691C...Save quantities on incoming lepton system.
8692 VINT(301)=VINT(1)
8693 VINT(302)=VINT(2)
8694 PMS(1)=VINT(303)**2
8695 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8696 PMS(2)=VINT(304)**2
8697 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8698 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8699 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8700
8701C...Calculate range of x and Q2 values allowed in generation.
8702 DO 100 I=1,2
8703 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8704 IF(MINT(140+I).NE.0) THEN
8705 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8706 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8707 & PMC(I),1D0-EPS)
8708 YMIN=MAX(CKIN(71+2*I),EPS)
8709 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8710 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8711 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8712 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8713 THEMIN=MAX(CKIN(67+2*I),0D0)
8714 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8715 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8716 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8717 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8718 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8719 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8720 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8721 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8722 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8723C...W limits when lepton on one side only.
8724 IF(MINT(143-I).EQ.0) THEN
8725 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8726 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8727 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8728 ENDIF
8729 ENDIF
8730 100 CONTINUE
8731
8732C...W limits when lepton on both sides.
8733 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8734 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8735 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8736 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8737 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8738 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8739 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8740 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8741 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8742 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8743 ELSE
8744 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8745 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8746 ENDIF
8747 ENDIF
8748
8749C...Q2 and W values and photon flux weight factors for initialization.
8750 ELSEIF(IGAGA.EQ.2) THEN
8751 ISUB=MINT(1)
8752 MINT(15)=0
8753 MINT(16)=0
8754
8755C...W value for photon on one or both sides, and for processes
8756C...with gamma-gamma cross section peaked at small shat.
8757 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8758 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8759 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8760 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8761 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8762 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8763 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8764 ELSE
8765 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8766 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8767 ENDIF
8768 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8769
8770C...Upper estimate of photon flux weight factor.
8771C...Initialization Q2 scale. Flag incoming unresolved photon.
8772 WTGAGA=1D0
8773 DO 110 I=1,2
8774 IF(MINT(140+I).NE.0) THEN
8775 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8776 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8777 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8778 & THEN
8779 Q2INIT=5D0+Q2MIN(3-I)
8780 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8781 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8782 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8783 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8784 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8785 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8786 Q2INIT=VINT(2)/3D0
8787 ELSEIF(ISUB.EQ.140) THEN
8788 Q2INIT=VINT(2)/2D0
8789 ELSE
8790 Q2INIT=Q2MIN(I)
8791 ENDIF
8792 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8793 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8794 & MINT(14+I)=22
8795 VINT(306+I)=VINT(2+I)**2
8796 ENDIF
8797 110 CONTINUE
8798 VINT(320)=WTGAGA
8799
8800C...Update pTmin and cross section information.
8801 IF(MSTP(82).LE.1) THEN
8802 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8803 ELSE
8804 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8805 ENDIF
8806 VINT(149)=4D0*PTMN**2/VINT(2)
8807 VINT(154)=PTMN
8808 CALL PYXTOT
8809 VINT(318)=VINT(317)
8810
8811C...Generate photons inside leptons and
8812C...calculate photon flux weight factors.
8813 ELSEIF(IGAGA.EQ.3) THEN
8814 ISUB=MINT(1)
8815 MINT(15)=0
8816 MINT(16)=0
8817
8818C...Generate phase space point and check against cuts.
8819 LOOP=0
8820 120 LOOP=LOOP+1
8821 DO 130 I=1,2
8822 IF(MINT(140+I).NE.0) THEN
8823C...Pick x and Q2
8824 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8825 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8826C...Cuts on internal consistency in x and Q2.
8827 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8828 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8829 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8830C...Cuts on y and theta.
8831 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8832 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8833 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8834 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8835 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8836 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8837 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8838 & GOTO 120
8839
8840C...Phi angle isotropic. Reconstruct pT.
8841 PHI(I)=PARU(2)*PYR(0)
8842 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8843 & PMS(I))*SIN(THETA(I))
8844
8845C...Store info on variables selected, for documentation purposes.
8846 VINT(2+I)=-SQRT(Q2(I))
8847 VINT(304+I)=X(I)
8848 VINT(306+I)=Q2(I)
8849 VINT(308+I)=Y(I)
8850 VINT(310+I)=THETA(I)
8851 VINT(312+I)=PHI(I)
8852 ELSE
8853 VINT(304+I)=1D0
8854 VINT(306+I)=0D0
8855 VINT(308+I)=1D0
8856 VINT(310+I)=0D0
8857 VINT(312+I)=0D0
8858 ENDIF
8859 130 CONTINUE
8860
8861C...Cut on W combines info from two sides.
8862 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8863 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8864 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8865 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8866 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8867 IF(W2.LT.W2MIN) GOTO 120
8868 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8869 PMS1=-Q2(1)
8870 PMS2=-Q2(2)
8871 ELSEIF(MINT(141).NE.0) THEN
8872 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8873 PMS1=-Q2(1)
8874 PMS2=PMS(2)
8875 ELSEIF(MINT(142).NE.0) THEN
8876 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8877 PMS1=PMS(1)
8878 PMS2=-Q2(2)
8879 ENDIF
8880
8881C...Store kinematics info for photon(s) in subsystem cm frame.
8882 VINT(2)=W2
8883 VINT(1)=SQRT(W2)
8884 VINT(291)=0D0
8885 VINT(292)=0D0
8886 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8887 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8888 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8889 VINT(296)=0D0
8890 VINT(297)=0D0
8891 VINT(298)=-VINT(293)
8892 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8893 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8894
8895C...Assign weight for photon flux; different for transverse and
8896C...longitudinal photons. Flag incoming unresolved photon.
8897 WTGAGA=1D0
8898 DO 140 I=1,2
8899 IF(MINT(140+I).NE.0) THEN
8900 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8901 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8902 IF(MSTP(16).EQ.0) THEN
8903 XY=X(I)
8904 ELSE
8905 WTGAGA=WTGAGA*X(I)/Y(I)
8906 XY=Y(I)
8907 ENDIF
8908 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8909 WTGAGA=WTGAGA*(1D0-XY)
8910 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8911 WTGAGA=WTGAGA*(1D0-XY)
8912 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8913 WTGAGA=WTGAGA*(1D0-XY)
8914 ELSE
8915 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8916 & PMS(I)*XY**2/Q2(I))
8917 ENDIF
8918 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8919 ENDIF
8920 140 CONTINUE
8921 VINT(319)=WTGAGA
8922 MINT(143)=LOOP
8923
8924C...Update pTmin and cross section information.
8925 IF(MSTP(82).LE.1) THEN
8926 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8927 ELSE
8928 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8929 ENDIF
8930 VINT(149)=4D0*PTMN**2/VINT(2)
8931 VINT(154)=PTMN
8932 CALL PYXTOT
8933
8934C...Reconstruct kinematics of photons inside leptons.
8935 ELSEIF(IGAGA.EQ.4) THEN
8936
8937C...Make place for incoming particles and scattered leptons.
8938 MOVE=3
8939 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8940 MINT(4)=MINT(4)+MOVE
8941 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8942 IF(K(I,1).EQ.21) THEN
8943 DO 150 J=1,5
8944 K(I+MOVE,J)=K(I,J)
8945 P(I+MOVE,J)=P(I,J)
8946 V(I+MOVE,J)=V(I,J)
8947 150 CONTINUE
8948 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8949 & K(I+MOVE,3)=K(I,3)+MOVE
8950 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8951 & K(I+MOVE,4)=K(I,4)+MOVE
8952 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8953 & K(I+MOVE,5)=K(I,5)+MOVE
8954 ENDIF
8955 160 CONTINUE
8956 DO 170 I=MINT(84)+1,N
8957 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8958 & K(I,3)=K(I,3)+MOVE
8959 170 CONTINUE
8960
8961C...Fill in incoming particles.
8962 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8963 DO 180 J=1,5
8964 K(I,J)=0
8965 P(I,J)=0D0
8966 V(I,J)=0D0
8967 180 CONTINUE
8968 190 CONTINUE
8969 DO 200 I=1,2
8970 K(MINT(83)+I,1)=21
8971 IF(MINT(140+I).NE.0) THEN
8972 K(MINT(83)+I,2)=MINT(140+I)
8973 P(MINT(83)+I,5)=VINT(302+I)
8974 ELSE
8975 K(MINT(83)+I,2)=MINT(10+I)
8976 P(MINT(83)+I,5)=VINT(2+I)
8977 ENDIF
8978 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8979 & VINT(302))*(-1D0)**(I+1)
8980 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8981 200 CONTINUE
8982
8983C...New mother-daughter relations in documentation section.
8984 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8985 K(MINT(83)+1,4)=MINT(83)+3
8986 K(MINT(83)+1,5)=MINT(83)+5
8987 K(MINT(83)+2,4)=MINT(83)+4
8988 K(MINT(83)+2,5)=MINT(83)+6
8989 K(MINT(83)+3,3)=MINT(83)+1
8990 K(MINT(83)+5,3)=MINT(83)+1
8991 K(MINT(83)+4,3)=MINT(83)+2
8992 K(MINT(83)+6,3)=MINT(83)+2
8993 ELSEIF(MINT(141).NE.0) THEN
8994 K(MINT(83)+1,4)=MINT(83)+3
8995 K(MINT(83)+1,5)=MINT(83)+4
8996 K(MINT(83)+2,4)=MINT(83)+5
8997 K(MINT(83)+3,3)=MINT(83)+1
8998 K(MINT(83)+4,3)=MINT(83)+1
8999 K(MINT(83)+5,3)=MINT(83)+2
9000 ELSEIF(MINT(142).NE.0) THEN
9001 K(MINT(83)+1,4)=MINT(83)+4
9002 K(MINT(83)+2,4)=MINT(83)+3
9003 K(MINT(83)+2,5)=MINT(83)+5
9004 K(MINT(83)+3,3)=MINT(83)+2
9005 K(MINT(83)+4,3)=MINT(83)+1
9006 K(MINT(83)+5,3)=MINT(83)+2
9007 ENDIF
9008
9009C...Fill scattered lepton(s).
9010 DO 210 I=1,2
9011 IF(MINT(140+I).NE.0) THEN
9012 LSC=MINT(83)+MIN(I+2,MOVE)
9013 K(LSC,1)=21
9014 K(LSC,2)=MINT(140+I)
9015 P(LSC,1)=PT(I)*COS(PHI(I))
9016 P(LSC,2)=PT(I)*SIN(PHI(I))
9017 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9018 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9019 & (-1D0)**(I-1)
9020 P(LSC,5)=VINT(302+I)
9021 ENDIF
9022 210 CONTINUE
9023
9024C...Find incoming four-vectors to subprocess.
9025 K(N+1,1)=21
9026 IF(MINT(141).NE.0) THEN
9027 DO 220 J=1,4
9028 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9029 220 CONTINUE
9030 ELSE
9031 DO 230 J=1,4
9032 P(N+1,J)=P(MINT(83)+1,J)
9033 230 CONTINUE
9034 ENDIF
9035 K(N+2,1)=21
9036 IF(MINT(142).NE.0) THEN
9037 DO 240 J=1,4
9038 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9039 240 CONTINUE
9040 ELSE
9041 DO 250 J=1,4
9042 P(N+2,J)=P(MINT(83)+2,J)
9043 250 CONTINUE
9044 ENDIF
9045
9046C...Define boost and rotation between hadronic subsystem and
9047C...collision rest frame; boost hadronic subsystem to this frame.
9048 DO 260 J=1,3
9049 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9050 260 CONTINUE
9051 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9052 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9053 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9054 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9055 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9056 & BETA(3))
9057
9058C...Add on scattered leptons to final state.
9059 DO 280 I=1,2
9060 IF(MINT(140+I).NE.0) THEN
9061 LSC=MINT(83)+MIN(I+2,MOVE)
9062 N=N+1
9063 DO 270 J=1,5
9064 K(N,J)=K(LSC,J)
9065 P(N,J)=P(LSC,J)
9066 V(N,J)=V(LSC,J)
9067 270 CONTINUE
9068 K(N,1)=1
9069 K(N,3)=LSC
9070 ENDIF
9071 280 CONTINUE
9072 ENDIF
9073
9074 RETURN
9075 END
9076
9077C*********************************************************************
9078
9079C...PYRAND
9080C...Generates quantities characterizing the high-pT scattering at the
9081C...parton level according to the matrix elements. Chooses incoming,
9082C...reacting partons, their momentum fractions and one of the possible
9083C...subprocesses.
9084
9085 SUBROUTINE PYRAND
9086
9087C...Double precision and integer declarations.
9088 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9089 IMPLICIT INTEGER(I-N)
9090 INTEGER PYK,PYCHGE,PYCOMP
9091C...Parameter statement to help give large particle numbers.
9092 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9093 &KEXCIT=4000000,KDIMEN=5000000)
9094
9095C...User process initialization and event commonblocks.
9096 INTEGER MAXPUP
9097 PARAMETER (MAXPUP=100)
9098 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9099 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9100 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9101 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9102 &LPRUP(MAXPUP)
9103 INTEGER MAXNUP
9104 PARAMETER (MAXNUP=500)
9105 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9106 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9107 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9108 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9109 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9110 SAVE /HEPRUP/,/HEPEUP/
9111
9112C...Commonblocks.
9113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9115 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9116 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9117 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9118 COMMON/PYINT1/MINT(400),VINT(400)
9119 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9120 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9121 COMMON/PYINT4/MWID(500),WIDS(500,5)
9122 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9123 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9124 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9125 COMMON/PYTCCO/COEFX(194:380,2)
9126 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9127 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9128 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9129 &/TCPARA/
9130C...Local arrays.
9131 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9132
9133C...Parameters and data used in elastic/diffractive treatment.
9134 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9135 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9136
9137C...Initial values, specifically for (first) semihard interaction.
9138 MINT(10)=0
9139 MINT(17)=0
9140 MINT(18)=0
9141 VINT(143)=1D0
9142 VINT(144)=1D0
9143 VINT(157)=0D0
9144 VINT(158)=0D0
9145 MFAIL=0
9146 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9147 ISUB=0
9148 ISTSB=0
9149 LOOP=0
9150 100 LOOP=LOOP+1
9151 MINT(51)=0
9152 MINT(143)=1
9153 VINT(97)=1D0
9154
9155C...Start by assuming incoming photon is entering subprocess.
9156 IF(MINT(11).EQ.22) THEN
9157 MINT(15)=22
9158 VINT(307)=VINT(3)**2
9159 ENDIF
9160 IF(MINT(12).EQ.22) THEN
9161 MINT(16)=22
9162 VINT(308)=VINT(4)**2
9163 ENDIF
9164 MINT(103)=MINT(11)
9165 MINT(104)=MINT(12)
9166
9167C...Choice of process type - first event of pileup.
9168 INMULT=0
9169 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9170 ELSEIF(MINT(82).EQ.1) THEN
9171
9172C...For gamma-p or gamma-gamma first pick between alternatives.
9173 IGA=0
9174 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9175 MINT(122)=IGA
9176
9177C...For real gamma + gamma with different nature, flip at random.
9178 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9179 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9180 MINTSV=MINT(41)
9181 MINT(41)=MINT(42)
9182 MINT(42)=MINTSV
9183 MINTSV=MINT(45)
9184 MINT(45)=MINT(46)
9185 MINT(46)=MINTSV
9186 MINTSV=MINT(107)
9187 MINT(107)=MINT(108)
9188 MINT(108)=MINTSV
9189 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9190 ENDIF
9191
9192C...Pick process type, possibly by user process machinery.
9193C...(If the latter, also event will be picked here.)
9194 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9195 CALL UPEVNT
9196 CALL PYUPRE
9197 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9198 CALL UPEVNT
9199 CALL PYUPRE
9200 ISUB=0
9201 110 ISUB=ISUB+1
9202 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9203 & ISUB.LT.500) GOTO 110
9204 ELSE
9205 RSUB=XSEC(0,1)*PYR(0)
9206 DO 120 I=1,500
9207 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9208 ISUB=I
9209 RSUB=RSUB-XSEC(I,1)
9210 IF(RSUB.LE.0D0) GOTO 130
9211 120 CONTINUE
9212 130 IF(ISUB.EQ.95) ISUB=96
9213 IF(ISUB.EQ.96) INMULT=1
9214 IF(ISET(ISUB).EQ.11) THEN
9215 IDPRUP=KFPR(ISUB,2)
9216 CALL UPEVNT
9217 CALL PYUPRE
9218 ENDIF
9219 ENDIF
9220
9221C...Choice of inclusive process type - pileup events.
9222 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9223 RSUB=VINT(131)*PYR(0)
9224 ISUB=96
9225 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9226 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9227 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9228 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9229 & ISUB=91
9230 IF(ISUB.EQ.96) INMULT=1
9231 ENDIF
9232
9233C...Choice of photon energy and flux factor inside lepton.
9234 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9235 CALL PYGAGA(3,WTGAGA)
9236 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9237 CKIN(3)=MAX(VINT(285),VINT(154))
9238 CKIN(1)=2D0*CKIN(3)
9239 ENDIF
9240C...When necessary set direct/resolved photon by hand.
9241 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9242 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9243 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9244 ENDIF
9245
9246C...Restrict direct*resolved processes to pTmin >= Q,
9247C...to avoid doublecounting with DIS.
9248 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9249 IF(MINT(15).EQ.22) THEN
9250 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9251 ELSE
9252 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9253 ENDIF
9254 CKIN(1)=2D0*CKIN(3)
9255 ENDIF
9256
9257C...Set up for multiple interactions (may include impact parameter).
9258 IF(INMULT.EQ.1) THEN
9259 IF(MINT(35).LE.1) CALL PYMULT(2)
9260 IF(MINT(35).GE.2) CALL PYMIGN(2)
9261 ENDIF
9262
9263C...Loopback point for minimum bias in photon physics.
9264 LOOP2=0
9265 140 LOOP2=LOOP2+1
9266 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9267 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9268 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9269 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9270 MINT(1)=ISUB
9271 ISTSB=ISET(ISUB)
9272
9273C...Random choice of flavour for some SUSY processes.
9274 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9275C...~e_L ~nu_e or ~mu_L ~nu_mu.
9276 IF(ISUB.EQ.210) THEN
9277 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9278 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9279C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9280 ELSEIF(ISUB.EQ.213) THEN
9281 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9282 KFPR(ISUB,2)=KFPR(ISUB,1)
9283C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9284 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9285 & ISUB.NE.257) THEN
9286 IF(ISUB.GE.258) THEN
9287 RKF=4D0
9288 ELSE
9289 RKF=5D0
9290 ENDIF
9291 IF(MOD(ISUB,2).EQ.0) THEN
9292 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9293 ELSE
9294 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9295 ENDIF
9296C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9297 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9298 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9299 KSU1=KSUSY1
9300 KSU2=KSUSY1
9301 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9302 KSU1=KSUSY2
9303 KSU2=KSUSY2
9304 ELSEIF(PYR(0).LT.0.5D0) THEN
9305 KSU1=KSUSY1
9306 KSU2=KSUSY2
9307 ELSE
9308 KSU1=KSUSY2
9309 KSU2=KSUSY1
9310 ENDIF
9311 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9312 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9313C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9314 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9315 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9316 KFPR(ISUB,2)=KFPR(ISUB,1)
9317 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9318 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9319 KFPR(ISUB,2)=KFPR(ISUB,1)
9320C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9321 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9322 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9323 KSU1=KSUSY1
9324 KSU2=KSUSY1
9325 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9326 KSU1=KSUSY2
9327 KSU2=KSUSY2
9328 ELSEIF(PYR(0).LT.0.5D0) THEN
9329 KSU1=KSUSY1
9330 KSU2=KSUSY2
9331 ELSE
9332 KSU1=KSUSY2
9333 KSU2=KSUSY1
9334 ENDIF
9335 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9336 RKF=5D0
9337 ELSE
9338 RKF=4D0
9339 ENDIF
9340 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9341 ENDIF
9342 ENDIF
9343
9344C...Random choice of flavours for some UED processes
9345c...The production processes can generate a doublet pair,
9346c...a singlet pair, or a doublet + singlet.
9347 IF(ISUB.EQ.313)THEN
9348C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9349 IF(PYR(0).LE.0.1)THEN
9350 KFPR(ISUB,1)=5100001
9351 ELSE
9352 KFPR(ISUB,1)=5100002
9353 ENDIF
9354 KFPR(ISUB,2)=KFPR(ISUB,1)
9355 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9356C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9357C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9358 IF(PYR(0).LE.0.1)THEN
9359 KFPR(ISUB,1)=5100001
9360 ELSE
9361 KFPR(ISUB,1)=5100002
9362 ENDIF
9363 KFPR(ISUB,2)=-KFPR(ISUB,1)
9364 ELSEIF(ISUB.EQ.316)THEN
9365C...qi + qbarj -> q*_Di + q*_Sbarj
9366 IF(PYR(0).LE.0.5)THEN
9367 KFPR(ISUB,1)=5100001
9368c Changed from private pythia6410_ued code
9369c KFPR(ISUB,2)=-5010001
9370 KFPR(ISUB,2)=-6100002
9371 ELSE
9372 KFPR(ISUB,1)=5100002
9373c Changed from private pythia6410_ued code
9374c KFPR(ISUB,2)=-5010002
9375 KFPR(ISUB,2)=-6100001
9376 ENDIF
9377 ELSEIF(ISUB.EQ.317)THEN
9378C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9379 IF(PYR(0).LE.0.5)THEN
9380 KFPR(ISUB,1)=5100001
9381 KFPR(ISUB,2)=-5100002
9382 ELSE
9383 KFPR(ISUB,1)=5100002
9384 KFPR(ISUB,2)=-5100001
9385 ENDIF
9386 ELSEIF(ISUB.EQ.318)THEN
9387C...qi + qj -> q*_Di + q*_Sj
9388 IF(PYR(0).LE.0.5)THEN
9389 KFPR(ISUB,1)=5100001
9390 KFPR(ISUB,2)=6100002
9391 ELSE
9392 KFPR(ISUB,1)=5100002
9393 KFPR(ISUB,2)=6100001
9394 ENDIF
9395 ENDIF
9396
9397C...Find resonances (explicit or implicit in cross-section).
9398 MINT(72)=0
9399 KFR1=0
9400 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9401 KFR1=KFPR(ISUB,1)
9402 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9403 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9404 KFR1=23
9405 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9406 & ISUB.EQ.177) THEN
9407 KFR1=24
9408 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9409 KFR1=25
9410 IF(MSTP(46).EQ.5) THEN
9411 KFR1=89
9412 PMAS(89,1)=PARP(45)
9413 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9414 ENDIF
9415 ENDIF
9416 CKMX=CKIN(2)
9417 IF(CKMX.LE.0D0) CKMX=VINT(1)
9418 KCR1=PYCOMP(KFR1)
9419 IF(KFR1.NE.0) THEN
9420 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9421 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9422 ENDIF
9423 IF(KFR1.NE.0) THEN
9424 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9425 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9426 MINT(72)=1
9427 MINT(73)=KFR1
9428 VINT(73)=TAUR1
9429 VINT(74)=GAMR1
9430 ENDIF
9431 KFR2=0
9432 KFR3=0
9433 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9434 $(ISUB.GE.361.AND.ISUB.LE.380))
9435 $THEN
9436 KFR2=23
9437 IF(ISUB.EQ.141) THEN
9438 KCR2=PYCOMP(KFR2)
9439 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9440 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9441 KFR2=0
9442 ELSE
9443 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9444 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9445 MINT(72)=2
9446 MINT(74)=KFR2
9447 VINT(75)=TAUR2
9448 VINT(76)=GAMR2
9449 ENDIF
9450C...3 resonances at work: rho, omega, a
9451 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9452 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9453 MINT(72)=IRES
9454 IF(IRES.GE.1) THEN
9455 VINT(73)=XMAS(1)**2/VINT(2)
9456 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9457 TAUR1=VINT(73)
9458 GAMR1=VINT(74)
9459 KFR1=1
9460 ENDIF
9461 IF(IRES.GE.2) THEN
9462 VINT(75)=XMAS(2)**2/VINT(2)
9463 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9464 TAUR2=VINT(75)
9465 GAMR2=VINT(76)
9466 KFR2=2
9467 ENDIF
9468 IF(IRES.EQ.3) THEN
9469 VINT(77)=XMAS(3)**2/VINT(2)
9470 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9471 TAUR3=VINT(77)
9472 GAMR3=VINT(78)
9473 KFR3=3
9474 ENDIF
9475C...Charged current: rho+- and a+-
9476 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9477 MINT(72)=IRES
9478 IF(JRES.GE.1) THEN
9479 VINT(73)=YMAS(1)**2/VINT(2)
9480 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9481 KFR1=1
9482 TAUR1=VINT(73)
9483 GAMR1=VINT(74)
9484 ENDIF
9485 IF(JRES.GE.2) THEN
9486 VINT(75)=YMAS(2)**2/VINT(2)
9487 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9488 KFR2=2
9489 TAUR2=VINT(73)
9490 GAMR2=VINT(74)
9491 ENDIF
9492 KFR3=0
9493 ENDIF
9494 IF(ISUB.NE.141) THEN
9495 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9496
9497 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9498 MINT(72)=2
9499 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9500 MINT(72)=2
9501 MINT(74)=KFR3
9502 VINT(75)=TAUR3
9503 VINT(76)=GAMR3
9504 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9505 MINT(72)=2
9506 MINT(73)=KFR2
9507 VINT(73)=TAUR2
9508 VINT(74)=GAMR2
9509 MINT(74)=KFR3
9510 VINT(75)=TAUR3
9511 VINT(76)=GAMR3
9512 ELSEIF(KFR1.NE.0) THEN
9513 MINT(72)=1
9514 ELSEIF(KFR2.NE.0) THEN
9515 MINT(72)=1
9516 MINT(73)=KFR2
9517 VINT(73)=TAUR2
9518 VINT(74)=GAMR2
9519 ELSEIF(KFR3.NE.0) THEN
9520 MINT(72)=1
9521 MINT(73)=KFR3
9522 VINT(73)=TAUR3
9523 VINT(74)=GAMR3
9524 ELSE
9525 MINT(72)=0
9526 ENDIF
9527 ELSE
9528 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9529
9530 ELSEIF(KFR2.NE.0) THEN
9531 KFR1=KFR2
9532 TAUR1=TAUR2
9533 GAMR1=GAMR2
9534 MINT(72)=1
9535 MINT(73)=KFR1
9536 VINT(73)=TAUR1
9537 VINT(74)=GAMR1
9538 KFR2=0
9539 ELSE
9540 MINT(72)=0
9541 ENDIF
9542 ENDIF
9543 ENDIF
9544
9545C...Find product masses and minimum pT of process,
9546C...optionally with broadening according to a truncated Breit-Wigner.
9547 VINT(63)=0D0
9548 VINT(64)=0D0
9549 MINT(71)=0
9550 VINT(71)=CKIN(3)
9551 IF(MINT(82).GE.2) VINT(71)=0D0
9552 VINT(80)=1D0
9553 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9554 NBW=0
9555 DO 160 I=1,2
9556 PMMN(I)=0D0
9557 IF(KFPR(ISUB,I).EQ.0) THEN
9558 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9559 & PARP(41)) THEN
9560 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9561 ELSE
9562 NBW=NBW+1
9563C...This prevents SUSY/t particles from becoming too light.
9564 KFLW=KFPR(ISUB,I)
9565 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9566 KCW=PYCOMP(KFLW)
9567 PMMN(I)=PMAS(KCW,1)
9568 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9569 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9570 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9571 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9572 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9573 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9574 PMMN(I)=MIN(PMMN(I),PMSUM)
9575 ENDIF
9576 150 CONTINUE
9577 ELSEIF(KFLW.EQ.6) THEN
9578 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9579 ENDIF
9580 ENDIF
9581 160 CONTINUE
9582 IF(NBW.GE.1) THEN
9583 CKIN41=CKIN(41)
9584 CKIN43=CKIN(43)
9585 CKIN(41)=MAX(PMMN(1),CKIN(41))
9586 CKIN(43)=MAX(PMMN(2),CKIN(43))
9587 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9588 CKIN(41)=CKIN41
9589 CKIN(43)=CKIN43
9590 IF(MINT(51).EQ.1) THEN
9591 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9592 IF(MFAIL.EQ.1) THEN
9593 MSTI(61)=1
9594 RETURN
9595 ENDIF
9596 GOTO 100
9597 ENDIF
9598 VINT(63)=PQM3**2
9599 VINT(64)=PQM4**2
9600 ENDIF
9601 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9602 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9603 ENDIF
9604
9605C...Prepare for additional variable choices in 2 -> 3.
9606 IF(ISTSB.EQ.5) THEN
9607 VINT(201)=0D0
9608 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9609 VINT(206)=VINT(201)
9610 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9611 VINT(204)=PMAS(23,1)
9612 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9613 & VINT(204)=PMAS(24,1)
9614 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9615 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9616 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9617 & VINT(204)=VINT(201)
9618 VINT(209)=VINT(204)
9619 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9620 ENDIF
9621
9622C...Select incoming VDM particle (rho/omega/phi/J/psi).
9623 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9624 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9625 VRN=PYR(0)*SIGT(0,0,5)
9626 IF(MINT(101).LE.1) THEN
9627 I1MN=0
9628 I1MX=0
9629 ELSE
9630 I1MN=1
9631 I1MX=MINT(101)
9632 ENDIF
9633 IF(MINT(102).LE.1) THEN
9634 I2MN=0
9635 I2MX=0
9636 ELSE
9637 I2MN=1
9638 I2MX=MINT(102)
9639 ENDIF
9640 DO 180 I1=I1MN,I1MX
9641 KFV1=110*I1+3
9642 DO 170 I2=I2MN,I2MX
9643 KFV2=110*I2+3
9644 VRN=VRN-SIGT(I1,I2,5)
9645 IF(VRN.LE.0D0) GOTO 190
9646 170 CONTINUE
9647 180 CONTINUE
9648 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9649 IF(MINT(102).GE.2) MINT(104)=KFV2
9650 ENDIF
9651
9652 IF(ISTSB.EQ.0) THEN
9653C...Elastic scattering or single or double diffractive scattering.
9654
9655C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9656 MINT(103)=MINT(11)
9657 MINT(104)=MINT(12)
9658 PMM(1)=VINT(3)
9659 PMM(2)=VINT(4)
9660 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9661 JJ=ISUB-90
9662 VRN=PYR(0)*SIGT(0,0,JJ)
9663 IF(MINT(101).LE.1) THEN
9664 I1MN=0
9665 I1MX=0
9666 ELSE
9667 I1MN=1
9668 I1MX=MINT(101)
9669 ENDIF
9670 IF(MINT(102).LE.1) THEN
9671 I2MN=0
9672 I2MX=0
9673 ELSE
9674 I2MN=1
9675 I2MX=MINT(102)
9676 ENDIF
9677 DO 210 I1=I1MN,I1MX
9678 KFV1=110*I1+3
9679 DO 200 I2=I2MN,I2MX
9680 KFV2=110*I2+3
9681 VRN=VRN-SIGT(I1,I2,JJ)
9682 IF(VRN.LE.0D0) GOTO 220
9683 200 CONTINUE
9684 210 CONTINUE
9685 220 IF(MINT(101).GE.2) THEN
9686 MINT(103)=KFV1
9687 PMM(1)=PYMASS(KFV1)
9688 ENDIF
9689 IF(MINT(102).GE.2) THEN
9690 MINT(104)=KFV2
9691 PMM(2)=PYMASS(KFV2)
9692 ENDIF
9693 ENDIF
9694 VINT(67)=PMM(1)
9695 VINT(68)=PMM(2)
9696
9697C...Select mass for GVMD states (rejecting previous assignment).
9698 Q0S=4D0*PARP(15)**2
9699 Q1S=4D0*VINT(154)**2
9700 LOOP3=0
9701 230 LOOP3=LOOP3+1
9702 DO 240 JT=1,2
9703 IF(MINT(106+JT).EQ.3) THEN
9704 PS=VINT(2+JT)**2
9705 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9706 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9707 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9708 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9709 ENDIF
9710 240 CONTINUE
9711 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9712 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9713 & GOTO 230
9714 GOTO 100
9715 ENDIF
9716
9717C...Side/sides of diffractive system.
9718 MINT(17)=0
9719 MINT(18)=0
9720 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9721 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9722
9723C...Find masses of particles and minimal masses of diffractive states.
9724 DO 250 JT=1,2
9725 PDIF(JT)=PMM(JT)
9726 VINT(68+JT)=PDIF(JT)
9727 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9728 250 CONTINUE
9729 SH=VINT(2)
9730 SQM1=PMM(1)**2
9731 SQM2=PMM(2)**2
9732 SQM3=PDIF(1)**2
9733 SQM4=PDIF(2)**2
9734 SMRES1=(PMM(1)+PMRC)**2
9735 SMRES2=(PMM(2)+PMRC)**2
9736
9737C...Find elastic slope and lower limit diffractive slope.
9738 IHA=MAX(2,IABS(MINT(103))/110)
9739 IF(IHA.GE.5) IHA=1
9740 IHB=MAX(2,IABS(MINT(104))/110)
9741 IF(IHB.GE.5) IHB=1
9742 IF(ISUB.EQ.91) THEN
9743 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9744 ELSEIF(ISUB.EQ.92) THEN
9745 BMN=MAX(2D0,2D0*BHAD(IHB))
9746 ELSEIF(ISUB.EQ.93) THEN
9747 BMN=MAX(2D0,2D0*BHAD(IHA))
9748 ELSEIF(ISUB.EQ.94) THEN
9749 BMN=2D0*ALP*4D0
9750 ENDIF
9751
9752C...Determine maximum possible t range and coefficient of generation.
9753 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9754 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9755 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9756 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9757 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9758 & (SQM1*SQM4-SQM2*SQM3)/SH
9759 THL=-0.5D0*(THA+THB)
9760 THU=THC/THL
9761 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9762
9763C...Select diffractive mass/masses according to dm^2/m^2.
9764 LOOP3=0
9765 260 LOOP3=LOOP3+1
9766 DO 270 JT=1,2
9767 IF(MINT(16+JT).EQ.0) THEN
9768 PDIF(2+JT)=PDIF(JT)
9769 ELSE
9770 PMMIN=PDIF(JT)
9771 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9772 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9773 ENDIF
9774 270 CONTINUE
9775 SQM3=PDIF(3)**2
9776 SQM4=PDIF(4)**2
9777
9778C..Additional mass factors, including resonance enhancement.
9779 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9780 IF(LOOP3.LT.100) GOTO 260
9781 GOTO 100
9782 ENDIF
9783 IF(ISUB.EQ.92) THEN
9784 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9785 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9786 ELSEIF(ISUB.EQ.93) THEN
9787 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9788 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9789 ELSEIF(ISUB.EQ.94) THEN
9790 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9791 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9792 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9793 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9794 ENDIF
9795
9796C...Select t according to exp(Bmn*t) and correct to right slope.
9797 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9798 IF(ISUB.GE.92) THEN
9799 IF(ISUB.EQ.92) THEN
9800 BADD=2D0*ALP*LOG(SH/SQM3)
9801 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9802 ELSEIF(ISUB.EQ.93) THEN
9803 BADD=2D0*ALP*LOG(SH/SQM4)
9804 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9805 ELSEIF(ISUB.EQ.94) THEN
9806 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9807 ENDIF
9808 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9809 ENDIF
9810
9811C...Check whether m^2 and t choices are consistent.
9812 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9813 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9814 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9815 IF(THB.LE.1D-8) GOTO 260
9816 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9817 & (SQM1*SQM4-SQM2*SQM3)/SH
9818 THLM=-0.5D0*(THA+THB)
9819 THUM=THC/THLM
9820 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9821
9822C...Information to output.
9823 VINT(21)=1D0
9824 VINT(22)=0D0
9825 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9826 VINT(45)=TH
9827 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9828 VINT(63)=PDIF(3)**2
9829 VINT(64)=PDIF(4)**2
9830 VINT(283)=PMM(1)**2/4D0
9831 VINT(284)=PMM(2)**2/4D0
9832
9833C...Note: in the following, by In is meant the integral over the
9834C...quantity multiplying coefficient cn.
9835C...Choose tau according to h1(tau)/tau, where
9836C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9837C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9838C...I1/I5*c5*1/(tau+tau_R') +
9839C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9840C...I1/I7*c7*tau/(1.-tau), and
9841C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9842 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9843 CALL PYKLIM(1)
9844 IF(MINT(51).NE.0) THEN
9845 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9846 IF(MFAIL.EQ.1) THEN
9847 MSTI(61)=1
9848 RETURN
9849 ENDIF
9850 GOTO 100
9851 ENDIF
9852 RTAU=PYR(0)
9853 MTAU=1
9854 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9855 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9856 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9857 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9858 & MTAU=5
9859 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9860 & COEF(ISUB,5)) MTAU=6
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9862 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9863C...Additional check to handle techni-processes with extra resonance
9864C....Only modify tau treatment
9865 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9866 & THEN
9867 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9868 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9869 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9870 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9871 & +COEFX(ISUB,1)) MTAU=9
9872 ENDIF
9873 CALL PYKMAP(1,MTAU,PYR(0))
9874
9875C...2 -> 3, 4 processes:
9876C...Choose tau' according to h4(tau,tau')/tau', where
9877C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9878C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9879 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9880 CALL PYKLIM(4)
9881 IF(MINT(51).NE.0) THEN
9882 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9883 IF(MFAIL.EQ.1) THEN
9884 MSTI(61)=1
9885 RETURN
9886 ENDIF
9887 GOTO 100
9888 ENDIF
9889 RTAUP=PYR(0)
9890 MTAUP=1
9891 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9892 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9893 CALL PYKMAP(4,MTAUP,PYR(0))
9894 ENDIF
9895
9896C...Choose y* according to h2(y*), where
9897C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9898C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9899C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9900C...and c1 + c2 + c3 + c4 + c5 = 1.
9901 CALL PYKLIM(2)
9902 IF(MINT(51).NE.0) THEN
9903 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9904 IF(MFAIL.EQ.1) THEN
9905 MSTI(61)=1
9906 RETURN
9907 ENDIF
9908 GOTO 100
9909 ENDIF
9910 RYST=PYR(0)
9911 MYST=1
9912 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9913 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9914 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9915 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9916 & COEF(ISUB,11)) MYST=5
9917 CALL PYKMAP(2,MYST,PYR(0))
9918
9919C...2 -> 2 processes:
9920C...Choose cos(theta-hat) (cth) according to h3(cth), where
9921C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9922C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9923C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9924C...and c0 + c1 + c2 + c3 + c4 = 1.
9925 CALL PYKLIM(3)
9926 IF(MINT(51).NE.0) THEN
9927 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9928 IF(MFAIL.EQ.1) THEN
9929 MSTI(61)=1
9930 RETURN
9931 ENDIF
9932 GOTO 100
9933 ENDIF
9934 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9935 RCTH=PYR(0)
9936 MCTH=1
9937 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9938 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9939 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9940 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9941 & COEF(ISUB,16)) MCTH=5
9942 CALL PYKMAP(3,MCTH,PYR(0))
9943 ENDIF
9944
9945C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9946 IF(ISTSB.EQ.5) THEN
9947 CALL PYKMAP(5,0,0D0)
9948 IF(MINT(51).NE.0) THEN
9949 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9950 IF(MFAIL.EQ.1) THEN
9951 MSTI(61)=1
9952 RETURN
9953 ENDIF
9954 GOTO 100
9955 ENDIF
9956 ENDIF
9957
9958C...DIS as f + gamma* -> f process: set dummy values.
9959 ELSEIF(ISTSB.EQ.8) THEN
9960 VINT(21)=0.9D0
9961 VINT(22)=0D0
9962 VINT(23)=0D0
9963 VINT(47)=0D0
9964 VINT(48)=0D0
9965
9966C...Low-pT or multiple interactions (first semihard interaction).
9967 ELSEIF(ISTSB.EQ.9) THEN
9968 IF(MINT(35).LE.1) CALL PYMULT(3)
9969 IF(MINT(35).GE.2) CALL PYMIGN(3)
9970 ISUB=MINT(1)
9971
9972C...Study user-defined process: kinematics plus weight.
9973 ELSEIF(ISTSB.EQ.11) THEN
9974 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9975 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9976 MSTI(51)=0
9977 IF(NUP.LE.0) THEN
9978 MINT(51)=2
9979 MSTI(51)=1
9980 IF(MINT(82).EQ.1) THEN
9981 NGEN(0,1)=NGEN(0,1)-1
9982 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9983 ENDIF
9984 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9985 RETURN
9986 ENDIF
9987
9988C...Extract cross section event weight.
9989 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9990 SIGS=1D-9*XWGTUP
9991 ELSE
9992 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9993 ENDIF
9994 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
9995 VINT(97)=SIGN(1D0,XWGTUP)
9996 ELSE
9997 VINT(97)=1D-9*XWGTUP
9998 ENDIF
9999
10000C...Construct 'trivial' kinematical variables needed.
10001 KFL1=IDUP(1)
10002 KFL2=IDUP(2)
10003 VINT(41)=PUP(4,1)/EBMUP(1)
10004 VINT(42)=PUP(4,2)/EBMUP(2)
10005 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10006 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10007 & '(listing follows):')
10008 CALL PYLIST(7)
10009 ENDIF
10010 VINT(21)=VINT(41)*VINT(42)
10011 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10012 VINT(44)=VINT(21)*VINT(2)
10013 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10014 VINT(55)=SCALUP
10015 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10016 VINT(56)=VINT(55)**2
10017 VINT(57)=AQEDUP
10018 VINT(58)=AQCDUP
10019
10020C...Construct other kinematical variables needed (approximately).
10021 VINT(23)=0D0
10022 VINT(26)=VINT(21)
10023 VINT(45)=-0.5D0*VINT(44)
10024 VINT(46)=-0.5D0*VINT(44)
10025 VINT(49)=VINT(43)
10026 VINT(50)=VINT(44)
10027 VINT(51)=VINT(55)
10028 VINT(52)=VINT(56)
10029 VINT(53)=VINT(55)
10030 VINT(54)=VINT(56)
10031 VINT(25)=0D0
10032 VINT(48)=0D0
10033 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10034 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10035 DO 280 IUP=3,NUP
10036 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10037 & '(PYRAND:) unacceptable ISTUP code for particles')
10038 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10039 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10040 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10041 & PUP(2,IUP)**2)
10042 280 CONTINUE
10043 VINT(47)=SQRT(VINT(48))
10044 ENDIF
10045
10046C...Choose azimuthal angle.
10047 VINT(24)=0D0
10048 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10049
10050C...Check against user cuts on kinematics at parton level.
10051 MINT(51)=0
10052 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10053 IF(MINT(51).NE.0) THEN
10054 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10055 IF(MFAIL.EQ.1) THEN
10056 MSTI(61)=1
10057 RETURN
10058 ENDIF
10059 GOTO 100
10060 ENDIF
10061 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10062 MCUT=0
10063 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10064 & CALL PYKCUT(MCUT)
10065 IF(MCUT.NE.0) THEN
10066 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10067 IF(MFAIL.EQ.1) THEN
10068 MSTI(61)=1
10069 RETURN
10070 ENDIF
10071 GOTO 100
10072 ENDIF
10073 ENDIF
10074
10075 IF(ISTSB.LE.10) THEN
10076C... If internal process, call PYSIGH
10077 CALL PYSIGH(NCHN,SIGS)
10078 ELSE
10079C... If external process, still have to set MI starting scale
10080 IF (MSTP(86).EQ.1) THEN
10081C... Limit phase space by xT2 of hard interaction
10082C... (gives undercounting of MI when ext proc != dijets)
10083 XT2GMX = VINT(25)
10084 ELSE
10085C... All accessible phase space allowed
10086C... (gives double counting of MI when ext proc = dijets)
10087 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10088 ENDIF
10089 VINT(62)=0.25D0*XT2GMX*VINT(2)
10090 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10091 ENDIF
10092
10093 SIGSOR=SIGS
10094 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10095
10096C...Multiply cross section by lepton -> photon flux factor.
10097 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10098 SIGS=WTGAGA*SIGS
10099 DO 290 ICHN=1,NCHN
10100 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10101 290 CONTINUE
10102 SIGLPT=WTGAGA*SIGLPT
10103 ENDIF
10104
10105C...Multiply cross-section by user-defined weights.
10106 IF(MSTP(173).EQ.1) THEN
10107 SIGS=PARP(173)*SIGS
10108 DO 300 ICHN=1,NCHN
10109 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10110 300 CONTINUE
10111 SIGLPT=PARP(173)*SIGLPT
10112 ENDIF
10113 WTXS=1D0
10114 SIGSWT=SIGS
10115 VINT(99)=1D0
10116 VINT(100)=1D0
10117 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10118 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10119 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10120 SIGSWT=WTXS*SIGS
10121 VINT(99)=WTXS
10122 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10123 ENDIF
10124
10125C...Calculations for Monte Carlo estimate of all cross-sections.
10126 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10127 IF(MSTP(142).LE.1) THEN
10128 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10129 ELSE
10130 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10131 ENDIF
10132 ELSEIF(MINT(82).EQ.1) THEN
10133 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10134 ENDIF
10135 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10136 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10137
10138C...Multiple interactions: store results of cross-section calculation.
10139 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10140 VINT(153)=SIGSOR
10141 IF(MINT(35).LE.1) CALL PYMULT(4)
10142 IF(MINT(35).GE.2) CALL PYMIGN(4)
10143 ENDIF
10144
10145C...Ratio of actual to maximum cross section.
10146 IF(ISTSB.NE.11) THEN
10147 VIOL=SIGSWT/XSEC(ISUB,1)
10148 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10149 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10150 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10151 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10152 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10153 ELSE
10154 VIOL=1D0
10155 ENDIF
10156
10157C...Check that weight not negative.
10158 IF(MSTP(123).LE.0) THEN
10159 IF(VIOL.LT.-1D-3) THEN
10160 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10161 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10162 & VINT(22),VINT(23),VINT(26)
10163 CALL PYSTOP(2)
10164 ENDIF
10165 ELSE
10166 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10167 VINT(109)=VIOL
10168 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10169 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10170 & VINT(22),VINT(23),VINT(26)
10171 ENDIF
10172 ENDIF
10173
10174C...Weighting using estimate of maximum of differential cross-section.
10175 RATND=1D0
10176 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10177 IF(VIOL.LT.PYR(0)) THEN
10178 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10179 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10180 GOTO 100
10181 ENDIF
10182 ELSEIF(MFAIL.EQ.0) THEN
10183 RATND=SIGLPT/XSEC(95,1)
10184 VIOL=VIOL/RATND
10185 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10186 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10187 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10188 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10189 ISUB=0
10190 GOTO 100
10191 ENDIF
10192 IF(VIOL.LT.PYR(0)) THEN
10193 GOTO 140
10194 ENDIF
10195 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10196 IF(VIOL.LT.PYR(0)) THEN
10197 MSTI(61)=1
10198 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10199 RETURN
10200 ENDIF
10201 ELSE
10202 RATND=SIGLPT/XSEC(95,1)
10203 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10204 MSTI(61)=1
10205 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10206 RETURN
10207 ENDIF
10208 VIOL=VIOL/RATND
10209 IF(VIOL.LT.PYR(0)) THEN
10210 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10211 GOTO 100
10212 ENDIF
10213 ENDIF
10214
10215C...Check for possible violation of estimated maximum of differential
10216C...cross-section used in weighting.
10217 IF(MSTP(123).LE.0) THEN
10218 IF(VIOL.GT.1D0) THEN
10219 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10220 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10221 & VINT(22),VINT(23),VINT(26)
10222 CALL PYSTOP(2)
10223 ENDIF
10224 ELSEIF(MSTP(123).EQ.1) THEN
10225 IF(VIOL.GT.VINT(108)) THEN
10226 VINT(108)=VIOL
10227 IF(VIOL.GT.1.0001D0) THEN
10228 MINT(10)=1
10229 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10230 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10231 & VINT(22),VINT(23),VINT(26)
10232 ENDIF
10233 ENDIF
10234 ELSEIF(VIOL.GT.VINT(108)) THEN
10235 VINT(108)=VIOL
10236 IF(VIOL.GT.1D0) THEN
10237 MINT(10)=1
10238 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10239 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10240 & THEN
10241 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10242 IF(KFPR(ISUB,1).LE.9) THEN
10243 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10244 & XMAXUP(KFPR(ISUB,1))
10245 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10246 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10247 & XMAXUP(KFPR(ISUB,1))
10248 ELSE
10249 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10250 & XMAXUP(KFPR(ISUB,1))
10251 ENDIF
10252 ENDIF
10253 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10254 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10255 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10256 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10257 & XSEC(0,1)=XSEC(0,1)+XDIF
10258 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10259 & VINT(22),VINT(23),VINT(26)
10260 IF(ISUB.LE.9) THEN
10261 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10262 ELSEIF(ISUB.LE.99) THEN
10263 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10264 ELSE
10265 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10266 ENDIF
10267 ENDIF
10268 VINT(108)=1D0
10269 ENDIF
10270 ENDIF
10271
10272C...Multiple interactions: choose impact parameter (if not already done).
10273 IF(MINT(39).EQ.0) VINT(148)=1D0
10274 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10275 &MSTP(82).GE.3) THEN
10276 IF(MINT(35).LE.1) CALL PYMULT(5)
10277 IF(MINT(35).GE.2) CALL PYMIGN(5)
10278 IF(VINT(150).LT.PYR(0)) THEN
10279 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10280 IF(MFAIL.EQ.1) THEN
10281 MSTI(61)=1
10282 RETURN
10283 ENDIF
10284 GOTO 100
10285 ENDIF
10286 ENDIF
10287 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10288 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10289 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10290 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10291 ENDIF
10292 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10293
10294C...Choose flavour of reacting partons (and subprocess).
10295 IF(ISTSB.GE.11) GOTO 320
10296 RSIGS=SIGS*PYR(0)
10297 QT2=VINT(48)
10298 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10299 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10300 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10301 &PYR(0).GT.RQQBAR)) THEN
10302 DO 310 ICHN=1,NCHN
10303 KFL1=ISIG(ICHN,1)
10304 KFL2=ISIG(ICHN,2)
10305 MINT(2)=ISIG(ICHN,3)
10306 RSIGS=RSIGS-SIGH(ICHN)
10307 IF(RSIGS.LE.0D0) GOTO 320
10308 310 CONTINUE
10309
10310C...Multiple interactions: choose qqbar preferentially at small pT.
10311 ELSEIF(ISUB.EQ.96) THEN
10312 MINT(105)=MINT(103)
10313 MINT(109)=MINT(107)
10314 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10315 MINT(105)=MINT(104)
10316 MINT(109)=MINT(108)
10317 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10318 MINT(1)=11
10319 MINT(2)=1
10320 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10321
10322C...Low-pT: choose string drawing configuration.
10323 ELSE
10324 KFL1=21
10325 KFL2=21
10326 RSIGS=6D0*PYR(0)
10327 MINT(2)=1
10328 IF(RSIGS.GT.1D0) MINT(2)=2
10329 IF(RSIGS.GT.2D0) MINT(2)=3
10330 ENDIF
10331
10332C...Reassign QCD process. Partons before initial state radiation.
10333 320 IF(MINT(2).GT.10) THEN
10334 MINT(1)=MINT(2)/10
10335 MINT(2)=MOD(MINT(2),10)
10336 ENDIF
10337 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10338 &NGEN(MINT(1),2)+1
10339 MINT(15)=KFL1
10340 MINT(16)=KFL2
10341 MINT(13)=MINT(15)
10342 MINT(14)=MINT(16)
10343 VINT(141)=VINT(41)
10344 VINT(142)=VINT(42)
10345 VINT(151)=0D0
10346 VINT(152)=0D0
10347
10348C...Calculate x value of photon for parton inside photon inside e.
10349 DO 350 JT=1,2
10350 MINT(18+JT)=0
10351 VINT(154+JT)=0D0
10352 MSPLI=0
10353 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10354 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10355 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10356 IF(MSPLI.EQ.2) THEN
10357 KFLH=MINT(14+JT)
10358 XHRD=VINT(140+JT)
10359 Q2HRD=VINT(54)
10360 MINT(105)=MINT(102+JT)
10361 MINT(109)=MINT(106+JT)
10362 VINT(120)=VINT(2+JT)
10363C.... ALICE
10364C.... Store side in MINT(124)
10365 MINT(124) = JT
10366C....
10367 IF(MSTP(57).LE.1) THEN
10368 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10369 ELSE
10370 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10371 ENDIF
10372 WTMX=4D0*XPQ(KFLH)
10373 IF(MSTP(13).EQ.2) THEN
10374 Q2PMS=Q2HRD/PMAS(11,1)**2
10375 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10376 ENDIF
10377 330 XE=XHRD**PYR(0)
10378 XG=MIN(1D0-1D-10,XHRD/XE)
10379 IF(MSTP(57).LE.1) THEN
10380 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10381 ELSE
10382 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10383 ENDIF
10384 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10385 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10386 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10387 MINT(18+JT)=1
10388 VINT(154+JT)=XE
10389 DO 340 KFLS=-25,25
10390 XSFX(JT,KFLS)=XPQ(KFLS)
10391 340 CONTINUE
10392 ENDIF
10393 350 CONTINUE
10394
10395C...Pick scale where photon is resolved.
10396 Q0S=PARP(15)**2
10397 Q1S=VINT(154)**2
10398 VINT(283)=0D0
10399 IF(MINT(107).EQ.3) THEN
10400 IF(MSTP(66).EQ.1) THEN
10401 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10402 ELSEIF(MSTP(66).EQ.2) THEN
10403 PS=VINT(3)**2
10404 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10405 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10406 Q2INT=SQRT(Q0S*Q2EFF)
10407 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10408 ELSEIF(MSTP(66).EQ.3) THEN
10409 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10410 ELSEIF(MSTP(66).GE.4) THEN
10411 PS=0.25D0*VINT(3)**2
10412 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10413 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10414 ENDIF
10415 ENDIF
10416 VINT(284)=0D0
10417 IF(MINT(108).EQ.3) THEN
10418 IF(MSTP(66).EQ.1) THEN
10419 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10420 ELSEIF(MSTP(66).EQ.2) THEN
10421 PS=VINT(4)**2
10422 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10423 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10424 Q2INT=SQRT(Q0S*Q2EFF)
10425 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10426 ELSEIF(MSTP(66).EQ.3) THEN
10427 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10428 ELSEIF(MSTP(66).GE.4) THEN
10429 PS=0.25D0*VINT(4)**2
10430 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10431 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10432 ENDIF
10433 ENDIF
10434 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10435
10436C...Format statements for differential cross-section maximum violations.
10437 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10438 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10439 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10440 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10441 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10442 &'in event',1X,I7)
10443 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10444 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10445 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10446 &'in event',1X,I7)
10447 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10448 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10449 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10450 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10451 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10452 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10453
10454 RETURN
10455 END
10456
10457C*********************************************************************
10458
10459C...PYSCAT
10460C...Finds outgoing flavours and event type; sets up the kinematics
10461C...and colour flow of the hard scattering
10462
10463 SUBROUTINE PYSCAT
10464
10465C...Double precision and integer declarations
10466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10467 IMPLICIT INTEGER(I-N)
10468 INTEGER PYK,PYCHGE,PYCOMP
10469C...Parameter statement to help give large particle numbers.
10470 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10471 &KEXCIT=4000000,KDIMEN=5000000)
10472C...Parameter statement for maximum size of showers.
10473 PARAMETER (MAXNUR=1000)
10474
10475C...User process event common block.
10476 INTEGER MAXNUP
10477 PARAMETER (MAXNUP=500)
10478 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10479 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10480 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10481 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10482 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10483 SAVE /HEPEUP/
10484
10485C...Commonblocks.
10486 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10487 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10488 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10489 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10490 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10491 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10492 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10493 COMMON/PYINT1/MINT(400),VINT(400)
10494 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10495 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10496 COMMON/PYINT4/MWID(500),WIDS(500,5)
10497 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10498 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10499 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10500 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10501 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10502 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10503 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10504 &/PYTCSM/,/PYPUED/
10505C...Local arrays and saved variables
10506 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10507 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10508 INTEGER IOKFLA(6),IIFLAV
10509C...UED related declarations:
10510C...equivalences between ordered particles (451->475)
10511C...and UED particle code (5 000 000 + id)
10512 DIMENSION IUEDEQ(475),MUED(2)
10513 DATA (IUEDEQ(I),I=451,475)/
10514 & 6100001,6100002,6100003,6100004,6100005,6100006,
10515 & 5100001,5100002,5100003,5100004,5100005,5100006,
10516 & 6100011,6100013,6100015,
10517 & 5100012,5100011,5100014,5100013,5100016,5100015,
10518 & 5100021,5100022,5100023,5100024/
10519 SAVE VINTSV
10520
10521C...Read out process
10522 ISUB=MINT(1)
10523 ISUBSV=ISUB
10524
10525C...Restore information for low-pT processes
10526 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10527 DO 100 J=41,66
10528 100 VINT(J)=VINTSV(J)
10529 ENDIF
10530
10531C...Convert H' or A process into equivalent H one
10532 IHIGG=1
10533 KFHIGG=25
10534 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10535 &ISUB.LE.190)) THEN
10536 IHIGG=2
10537 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10538 KFHIGG=33+IHIGG
10539 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10540 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10541 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10542 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10543 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10544 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10545 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10546 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10547 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10548 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10549 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10550 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10551 ENDIF
10552
10553 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10554
10555C...Convert bottomonium process into equivalent charmonium ones.
10556 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10557
10558C...Choice of subprocess, number of documentation lines
10559 IDOC=6+ISET(ISUB)
10560 IF(ISUB.EQ.95) IDOC=8
10561 IF(ISET(ISUB).EQ.5) IDOC=9
10562 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10563 MINT(3)=IDOC-6
10564 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10565 MINT(4)=IDOC
10566 IPU1=MINT(84)+1
10567 IPU2=MINT(84)+2
10568 IPU3=MINT(84)+3
10569 IPU4=MINT(84)+4
10570 IPU5=MINT(84)+5
10571 IPU6=MINT(84)+6
10572
10573C...Reset K, P and V vectors. Store incoming particles
10574 DO 120 JT=1,MSTP(126)+100
10575 I=MINT(83)+JT
10576 IF(I.GT.MSTU(4)) GOTO 120
10577 DO 110 J=1,5
10578 K(I,J)=0
10579 P(I,J)=0D0
10580 V(I,J)=0D0
10581 110 CONTINUE
10582 120 CONTINUE
10583 DO 140 JT=1,2
10584 I=MINT(83)+JT
10585 K(I,1)=21
10586 K(I,2)=MINT(10+JT)
10587 DO 130 J=1,5
10588 P(I,J)=VINT(285+5*JT+J)
10589 130 CONTINUE
10590 140 CONTINUE
10591 MINT(6)=2
10592 KFRES=0
10593
10594C...Store incoming partons in their CM-frame. Save pdf value.
10595 SH=VINT(44)
10596 SHR=SQRT(SH)
10597 SHP=VINT(26)*VINT(2)
10598 SHPR=SQRT(SHP)
10599 SHUSER=SHR
10600 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10601 DO 150 JT=1,2
10602 I=MINT(84)+JT
10603 K(I,1)=14
10604 K(I,2)=MINT(14+JT)
10605 K(I,3)=MINT(83)+2+JT
10606 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10607 P(I,4)=0.5D0*SHUSER
10608 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10609 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10610 ELSE
10611 VINT(38+JT)=1D0
10612 ENDIF
10613 150 CONTINUE
10614
10615C...Copy incoming partons to documentation lines
10616 DO 170 JT=1,2
10617 I1=MINT(83)+4+JT
10618 I2=MINT(84)+JT
10619 K(I1,1)=21
10620 K(I1,2)=K(I2,2)
10621 K(I1,3)=I1-2
10622 DO 160 J=1,5
10623 P(I1,J)=P(I2,J)
10624 160 CONTINUE
10625 170 CONTINUE
10626
10627C...Choose new quark/lepton flavour for relevant annihilation graphs
10628 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10629 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10630 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10631 IGLGA=21
10632 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10633 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10634 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10635 DO 190 I=1,MDCY(IGLGA,3)
10636 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10637 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10638 IF(RKFL.LE.0D0) GOTO 200
10639 190 CONTINUE
10640 200 CONTINUE
10641 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10642 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10643 IF(KFLF.GE.4) GOTO 180
10644 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10645 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10646 KFLF=4
10647 MINT(2)=MINT(2)-2
10648 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10649 & OR.ISUB.EQ.316) THEN
10650 KFLF=5
10651 MINT(2)=MINT(2)-4
10652 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10653 & .AND.IABS(KFLF).GE.3) THEN
10654 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10655 & VINT(44)**2
10656 FACCIB=VINT(46)**2/RTCM(41)**4
10657 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10658 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10659 KFLF=5
10660 MINT(2)=1
10661 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10662 IF(KFLF.EQ.5) GOTO 180
10663 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10664 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10665 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10666 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10667 ENDIF
10668 ENDIF
10669
10670C...Final state flavours and colour flow: default values
10671 JS=1
10672 MINT(21)=MINT(15)
10673 MINT(22)=MINT(16)
10674 MINT(23)=0
10675 MINT(24)=0
10676 KCC=20
10677 KCS=ISIGN(1,MINT(15))
10678
10679 IF(ISET(ISUB).EQ.11) THEN
10680C...User-defined processes: find products
10681 MINT(3)=0
10682 DO 210 IUP=3,NUP
10683 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10684 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10685 MINT(21+IUP)=IDUP(IUP)
10686 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10687 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10688 ELSEIF(IDUP(IUP).EQ.0) THEN
10689 ELSE
10690 MINT(3)=MINT(3)+1
10691 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10692 ENDIF
10693 210 CONTINUE
10694
10695 ELSEIF(ISUB.LE.10) THEN
10696 IF(ISUB.EQ.1) THEN
10697C...f + fbar -> gamma*/Z0
10698 KFRES=23
10699
10700 ELSEIF(ISUB.EQ.2) THEN
10701C...f + fbar' -> W+/-
10702 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10703 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10704 KFRES=ISIGN(24,KCH1+KCH2)
10705
10706 ELSEIF(ISUB.EQ.3) THEN
10707C...f + fbar -> h0 (or H0, or A0)
10708 KFRES=KFHIGG
10709
10710 ELSEIF(ISUB.EQ.4) THEN
10711C...gamma + W+/- -> W+/-
10712
10713 ELSEIF(ISUB.EQ.5) THEN
10714C...Z0 + Z0 -> h0
10715 XH=SH/SHP
10716 MINT(21)=MINT(15)
10717 MINT(22)=MINT(16)
10718 PMQ(1)=PYMASS(MINT(21))
10719 PMQ(2)=PYMASS(MINT(22))
10720 220 JT=INT(1.5D0+PYR(0))
10721 ZMIN=2D0*PMQ(JT)/SHPR
10722 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10723 & (SHPR*(SHPR-PMQ(3-JT)))
10724 ZMAX=MIN(1D0-XH,ZMAX)
10725 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10726 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10727 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10728 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10729 IF(SQC1.LT.1D-8) GOTO 220
10730 C1=SQRT(SQC1)
10731 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10732 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10733 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10734 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10735 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10736 IF(SQC1.LT.1D-8) GOTO 220
10737 C1=SQRT(SQC1)
10738 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10739 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10740 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10741 PHIR=PARU(2)*PYR(0)
10742 CPHI=COS(PHIR)
10743 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10744 & SQRT(1D0-CTHE(2)**2)*CPHI
10745 Z1=2D0-Z(JT)
10746 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10747 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10748 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10749 & PMQ(3-JT)**2/SHP))
10750 ZMIN=2D0*PMQ(3-JT)/SHPR
10751 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10752 ZMAX=MIN(1D0-XH,ZMAX)
10753 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10754 KCC=22
10755 KFRES=25
10756
10757 ELSEIF(ISUB.EQ.6) THEN
10758C...Z0 + W+/- -> W+/-
10759
10760 ELSEIF(ISUB.EQ.7) THEN
10761C...W+ + W- -> Z0
10762
10763 ELSEIF(ISUB.EQ.8) THEN
10764C...W+ + W- -> h0
10765 XH=SH/SHP
10766 230 DO 260 JT=1,2
10767 I=MINT(14+JT)
10768 IA=IABS(I)
10769 IF(IA.LE.10) THEN
10770 RVCKM=VINT(180+I)*PYR(0)
10771 DO 240 J=1,MSTP(1)
10772 IB=2*J-1+MOD(IA,2)
10773 IPM=(5-ISIGN(1,I))/2
10774 IDC=J+MDCY(IA,2)+2
10775 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10776 MINT(20+JT)=ISIGN(IB,I)
10777 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10778 IF(RVCKM.LE.0D0) GOTO 250
10779 240 CONTINUE
10780 ELSE
10781 IB=2*((IA+1)/2)-1+MOD(IA,2)
10782 MINT(20+JT)=ISIGN(IB,I)
10783 ENDIF
10784 250 PMQ(JT)=PYMASS(MINT(20+JT))
10785 260 CONTINUE
10786 JT=INT(1.5D0+PYR(0))
10787 ZMIN=2D0*PMQ(JT)/SHPR
10788 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10789 & (SHPR*(SHPR-PMQ(3-JT)))
10790 ZMAX=MIN(1D0-XH,ZMAX)
10791 IF(ZMIN.GE.ZMAX) GOTO 230
10792 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10793 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10794 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10795 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10796 IF(SQC1.LT.1D-8) GOTO 230
10797 C1=SQRT(SQC1)
10798 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10799 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10800 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10801 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10802 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10803 IF(SQC1.LT.1D-8) GOTO 230
10804 C1=SQRT(SQC1)
10805 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10806 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10807 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10808 PHIR=PARU(2)*PYR(0)
10809 CPHI=COS(PHIR)
10810 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10811 & SQRT(1D0-CTHE(2)**2)*CPHI
10812 Z1=2D0-Z(JT)
10813 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10814 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10815 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10816 & PMQ(3-JT)**2/SHP))
10817 ZMIN=2D0*PMQ(3-JT)/SHPR
10818 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10819 ZMAX=MIN(1D0-XH,ZMAX)
10820 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10821 KCC=22
10822 KFRES=25
10823
10824 ELSEIF(ISUB.EQ.10) THEN
10825C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10826 IF(MINT(2).EQ.1) THEN
10827 KCC=22
10828 ELSE
10829C...W exchange: need to mix flavours according to CKM matrix
10830 DO 280 JT=1,2
10831 I=MINT(14+JT)
10832 IA=IABS(I)
10833 IF(IA.LE.10) THEN
10834 RVCKM=VINT(180+I)*PYR(0)
10835 DO 270 J=1,MSTP(1)
10836 IB=2*J-1+MOD(IA,2)
10837 IPM=(5-ISIGN(1,I))/2
10838 IDC=J+MDCY(IA,2)+2
10839 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10840 MINT(20+JT)=ISIGN(IB,I)
10841 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10842 IF(RVCKM.LE.0D0) GOTO 280
10843 270 CONTINUE
10844 ELSE
10845 IB=2*((IA+1)/2)-1+MOD(IA,2)
10846 MINT(20+JT)=ISIGN(IB,I)
10847 ENDIF
10848 280 CONTINUE
10849 KCC=22
10850 ENDIF
10851 ENDIF
10852
10853 ELSEIF(ISUB.LE.20) THEN
10854 IF(ISUB.EQ.11) THEN
10855C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10856 KCC=MINT(2)
10857 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10858
10859 ELSEIF(ISUB.EQ.12) THEN
10860C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10861 MINT(21)=ISIGN(KFLF,MINT(15))
10862 MINT(22)=-MINT(21)
10863 KCC=4
10864
10865 ELSEIF(ISUB.EQ.13) THEN
10866C...f + fbar -> g + g; th arbitrary
10867 MINT(21)=21
10868 MINT(22)=21
10869 KCC=MINT(2)+4
10870
10871 ELSEIF(ISUB.EQ.14) THEN
10872C...f + fbar -> g + gamma; th arbitrary
10873 IF(PYR(0).GT.0.5D0) JS=2
10874 MINT(20+JS)=21
10875 MINT(23-JS)=22
10876 KCC=17+JS
10877
10878 ELSEIF(ISUB.EQ.15) THEN
10879C...f + fbar -> g + Z0; th arbitrary
10880 IF(PYR(0).GT.0.5D0) JS=2
10881 MINT(20+JS)=21
10882 MINT(23-JS)=23
10883 KCC=17+JS
10884
10885 ELSEIF(ISUB.EQ.16) THEN
10886C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10887 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10888 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10889 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10890 MINT(20+JS)=21
10891 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10892 KCC=17+JS
10893
10894 ELSEIF(ISUB.EQ.17) THEN
10895C...f + fbar -> g + h0; th arbitrary
10896 IF(PYR(0).GT.0.5D0) JS=2
10897 MINT(20+JS)=21
10898 MINT(23-JS)=25
10899 KCC=17+JS
10900
10901 ELSEIF(ISUB.EQ.18) THEN
10902C...f + fbar -> gamma + gamma; th arbitrary
10903 MINT(21)=22
10904 MINT(22)=22
10905
10906 ELSEIF(ISUB.EQ.19) THEN
10907C...f + fbar -> gamma + Z0; th arbitrary
10908 IF(PYR(0).GT.0.5D0) JS=2
10909 MINT(20+JS)=22
10910 MINT(23-JS)=23
10911
10912 ELSEIF(ISUB.EQ.20) THEN
10913C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10914C...(p(fbar')-p(W+))**2
10915 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10916 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10917 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10918 MINT(20+JS)=22
10919 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10920 ENDIF
10921
10922 ELSEIF(ISUB.LE.30) THEN
10923 IF(ISUB.EQ.21) THEN
10924C...f + fbar -> gamma + h0; th arbitrary
10925 IF(PYR(0).GT.0.5D0) JS=2
10926 MINT(20+JS)=22
10927 MINT(23-JS)=25
10928
10929 ELSEIF(ISUB.EQ.22) THEN
10930C...f + fbar -> Z0 + Z0; th arbitrary
10931 MINT(21)=23
10932 MINT(22)=23
10933
10934 ELSEIF(ISUB.EQ.23) THEN
10935C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10936 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10937 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10938 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10939 MINT(20+JS)=23
10940 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10941
10942 ELSEIF(ISUB.EQ.24) THEN
10943C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10944 IF(PYR(0).GT.0.5D0) JS=2
10945 MINT(20+JS)=23
10946 MINT(23-JS)=KFHIGG
10947
10948 ELSEIF(ISUB.EQ.25) THEN
10949C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10950 MINT(21)=-ISIGN(24,MINT(15))
10951 MINT(22)=-MINT(21)
10952
10953 ELSEIF(ISUB.EQ.26) THEN
10954C...f + fbar' -> W+/- + h0 (or H0, or A0);
10955C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10958 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10959 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10960 MINT(23-JS)=KFHIGG
10961
10962 ELSEIF(ISUB.EQ.27) THEN
10963C...f + fbar -> h0 + h0
10964
10965 ELSEIF(ISUB.EQ.28) THEN
10966C...f + g -> f + g; th = (p(f)-p(f))**2
10967 IF(MINT(15).EQ.21) JS=2
10968 KCC=MINT(2)+6
10969 IF(MINT(15).EQ.21) KCC=KCC+2
10970 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10971 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10972
10973 ELSEIF(ISUB.EQ.29) THEN
10974C...f + g -> f + gamma; th = (p(f)-p(f))**2
10975 IF(MINT(15).EQ.21) JS=2
10976 MINT(23-JS)=22
10977 KCC=15+JS
10978 KCS=ISIGN(1,MINT(14+JS))
10979
10980 ELSEIF(ISUB.EQ.30) THEN
10981C...f + g -> f + Z0; th = (p(f)-p(f))**2
10982 IF(MINT(15).EQ.21) JS=2
10983 MINT(23-JS)=23
10984 KCC=15+JS
10985 KCS=ISIGN(1,MINT(14+JS))
10986 ENDIF
10987
10988 ELSEIF(ISUB.LE.40) THEN
10989 IF(ISUB.EQ.31) THEN
10990C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10991 IF(MINT(15).EQ.21) JS=2
10992 I=MINT(14+JS)
10993 IA=IABS(I)
10994 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
10995 RVCKM=VINT(180+I)*PYR(0)
10996 DO 290 J=1,MSTP(1)
10997 IB=2*J-1+MOD(IA,2)
10998 IPM=(5-ISIGN(1,I))/2
10999 IDC=J+MDCY(IA,2)+2
11000 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11001 MINT(20+JS)=ISIGN(IB,I)
11002 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11003 IF(RVCKM.LE.0D0) GOTO 300
11004 290 CONTINUE
11005 300 KCC=15+JS
11006 KCS=ISIGN(1,MINT(14+JS))
11007
11008 ELSEIF(ISUB.EQ.32) THEN
11009C...f + g -> f + h0; th = (p(f)-p(f))**2
11010 IF(MINT(15).EQ.21) JS=2
11011 MINT(23-JS)=25
11012 KCC=15+JS
11013 KCS=ISIGN(1,MINT(14+JS))
11014
11015 ELSEIF(ISUB.EQ.33) THEN
11016C...f + gamma -> f + g; th=(p(f)-p(f))**2
11017 IF(MINT(15).EQ.22) JS=2
11018 MINT(23-JS)=21
11019 KCC=24+JS
11020 KCS=ISIGN(1,MINT(14+JS))
11021
11022 ELSEIF(ISUB.EQ.34) THEN
11023C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11024 IF(MINT(15).EQ.22) JS=2
11025 KCC=22
11026 KCS=ISIGN(1,MINT(14+JS))
11027
11028 ELSEIF(ISUB.EQ.35) THEN
11029C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11030 IF(MINT(15).EQ.22) JS=2
11031 MINT(23-JS)=23
11032 KCC=22
11033
11034 ELSEIF(ISUB.EQ.36) THEN
11035C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11036 IF(MINT(15).EQ.22) JS=2
11037 I=MINT(14+JS)
11038 IA=IABS(I)
11039 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11040 IF(IA.LE.10) THEN
11041 RVCKM=VINT(180+I)*PYR(0)
11042 DO 310 J=1,MSTP(1)
11043 IB=2*J-1+MOD(IA,2)
11044 IPM=(5-ISIGN(1,I))/2
11045 IDC=J+MDCY(IA,2)+2
11046 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11047 MINT(20+JS)=ISIGN(IB,I)
11048 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11049 IF(RVCKM.LE.0D0) GOTO 320
11050 310 CONTINUE
11051 ELSE
11052 IB=2*((IA+1)/2)-1+MOD(IA,2)
11053 MINT(20+JS)=ISIGN(IB,I)
11054 ENDIF
11055 320 KCC=22
11056
11057 ELSEIF(ISUB.EQ.37) THEN
11058C...f + gamma -> f + h0
11059
11060 ELSEIF(ISUB.EQ.38) THEN
11061C...f + Z0 -> f + g
11062
11063 ELSEIF(ISUB.EQ.39) THEN
11064C...f + Z0 -> f + gamma
11065
11066 ELSEIF(ISUB.EQ.40) THEN
11067C...f + Z0 -> f + Z0
11068 ENDIF
11069
11070 ELSEIF(ISUB.LE.50) THEN
11071 IF(ISUB.EQ.41) THEN
11072C...f + Z0 -> f' + W+/-
11073
11074 ELSEIF(ISUB.EQ.42) THEN
11075C...f + Z0 -> f + h0
11076
11077 ELSEIF(ISUB.EQ.43) THEN
11078C...f + W+/- -> f' + g
11079
11080 ELSEIF(ISUB.EQ.44) THEN
11081C...f + W+/- -> f' + gamma
11082
11083 ELSEIF(ISUB.EQ.45) THEN
11084C...f + W+/- -> f' + Z0
11085
11086 ELSEIF(ISUB.EQ.46) THEN
11087C...f + W+/- -> f' + W+/-
11088
11089 ELSEIF(ISUB.EQ.47) THEN
11090C...f + W+/- -> f' + h0
11091
11092 ELSEIF(ISUB.EQ.48) THEN
11093C...f + h0 -> f + g
11094
11095 ELSEIF(ISUB.EQ.49) THEN
11096C...f + h0 -> f + gamma
11097
11098 ELSEIF(ISUB.EQ.50) THEN
11099C...f + h0 -> f + Z0
11100 ENDIF
11101
11102 ELSEIF(ISUB.LE.60) THEN
11103 IF(ISUB.EQ.51) THEN
11104C...f + h0 -> f' + W+/-
11105
11106 ELSEIF(ISUB.EQ.52) THEN
11107C...f + h0 -> f + h0
11108
11109 ELSEIF(ISUB.EQ.53) THEN
11110C...g + g -> f + fbar; th arbitrary
11111 KCS=(-1)**INT(1.5D0+PYR(0))
11112 MINT(21)=ISIGN(KFLF,KCS)
11113 MINT(22)=-MINT(21)
11114 KCC=MINT(2)+10
11115
11116 ELSEIF(ISUB.EQ.54) THEN
11117C...g + gamma -> f + fbar; th arbitrary
11118 KCS=(-1)**INT(1.5D0+PYR(0))
11119 MINT(21)=ISIGN(KFLF,KCS)
11120 MINT(22)=-MINT(21)
11121 KCC=27
11122 IF(MINT(16).EQ.21) KCC=28
11123
11124 ELSEIF(ISUB.EQ.55) THEN
11125C...g + Z0 -> f + fbar
11126
11127 ELSEIF(ISUB.EQ.56) THEN
11128C...g + W+/- -> f + fbar'
11129
11130 ELSEIF(ISUB.EQ.57) THEN
11131C...g + h0 -> f + fbar
11132
11133 ELSEIF(ISUB.EQ.58) THEN
11134C...gamma + gamma -> f + fbar; th arbitrary
11135 KCS=(-1)**INT(1.5D0+PYR(0))
11136 MINT(21)=ISIGN(KFLF,KCS)
11137 MINT(22)=-MINT(21)
11138 KCC=21
11139
11140 ELSEIF(ISUB.EQ.59) THEN
11141C...gamma + Z0 -> f + fbar
11142
11143 ELSEIF(ISUB.EQ.60) THEN
11144C...gamma + W+/- -> f + fbar'
11145 ENDIF
11146
11147 ELSEIF(ISUB.LE.70) THEN
11148 IF(ISUB.EQ.61) THEN
11149C...gamma + h0 -> f + fbar
11150
11151 ELSEIF(ISUB.EQ.62) THEN
11152C...Z0 + Z0 -> f + fbar
11153
11154 ELSEIF(ISUB.EQ.63) THEN
11155C...Z0 + W+/- -> f + fbar'
11156
11157 ELSEIF(ISUB.EQ.64) THEN
11158C...Z0 + h0 -> f + fbar
11159
11160 ELSEIF(ISUB.EQ.65) THEN
11161C...W+ + W- -> f + fbar
11162
11163 ELSEIF(ISUB.EQ.66) THEN
11164C...W+/- + h0 -> f + fbar'
11165
11166 ELSEIF(ISUB.EQ.67) THEN
11167C...h0 + h0 -> f + fbar
11168
11169 ELSEIF(ISUB.EQ.68) THEN
11170C...g + g -> g + g; th arbitrary
11171 KCC=MINT(2)+12
11172 KCS=(-1)**INT(1.5D0+PYR(0))
11173
11174 ELSEIF(ISUB.EQ.69) THEN
11175C...gamma + gamma -> W+ + W-; th arbitrary
11176 MINT(21)=24
11177 MINT(22)=-24
11178 KCC=21
11179
11180 ELSEIF(ISUB.EQ.70) THEN
11181C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11182 IF(MINT(15).EQ.22) MINT(21)=23
11183 IF(MINT(16).EQ.22) MINT(22)=23
11184 KCC=21
11185 ENDIF
11186
11187 ELSEIF(ISUB.LE.80) THEN
11188 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11189C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11190 XH=SH/SHP
11191 MINT(21)=MINT(15)
11192 MINT(22)=MINT(16)
11193 PMQ(1)=PYMASS(MINT(21))
11194 PMQ(2)=PYMASS(MINT(22))
11195 330 JT=INT(1.5D0+PYR(0))
11196 ZMIN=2D0*PMQ(JT)/SHPR
11197 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11198 & (SHPR*(SHPR-PMQ(3-JT)))
11199 ZMAX=MIN(1D0-XH,ZMAX)
11200 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11201 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11202 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11203 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11204 IF(SQC1.LT.1D-8) GOTO 330
11205 C1=SQRT(SQC1)
11206 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11207 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11208 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11209 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11210 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11211 IF(SQC1.LT.1D-8) GOTO 330
11212 C1=SQRT(SQC1)
11213 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11214 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11215 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11216 PHIR=PARU(2)*PYR(0)
11217 CPHI=COS(PHIR)
11218 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11219 & SQRT(1D0-CTHE(2)**2)*CPHI
11220 Z1=2D0-Z(JT)
11221 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11222 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11223 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11224 & PMQ(3-JT)**2/SHP))
11225 ZMIN=2D0*PMQ(3-JT)/SHPR
11226 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11227 ZMAX=MIN(1D0-XH,ZMAX)
11228 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11229 KCC=22
11230
11231 ELSEIF(ISUB.EQ.73) THEN
11232C...Z0 + W+/- -> Z0 + W+/-
11233 JS=MINT(2)
11234 XH=SH/SHP
11235 340 JT=3-MINT(2)
11236 I=MINT(14+JT)
11237 IA=IABS(I)
11238 IF(IA.LE.10) THEN
11239 RVCKM=VINT(180+I)*PYR(0)
11240 DO 350 J=1,MSTP(1)
11241 IB=2*J-1+MOD(IA,2)
11242 IPM=(5-ISIGN(1,I))/2
11243 IDC=J+MDCY(IA,2)+2
11244 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11245 MINT(20+JT)=ISIGN(IB,I)
11246 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11247 IF(RVCKM.LE.0D0) GOTO 360
11248 350 CONTINUE
11249 ELSE
11250 IB=2*((IA+1)/2)-1+MOD(IA,2)
11251 MINT(20+JT)=ISIGN(IB,I)
11252 ENDIF
11253 360 PMQ(JT)=PYMASS(MINT(20+JT))
11254 MINT(23-JT)=MINT(17-JT)
11255 PMQ(3-JT)=PYMASS(MINT(23-JT))
11256 JT=INT(1.5D0+PYR(0))
11257 ZMIN=2D0*PMQ(JT)/SHPR
11258 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11259 & (SHPR*(SHPR-PMQ(3-JT)))
11260 ZMAX=MIN(1D0-XH,ZMAX)
11261 IF(ZMIN.GE.ZMAX) GOTO 340
11262 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11263 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11264 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11265 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11266 IF(SQC1.LT.1D-8) GOTO 340
11267 C1=SQRT(SQC1)
11268 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11269 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11270 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11271 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11272 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11273 IF(SQC1.LT.1D-8) GOTO 340
11274 C1=SQRT(SQC1)
11275 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11276 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11277 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11278 PHIR=PARU(2)*PYR(0)
11279 CPHI=COS(PHIR)
11280 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11281 & SQRT(1D0-CTHE(2)**2)*CPHI
11282 Z1=2D0-Z(JT)
11283 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11284 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11285 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11286 & PMQ(3-JT)**2/SHP))
11287 ZMIN=2D0*PMQ(3-JT)/SHPR
11288 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11289 ZMAX=MIN(1D0-XH,ZMAX)
11290 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11291 KCC=22
11292
11293 ELSEIF(ISUB.EQ.74) THEN
11294C...Z0 + h0 -> Z0 + h0
11295
11296 ELSEIF(ISUB.EQ.75) THEN
11297C...W+ + W- -> gamma + gamma
11298
11299 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11300C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11301 XH=SH/SHP
11302 370 DO 400 JT=1,2
11303 I=MINT(14+JT)
11304 IA=IABS(I)
11305 IF(IA.LE.10) THEN
11306 RVCKM=VINT(180+I)*PYR(0)
11307 DO 380 J=1,MSTP(1)
11308 IB=2*J-1+MOD(IA,2)
11309 IPM=(5-ISIGN(1,I))/2
11310 IDC=J+MDCY(IA,2)+2
11311 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11312 MINT(20+JT)=ISIGN(IB,I)
11313 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11314 IF(RVCKM.LE.0D0) GOTO 390
11315 380 CONTINUE
11316 ELSE
11317 IB=2*((IA+1)/2)-1+MOD(IA,2)
11318 MINT(20+JT)=ISIGN(IB,I)
11319 ENDIF
11320 390 PMQ(JT)=PYMASS(MINT(20+JT))
11321 400 CONTINUE
11322 JT=INT(1.5D0+PYR(0))
11323 ZMIN=2D0*PMQ(JT)/SHPR
11324 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11325 & (SHPR*(SHPR-PMQ(3-JT)))
11326 ZMAX=MIN(1D0-XH,ZMAX)
11327 IF(ZMIN.GE.ZMAX) GOTO 370
11328 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11329 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11330 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11331 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11332 IF(SQC1.LT.1D-8) GOTO 370
11333 C1=SQRT(SQC1)
11334 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11335 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11336 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11337 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11338 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11339 IF(SQC1.LT.1D-8) GOTO 370
11340 C1=SQRT(SQC1)
11341 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11342 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11343 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11344 PHIR=PARU(2)*PYR(0)
11345 CPHI=COS(PHIR)
11346 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11347 & SQRT(1D0-CTHE(2)**2)*CPHI
11348 Z1=2D0-Z(JT)
11349 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11350 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11351 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11352 & PMQ(3-JT)**2/SHP))
11353 ZMIN=2D0*PMQ(3-JT)/SHPR
11354 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11355 ZMAX=MIN(1D0-XH,ZMAX)
11356 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11357 KCC=22
11358
11359 ELSEIF(ISUB.EQ.78) THEN
11360C...W+/- + h0 -> W+/- + h0
11361
11362 ELSEIF(ISUB.EQ.79) THEN
11363C...h0 + h0 -> h0 + h0
11364
11365 ELSEIF(ISUB.EQ.80) THEN
11366C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11367 IF(MINT(15).EQ.22) JS=2
11368 I=MINT(14+JS)
11369 IA=IABS(I)
11370 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11371 IB=3-IA
11372 MINT(20+JS)=ISIGN(IB,I)
11373 KCC=22
11374 ENDIF
11375
11376 ELSEIF(ISUB.LE.90) THEN
11377 IF(ISUB.EQ.81) THEN
11378C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11379 MINT(21)=ISIGN(MINT(55),MINT(15))
11380 MINT(22)=-MINT(21)
11381 KCC=4
11382
11383 ELSEIF(ISUB.EQ.82) THEN
11384C...g + g -> Q + Qbar; th arbitrary
11385 KCS=(-1)**INT(1.5D0+PYR(0))
11386 MINT(21)=ISIGN(MINT(55),KCS)
11387 MINT(22)=-MINT(21)
11388 KCC=MINT(2)+10
11389
11390 ELSEIF(ISUB.EQ.83) THEN
11391C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11392 KFOLD=MINT(16)
11393 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11394 KFAOLD=IABS(KFOLD)
11395 IF(KFAOLD.GT.10) THEN
11396 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11397 ELSE
11398 RCKM=VINT(180+KFOLD)*PYR(0)
11399 IPM=(5-ISIGN(1,KFOLD))/2
11400 KFANEW=-MOD(KFAOLD+1,2)
11401 410 KFANEW=KFANEW+2
11402 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11403 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11404 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11405 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11406 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11407 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11408 ENDIF
11409 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11410 ENDIF
11411 IF(MINT(2).EQ.1) THEN
11412 MINT(21)=ISIGN(MINT(55),MINT(15))
11413 MINT(22)=ISIGN(KFANEW,MINT(16))
11414 ELSE
11415 MINT(21)=ISIGN(KFANEW,MINT(15))
11416 MINT(22)=ISIGN(MINT(55),MINT(16))
11417 JS=2
11418 ENDIF
11419 KCC=22
11420
11421 ELSEIF(ISUB.EQ.84) THEN
11422C...g + gamma -> Q + Qbar; th arbitary
11423 KCS=(-1)**INT(1.5D0+PYR(0))
11424 MINT(21)=ISIGN(MINT(55),KCS)
11425 MINT(22)=-MINT(21)
11426 KCC=27
11427 IF(MINT(16).EQ.21) KCC=28
11428
11429 ELSEIF(ISUB.EQ.85) THEN
11430C...gamma + gamma -> F + Fbar; th arbitary
11431 KCS=(-1)**INT(1.5D0+PYR(0))
11432 MINT(21)=ISIGN(MINT(56),KCS)
11433 MINT(22)=-MINT(21)
11434 KCC=21
11435
11436 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11437C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11438 MINT(21)=KFPR(ISUB,1)
11439 MINT(22)=KFPR(ISUB,2)
11440 KCC=24
11441 KCS=(-1)**INT(1.5D0+PYR(0))
11442 ENDIF
11443
11444 ELSEIF(ISUB.LE.100) THEN
11445 IF(ISUB.EQ.95) THEN
11446C...Low-pT ( = energyless g + g -> g + g)
11447 KCC=MINT(2)+12
11448 KCS=(-1)**INT(1.5D0+PYR(0))
11449
11450 ELSEIF(ISUB.EQ.96) THEN
11451C...Multiple interactions (should be reassigned to QCD process)
11452 ENDIF
11453
11454 ELSEIF(ISUB.LE.110) THEN
11455 IF(ISUB.EQ.101) THEN
11456C...g + g -> gamma*/Z0
11457 KCC=21
11458 KFRES=22
11459
11460 ELSEIF(ISUB.EQ.102) THEN
11461C...g + g -> h0 (or H0, or A0)
11462 KCC=21
11463 KFRES=KFHIGG
11464
11465 ELSEIF(ISUB.EQ.103) THEN
11466C...gamma + gamma -> h0 (or H0, or A0)
11467 KCC=21
11468 KFRES=KFHIGG
11469
11470 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11471C...g + g -> chi_0c or chi_2c.
11472 KCC=21
11473 KFRES=KFPR(ISUB,1)
11474
11475 ELSEIF(ISUB.EQ.106) THEN
11476C...g + g -> J/Psi + gamma
11477 MINT(21)=KFPR(ISUB,1)
11478 MINT(22)=KFPR(ISUB,2)
11479 KCC=21
11480
11481 ELSEIF(ISUB.EQ.107) THEN
11482C...g + gamma -> J/Psi + g
11483 MINT(21)=KFPR(ISUB,1)
11484 MINT(22)=KFPR(ISUB,2)
11485 KCC=22
11486 IF(MINT(16).EQ.22) KCC=33
11487
11488 ELSEIF(ISUB.EQ.108) THEN
11489C...gamma + gamma -> J/Psi + gamma
11490 MINT(21)=KFPR(ISUB,1)
11491 MINT(22)=KFPR(ISUB,2)
11492
11493 ELSEIF(ISUB.EQ.110) THEN
11494C...f + fbar -> gamma + h0; th arbitrary
11495 IF(PYR(0).GT.0.5D0) JS=2
11496 MINT(20+JS)=22
11497 MINT(23-JS)=KFHIGG
11498 ENDIF
11499
11500 ELSEIF(ISUB.LE.120) THEN
11501 IF(ISUB.EQ.111) THEN
11502C...f + fbar -> g + h0; th arbitrary
11503 IF(PYR(0).GT.0.5D0) JS=2
11504 MINT(20+JS)=21
11505 MINT(23-JS)=KFHIGG
11506 KCC=17+JS
11507
11508 ELSEIF(ISUB.EQ.112) THEN
11509C...f + g -> f + h0; th = (p(f) - p(f))**2
11510 IF(MINT(15).EQ.21) JS=2
11511 MINT(23-JS)=KFHIGG
11512 KCC=15+JS
11513 KCS=ISIGN(1,MINT(14+JS))
11514
11515 ELSEIF(ISUB.EQ.113) THEN
11516C...g + g -> g + h0; th arbitrary
11517 IF(PYR(0).GT.0.5D0) JS=2
11518 MINT(23-JS)=KFHIGG
11519 KCC=22+JS
11520 KCS=(-1)**INT(1.5D0+PYR(0))
11521
11522 ELSEIF(ISUB.EQ.114) THEN
11523C...g + g -> gamma + gamma; th arbitrary
11524 IF(PYR(0).GT.0.5D0) JS=2
11525 MINT(21)=22
11526 MINT(22)=22
11527 KCC=21
11528
11529 ELSEIF(ISUB.EQ.115) THEN
11530C...g + g -> g + gamma; th arbitrary
11531 IF(PYR(0).GT.0.5D0) JS=2
11532 MINT(23-JS)=22
11533 KCC=22+JS
11534 KCS=(-1)**INT(1.5D0+PYR(0))
11535
11536 ELSEIF(ISUB.EQ.116) THEN
11537C...g + g -> gamma + Z0
11538
11539 ELSEIF(ISUB.EQ.117) THEN
11540C...g + g -> Z0 + Z0
11541
11542 ELSEIF(ISUB.EQ.118) THEN
11543C...g + g -> W+ + W-
11544 ENDIF
11545
11546 ELSEIF(ISUB.LE.140) THEN
11547 IF(ISUB.EQ.121) THEN
11548C...g + g -> Q + Qbar + h0
11549 KCS=(-1)**INT(1.5D0+PYR(0))
11550 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11551 MINT(22)=-MINT(21)
11552 KCC=11+INT(0.5D0+PYR(0))
11553 KFRES=KFHIGG
11554
11555 ELSEIF(ISUB.EQ.122) THEN
11556C...q + qbar -> Q + Qbar + h0
11557 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11558 MINT(22)=-MINT(21)
11559 KCC=4
11560 KFRES=KFHIGG
11561
11562 ELSEIF(ISUB.EQ.123) THEN
11563C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11564C...inner process)
11565 KCC=22
11566 KFRES=KFHIGG
11567
11568 ELSEIF(ISUB.EQ.124) THEN
11569C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11570C...inner process)
11571 DO 430 JT=1,2
11572 I=MINT(14+JT)
11573 IA=IABS(I)
11574 IF(IA.LE.10) THEN
11575 RVCKM=VINT(180+I)*PYR(0)
11576 DO 420 J=1,MSTP(1)
11577 IB=2*J-1+MOD(IA,2)
11578 IPM=(5-ISIGN(1,I))/2
11579 IDC=J+MDCY(IA,2)+2
11580 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11581 MINT(20+JT)=ISIGN(IB,I)
11582 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11583 IF(RVCKM.LE.0D0) GOTO 430
11584 420 CONTINUE
11585 ELSE
11586 IB=2*((IA+1)/2)-1+MOD(IA,2)
11587 MINT(20+JT)=ISIGN(IB,I)
11588 ENDIF
11589 430 CONTINUE
11590 KCC=22
11591 KFRES=KFHIGG
11592
11593 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11594C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11595 IF(MINT(15).EQ.22) JS=2
11596 MINT(23-JS)=21
11597 KCC=24+JS
11598 KCS=ISIGN(1,MINT(14+JS))
11599
11600 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11601C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11602 IF(MINT(15).EQ.22) JS=2
11603 KCC=22
11604 KCS=ISIGN(1,MINT(14+JS))
11605
11606 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11607C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11608 KCS=(-1)**INT(1.5D0+PYR(0))
11609 MINT(21)=ISIGN(KFLF,KCS)
11610 MINT(22)=-MINT(21)
11611 KCC=27
11612 IF(MINT(16).EQ.21) KCC=28
11613
11614 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11615C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11616 KCS=(-1)**INT(1.5D0+PYR(0))
11617 MINT(21)=ISIGN(KFLF,KCS)
11618 MINT(22)=-MINT(21)
11619 KCC=21
11620
11621 ENDIF
11622
11623 ELSEIF(ISUB.LE.160) THEN
11624 IF(ISUB.EQ.141) THEN
11625C...f + fbar -> gamma*/Z0/Z'0
11626 KFRES=32
11627
11628 ELSEIF(ISUB.EQ.142) THEN
11629C...f + fbar' -> W'+/-
11630 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11631 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11632 KFRES=ISIGN(34,KCH1+KCH2)
11633
11634 ELSEIF(ISUB.EQ.143) THEN
11635C...f + fbar' -> H+/-
11636 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11637 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11638 KFRES=ISIGN(37,KCH1+KCH2)
11639
11640 ELSEIF(ISUB.EQ.144) THEN
11641C...f + fbar' -> R
11642 KFRES=ISIGN(41,MINT(15)+MINT(16))
11643
11644 ELSEIF(ISUB.EQ.145) THEN
11645C...q + l -> LQ (leptoquark)
11646 IF(IABS(MINT(16)).LE.8) JS=2
11647 KFRES=ISIGN(42,MINT(14+JS))
11648 KCC=28+JS
11649 KCS=ISIGN(1,MINT(14+JS))
11650
11651 ELSEIF(ISUB.EQ.146) THEN
11652C...e + gamma -> e* (excited lepton)
11653 IF(MINT(15).EQ.22) JS=2
11654 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11655 KCC=22
11656
11657 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11658C...q + g -> q* (excited quark)
11659 IF(MINT(15).EQ.21) JS=2
11660 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11661 KCC=30+JS
11662 KCS=ISIGN(1,MINT(14+JS))
11663
11664 ELSEIF(ISUB.EQ.149) THEN
11665C...g + g -> eta_tc
11666 KFRES=KTECHN+331
11667 KCC=23
11668 KCS=(-1)**INT(1.5D0+PYR(0))
11669 ENDIF
11670
11671 ELSEIF(ISUB.LE.200) THEN
11672 IF(ISUB.EQ.161) THEN
11673C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11674 IF(MINT(15).EQ.21) JS=2
11675 I=MINT(14+JS)
11676 IA=IABS(I)
11677 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11678 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11679 MINT(20+JS)=ISIGN(IB,I)
11680 KCC=15+JS
11681 KCS=ISIGN(1,MINT(14+JS))
11682
11683 ELSEIF(ISUB.EQ.162) THEN
11684C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11685 IF(MINT(15).EQ.21) JS=2
11686 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11687 KFLQL=KFDP(MDCY(42,2),2)
11688 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11689 KCC=15+JS
11690 KCS=ISIGN(1,MINT(14+JS))
11691
11692 ELSEIF(ISUB.EQ.163) THEN
11693C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11694 KCS=(-1)**INT(1.5D0+PYR(0))
11695 MINT(21)=ISIGN(42,KCS)
11696 MINT(22)=-MINT(21)
11697 KCC=MINT(2)+10
11698
11699 ELSEIF(ISUB.EQ.164) THEN
11700C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11701 MINT(21)=ISIGN(42,MINT(15))
11702 MINT(22)=-MINT(21)
11703 KCC=4
11704
11705 ELSEIF(ISUB.EQ.165) THEN
11706C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11707 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11708 MINT(22)=-MINT(21)
11709
11710 ELSEIF(ISUB.EQ.166) THEN
11711C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11712 IF(MOD(MINT(15),2).EQ.0) THEN
11713 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11714 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11715 ELSE
11716 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11717 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11718 ENDIF
11719
11720 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11721C...q + q' -> q" + q* (excited quark)
11722 KFQSTR=KFPR(ISUB,2)
11723 KFQEXC=MOD(KFQSTR,KEXCIT)
11724 JS=MINT(2)
11725 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11726 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11727 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11728 KCC=22
11729 JS=3-JS
11730
11731 ELSEIF(ISUB.EQ.169) THEN
11732C...q + qbar -> e + e* (excited lepton)
11733 KFQSTR=KFPR(ISUB,2)
11734 KFQEXC=MOD(KFQSTR,KEXCIT)
11735 JS=MINT(2)
11736 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11737 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11738 JS=3-JS
11739
11740 ELSEIF(ISUB.EQ.191) THEN
11741C...f + fbar -> rho_tc0.
11742 KFRES=KTECHN+113
11743
11744 ELSEIF(ISUB.EQ.192) THEN
11745C...f + fbar' -> rho_tc+/-
11746 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11747 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11748 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11749
11750 ELSEIF(ISUB.EQ.193) THEN
11751C...f + fbar -> omega_tc0.
11752 KFRES=KTECHN+223
11753
11754 ELSEIF(ISUB.EQ.194) THEN
11755C...f + fbar -> f' + fbar' via mixture of s-channel
11756C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11757 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11758 MINT(22)=-MINT(21)
11759
11760 ELSEIF(ISUB.EQ.195) THEN
11761C...f + fbar' -> f'' + fbar''' via s-channel
11762C...rho_tc+ th=(p(f)-p(f'))**2
11763C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11764 IF(MOD(MINT(15),2).EQ.0) THEN
11765 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11766 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11767 ELSE
11768 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11769 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11770 ENDIF
11771 ENDIF
11772
11773CMRENNA++
11774 ELSEIF(ISUB.LE.215) THEN
11775 IF(ISUB.EQ.201) THEN
11776C...f + fbar -> ~e_L + ~e_Lbar
11777 MINT(21)=ISIGN(KSUSY1+11,KCS)
11778 MINT(22)=-MINT(21)
11779
11780 ELSEIF(ISUB.EQ.202) THEN
11781C...f + fbar -> ~e_R + ~e_Rbar
11782 MINT(21)=ISIGN(KSUSY2+11,KCS)
11783 MINT(22)=-MINT(21)
11784
11785 ELSEIF(ISUB.EQ.203) THEN
11786C...f + fbar -> ~e_L + ~e_Rbar
11787 IF(MINT(15).LT.0) JS=2
11788 IF(MINT(2).EQ.1) THEN
11789 MINT(20+JS)=KFPR(ISUB,1)
11790 MINT(23-JS)=-KFPR(ISUB,2)
11791 ELSE
11792 MINT(20+JS)=-KFPR(ISUB,1)
11793 MINT(23-JS)=KFPR(ISUB,2)
11794 ENDIF
11795
11796 ELSEIF(ISUB.EQ.204) THEN
11797C...f + fbar -> ~mu_L + ~mu_Lbar
11798 MINT(21)=ISIGN(KSUSY1+13,KCS)
11799 MINT(22)=-MINT(21)
11800
11801 ELSEIF(ISUB.EQ.205) THEN
11802C...f + fbar -> ~mu_R + ~mu_Rbar
11803 MINT(21)=ISIGN(KSUSY2+13,KCS)
11804 MINT(22)=-MINT(21)
11805
11806 ELSEIF(ISUB.EQ.206) THEN
11807C...f + fbar -> ~mu_L + ~mu_Rbar
11808 IF(MINT(15).LT.0) JS=2
11809 IF(MINT(2).EQ.1) THEN
11810 MINT(20+JS)=KFPR(ISUB,1)
11811 MINT(23-JS)=-KFPR(ISUB,2)
11812 ELSE
11813 MINT(20+JS)=-KFPR(ISUB,1)
11814 MINT(23-JS)=KFPR(ISUB,2)
11815 ENDIF
11816
11817 ELSEIF(ISUB.EQ.207) THEN
11818C...f + fbar -> ~tau_1 + ~tau_1bar
11819 MINT(21)=ISIGN(KSUSY1+15,KCS)
11820 MINT(22)=-MINT(21)
11821
11822 ELSEIF(ISUB.EQ.208) THEN
11823C...f + fbar -> ~tau_2 + ~tau_2bar
11824 MINT(21)=ISIGN(KSUSY2+15,KCS)
11825 MINT(22)=-MINT(21)
11826
11827 ELSEIF(ISUB.EQ.209) THEN
11828C...f + fbar -> ~tau_1 + ~tau_2bar
11829 IF(MINT(15).LT.0) JS=2
11830 IF(MINT(2).EQ.1) THEN
11831 MINT(20+JS)=KFPR(ISUB,1)
11832 MINT(23-JS)=-KFPR(ISUB,2)
11833 ELSE
11834 MINT(20+JS)=-KFPR(ISUB,1)
11835 MINT(23-JS)=KFPR(ISUB,2)
11836 ENDIF
11837
11838 ELSEIF(ISUB.EQ.210) THEN
11839C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11840 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11841 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11842 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11843 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11844
11845 ELSEIF(ISUB.EQ.211) THEN
11846C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11847 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11848 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11849 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11850 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11851
11852 ELSEIF(ISUB.EQ.212) THEN
11853C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11854 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11855 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11856 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11857 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11858
11859 ELSEIF(ISUB.EQ.213) THEN
11860C...f + fbar -> ~nul + ~nulbar
11861 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11862 MINT(22)=-MINT(21)
11863
11864 ELSEIF(ISUB.EQ.214) THEN
11865C...f + fbar -> ~nutau + ~nutaubar
11866 MINT(21)=ISIGN(KSUSY1+16,KCS)
11867 MINT(22)=-MINT(21)
11868 ENDIF
11869
11870 ELSEIF(ISUB.LE.225) THEN
11871 IF(ISUB.EQ.216) THEN
11872C...f + fbar -> ~chi01 + ~chi01
11873 MINT(21)=KSUSY1+22
11874 MINT(22)=KSUSY1+22
11875
11876 ELSEIF(ISUB.EQ.217) THEN
11877C...f + fbar -> ~chi02 + ~chi02
11878 MINT(21)=KSUSY1+23
11879 MINT(22)=KSUSY1+23
11880
11881 ELSEIF(ISUB.EQ.218 ) THEN
11882C...f + fbar -> ~chi03 + ~chi03
11883 MINT(21)=KSUSY1+25
11884 MINT(22)=KSUSY1+25
11885
11886 ELSEIF(ISUB.EQ.219 ) THEN
11887C...f + fbar -> ~chi04 + ~chi04
11888 MINT(21)=KSUSY1+35
11889 MINT(22)=KSUSY1+35
11890
11891 ELSEIF(ISUB.EQ.220 ) THEN
11892C...f + fbar -> ~chi01 + ~chi02
11893 IF(MINT(15).LT.0) JS=2
11894C IF(PYR(0).GT.0.5D0) JS=2
11895 MINT(20+JS)=KSUSY1+22
11896 MINT(23-JS)=KSUSY1+23
11897
11898 ELSEIF(ISUB.EQ.221 ) THEN
11899C...f + fbar -> ~chi01 + ~chi03
11900 IF(MINT(15).LT.0) JS=2
11901C IF(PYR(0).GT.0.5D0) JS=2
11902 MINT(20+JS)=KSUSY1+22
11903 MINT(23-JS)=KSUSY1+25
11904
11905 ELSEIF(ISUB.EQ.222) THEN
11906C...f + fbar -> ~chi01 + ~chi04
11907 IF(MINT(15).LT.0) JS=2
11908C IF(PYR(0).GT.0.5D0) JS=2
11909 MINT(20+JS)=KSUSY1+22
11910 MINT(23-JS)=KSUSY1+35
11911
11912 ELSEIF(ISUB.EQ.223) THEN
11913C...f + fbar -> ~chi02 + ~chi03
11914 IF(MINT(15).LT.0) JS=2
11915C IF(PYR(0).GT.0.5D0) JS=2
11916 MINT(20+JS)=KSUSY1+23
11917 MINT(23-JS)=KSUSY1+25
11918
11919 ELSEIF(ISUB.EQ.224) THEN
11920C...f + fbar -> ~chi02 + ~chi04
11921 IF(MINT(15).LT.0) JS=2
11922C IF(PYR(0).GT.0.5D0) JS=2
11923 MINT(20+JS)=KSUSY1+23
11924 MINT(23-JS)=KSUSY1+35
11925
11926 ELSEIF(ISUB.EQ.225) THEN
11927C...f + fbar -> ~chi03 + ~chi04
11928 IF(MINT(15).LT.0) JS=2
11929C IF(PYR(0).GT.0.5D0) JS=2
11930 MINT(20+JS)=KSUSY1+25
11931 MINT(23-JS)=KSUSY1+35
11932 ENDIF
11933
11934 ELSEIF(ISUB.LE.236) THEN
11935 IF(ISUB.EQ.226) THEN
11936C...f + fbar -> ~chi+-1 + ~chi-+1
11937C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11938 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11939 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11940 MINT(22)=-MINT(21)
11941
11942 ELSEIF(ISUB.EQ.227) THEN
11943C...f + fbar -> ~chi+-2 + ~chi-+2
11944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11945 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11946 MINT(22)=-MINT(21)
11947
11948 ELSEIF(ISUB.EQ.228) THEN
11949C...f + fbar -> ~chi+-1 + ~chi-+2
11950C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11951C...js=1 if pyr<.5, js=2 if pyr>.5
11952C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11953C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11954C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11955C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11957 KCH2=INT(1-KCH1)/2
11958 IF(MINT(2).EQ.1) THEN
11959 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11960 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11961c IF(KCH2.EQ.0) JS=2
11962 ELSE
11963 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11964 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11965 JS=2
11966c IF(KCH2.EQ.1) JS=2
11967 ENDIF
11968
11969 ELSEIF(ISUB.EQ.229) THEN
11970C...q + qbar' -> ~chi01 + ~chi+-1
11971C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11972 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11973 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11974C...CHECK THIS
11975 IF(MOD(MINT(15),2).EQ.0) JS=2
11976 MINT(20+JS)=KSUSY1+22
11977 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11978
11979 ELSEIF(ISUB.EQ.230) THEN
11980C...q + qbar' -> ~chi02 + ~chi+-1
11981 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11982 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11983 IF(MOD(MINT(15),2).EQ.0) JS=2
11984 MINT(20+JS)=KSUSY1+23
11985 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11986
11987 ELSEIF(ISUB.EQ.231) THEN
11988C...q + qbar' -> ~chi03 + ~chi+-1
11989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11991 IF(MOD(MINT(15),2).EQ.0) JS=2
11992 MINT(20+JS)=KSUSY1+25
11993 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11994
11995 ELSEIF(ISUB.EQ.232) THEN
11996C...q + qbar' -> ~chi04 + ~chi+-1
11997 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11998 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11999 IF(MOD(MINT(15),2).EQ.0) JS=2
12000 MINT(20+JS)=KSUSY1+35
12001 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12002
12003 ELSEIF(ISUB.EQ.233) THEN
12004C...q + qbar' -> ~chi01 + ~chi+-2
12005 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12006 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12007 IF(MOD(MINT(15),2).EQ.0) JS=2
12008 MINT(20+JS)=KSUSY1+22
12009 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12010
12011 ELSEIF(ISUB.EQ.234) THEN
12012C...q + qbar' -> ~chi02 + ~chi+-2
12013 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12014 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12015 IF(MOD(MINT(15),2).EQ.0) JS=2
12016 MINT(20+JS)=KSUSY1+23
12017 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12018
12019 ELSEIF(ISUB.EQ.235) THEN
12020C...q + qbar' -> ~chi03 + ~chi+-2
12021 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12022 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12023 IF(MOD(MINT(15),2).EQ.0) JS=2
12024 MINT(20+JS)=KSUSY1+25
12025 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12026
12027 ELSEIF(ISUB.EQ.236) THEN
12028C...q + qbar' -> ~chi04 + ~chi+-2
12029 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12030 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12031 IF(MOD(MINT(15),2).EQ.0) JS=2
12032 MINT(20+JS)=KSUSY1+35
12033 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12034 ENDIF
12035
12036 ELSEIF(ISUB.LE.245) THEN
12037 IF(ISUB.EQ.237) THEN
12038C...q + qbar -> ~chi01 + ~g
12039C...th arbitrary
12040 IF(PYR(0).GT.0.5D0) JS=2
12041 MINT(20+JS)=KSUSY1+21
12042 MINT(23-JS)=KSUSY1+22
12043 KCC=17+JS
12044
12045 ELSEIF(ISUB.EQ.238) THEN
12046C...q + qbar -> ~chi02 + ~g
12047C...th arbitrary
12048 IF(PYR(0).GT.0.5D0) JS=2
12049 MINT(20+JS)=KSUSY1+21
12050 MINT(23-JS)=KSUSY1+23
12051 KCC=17+JS
12052
12053 ELSEIF(ISUB.EQ.239) THEN
12054C...q + qbar -> ~chi03 + ~g
12055C...th arbitrary
12056 IF(PYR(0).GT.0.5D0) JS=2
12057 MINT(20+JS)=KSUSY1+21
12058 MINT(23-JS)=KSUSY1+25
12059 KCC=17+JS
12060
12061 ELSEIF(ISUB.EQ.240) THEN
12062C...q + qbar -> ~chi04 + ~g
12063C...th arbitrary
12064 IF(PYR(0).GT.0.5D0) JS=2
12065 MINT(20+JS)=KSUSY1+21
12066 MINT(23-JS)=KSUSY1+35
12067 KCC=17+JS
12068
12069 ELSEIF(ISUB.EQ.241) THEN
12070C...q + qbar' -> ~chi+-1 + ~g
12071C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12072C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12073C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12074C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12075C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12076 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12077 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12078 JS=1
12079 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12080 MINT(20+JS)=KSUSY1+21
12081 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12082 KCC=17+JS
12083
12084 ELSEIF(ISUB.EQ.242) THEN
12085C...q + qbar' -> ~chi+-2 + ~g
12086C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12087C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12088C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12089C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12090C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12093 JS=1
12094 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12095 MINT(20+JS)=KSUSY1+21
12096 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12097 KCC=17+JS
12098
12099 ELSEIF(ISUB.EQ.243) THEN
12100C...q + qbar -> ~g + ~g ; th arbitrary
12101 MINT(21)=KSUSY1+21
12102 MINT(22)=KSUSY1+21
12103 KCC=MINT(2)+4
12104
12105 ELSEIF(ISUB.EQ.244) THEN
12106C...g + g -> ~g + ~g ; th arbitrary
12107 KCC=MINT(2)+12
12108 KCS=(-1)**INT(1.5D0+PYR(0))
12109 MINT(21)=KSUSY1+21
12110 MINT(22)=KSUSY1+21
12111 ENDIF
12112
12113 ELSEIF(ISUB.LE.260) THEN
12114 IF(ISUB.EQ.246) THEN
12115C...qj + g -> ~qj_L + ~chi01
12116 IF(MINT(15).EQ.21) JS=2
12117 I=MINT(14+JS)
12118 IA=IABS(I)
12119 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12120 MINT(23-JS)=KSUSY1+22
12121 KCC=15+JS
12122 KCS=ISIGN(1,MINT(14+JS))
12123
12124 ELSEIF(ISUB.EQ.247) THEN
12125C...qj + g -> ~qj_R + ~chi01
12126 IF(MINT(15).EQ.21) JS=2
12127 I=MINT(14+JS)
12128 IA=IABS(I)
12129 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12130 MINT(23-JS)=KSUSY1+22
12131 KCC=15+JS
12132 KCS=ISIGN(1,MINT(14+JS))
12133
12134 ELSEIF(ISUB.EQ.248) THEN
12135C...qj + g -> ~qj_L + ~chi02
12136 IF(MINT(15).EQ.21) JS=2
12137 I=MINT(14+JS)
12138 IA=IABS(I)
12139 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12140 MINT(23-JS)=KSUSY1+23
12141 KCC=15+JS
12142 KCS=ISIGN(1,MINT(14+JS))
12143
12144 ELSEIF(ISUB.EQ.249) THEN
12145C...qj + g -> ~qj_R + ~chi02
12146 IF(MINT(15).EQ.21) JS=2
12147 I=MINT(14+JS)
12148 IA=IABS(I)
12149 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12150 MINT(23-JS)=KSUSY1+23
12151 KCC=15+JS
12152 KCS=ISIGN(1,MINT(14+JS))
12153
12154 ELSEIF(ISUB.EQ.250) THEN
12155C...qj + g -> ~qj_L + ~chi03
12156 IF(MINT(15).EQ.21) JS=2
12157 I=MINT(14+JS)
12158 IA=IABS(I)
12159 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12160 MINT(23-JS)=KSUSY1+25
12161 KCC=15+JS
12162 KCS=ISIGN(1,MINT(14+JS))
12163
12164 ELSEIF(ISUB.EQ.251) THEN
12165C...qj + g -> ~qj_R + ~chi03
12166 IF(MINT(15).EQ.21) JS=2
12167 I=MINT(14+JS)
12168 IA=IABS(I)
12169 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12170 MINT(23-JS)=KSUSY1+25
12171 KCC=15+JS
12172 KCS=ISIGN(1,MINT(14+JS))
12173
12174 ELSEIF(ISUB.EQ.252) THEN
12175C...qj + g -> ~qj_L + ~chi04
12176 IF(MINT(15).EQ.21) JS=2
12177 I=MINT(14+JS)
12178 IA=IABS(I)
12179 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12180 MINT(23-JS)=KSUSY1+35
12181 KCC=15+JS
12182 KCS=ISIGN(1,MINT(14+JS))
12183
12184 ELSEIF(ISUB.EQ.253) THEN
12185C...qj + g -> ~qj_R + ~chi04
12186 IF(MINT(15).EQ.21) JS=2
12187 I=MINT(14+JS)
12188 IA=IABS(I)
12189 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12190 MINT(23-JS)=KSUSY1+35
12191 KCC=15+JS
12192 KCS=ISIGN(1,MINT(14+JS))
12193
12194 ELSEIF(ISUB.EQ.254) THEN
12195C...qj + g -> ~qk_L + ~chi+-1
12196 IF(MINT(15).EQ.21) JS=2
12197 I=MINT(14+JS)
12198 IA=IABS(I)
12199 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12200 IB=-IA+INT((IA+1)/2)*4-1
12201 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12202 KCC=15+JS
12203 KCS=ISIGN(1,MINT(14+JS))
12204
12205 ELSEIF(ISUB.EQ.255) THEN
12206C...qj + g -> ~qk_L + ~chi+-1
12207 IF(MINT(15).EQ.21) JS=2
12208 I=MINT(14+JS)
12209 IA=IABS(I)
12210 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12211 IB=-IA+INT((IA+1)/2)*4-1
12212 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12213 KCC=15+JS
12214 KCS=ISIGN(1,MINT(14+JS))
12215
12216 ELSEIF(ISUB.EQ.256) THEN
12217C...qj + g -> ~qk_L + ~chi+-2
12218 IF(MINT(15).EQ.21) JS=2
12219 I=MINT(14+JS)
12220 IA=IABS(I)
12221 IB=-IA+INT((IA+1)/2)*4-1
12222 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12223 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12224 KCC=15+JS
12225 KCS=ISIGN(1,MINT(14+JS))
12226
12227 ELSEIF(ISUB.EQ.257) THEN
12228C...qj + g -> ~qk_R + ~chi+-2
12229 IF(MINT(15).EQ.21) JS=2
12230 I=MINT(14+JS)
12231 IA=IABS(I)
12232 IB=-IA+INT((IA+1)/2)*4-1
12233 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12234 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12235 KCC=15+JS
12236 KCS=ISIGN(1,MINT(14+JS))
12237
12238 ELSEIF(ISUB.EQ.258) THEN
12239C...qj + g -> ~qj_L + ~g
12240 IF(MINT(15).EQ.21) JS=2
12241 I=MINT(14+JS)
12242 IA=IABS(I)
12243 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12244 MINT(23-JS)=KSUSY1+21
12245 KCC=MINT(2)+6
12246 IF(JS.EQ.2) KCC=KCC+2
12247 KCS=ISIGN(1,I)
12248
12249 ELSEIF(ISUB.EQ.259) THEN
12250C...qj + g -> ~qj_R + ~g
12251 IF(MINT(15).EQ.21) JS=2
12252 I=MINT(14+JS)
12253 IA=IABS(I)
12254 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12255 MINT(23-JS)=KSUSY1+21
12256 KCC=MINT(2)+6
12257 IF(JS.EQ.2) KCC=KCC+2
12258 KCS=ISIGN(1,I)
12259 ENDIF
12260
12261 ELSEIF(ISUB.LE.270) THEN
12262 IF(ISUB.EQ.261) THEN
12263C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12264 ISGN=1
12265 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12266 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12267 MINT(22)=-MINT(21)
12268C...Correct color combination
12269 IF(MINT(43).EQ.4) KCC=4
12270
12271 ELSEIF(ISUB.EQ.262) THEN
12272C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12273 ISGN=1
12274 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12275 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12276 MINT(22)=-MINT(21)
12277C...Correct color combination
12278 IF(MINT(43).EQ.4) KCC=4
12279
12280 ELSEIF(ISUB.EQ.263) THEN
12281C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12282 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12283 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12284 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12285 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12286 ELSE
12287 JS=2
12288 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12289 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12290 ENDIF
12291C...Correct color combination
12292 IF(MINT(43).EQ.4) KCC=4
12293
12294 ELSEIF(ISUB.EQ.264) THEN
12295C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12296 KCS=(-1)**INT(1.5D0+PYR(0))
12297 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12298 MINT(22)=-MINT(21)
12299 KCC=MINT(2)+10
12300
12301 ELSEIF(ISUB.EQ.265) THEN
12302C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12303 KCS=(-1)**INT(1.5D0+PYR(0))
12304 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12305 MINT(22)=-MINT(21)
12306 KCC=MINT(2)+10
12307 ENDIF
12308
12309 ELSEIF(ISUB.LE.296) THEN
12310 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12311C...qi + qj -> ~qi_L + ~qj_L
12312 KCC=MINT(2)
12313 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12314 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12315 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12316
12317 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12318C...qi + qj -> ~qi_R + ~qj_R
12319 KCC=MINT(2)
12320 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12321 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12322 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12323
12324 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12325C...qi + qj -> ~qi_L + ~qj_R
12326 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12327 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12328 KCC=MINT(2)
12329 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12330
12331 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12332C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12333 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12334 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12335 KCC=MINT(2)
12336 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12337
12338 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12339C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12340 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12341 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12342 KCC=MINT(2)
12343 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12344
12345 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12346C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12347 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12348 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12349 KCC=MINT(2)
12350 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12351
12352 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12353C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12354 ISGN=1
12355 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12356 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12357 MINT(22)=-MINT(21)
12358 IF(MINT(43).EQ.4) KCC=4
12359
12360 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12361C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12362 ISGN=1
12363 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12364 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12365 MINT(22)=-MINT(21)
12366 IF(MINT(43).EQ.4) KCC=4
12367
12368 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12369C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12370C...pure LL + RR
12371 KCS=(-1)**INT(1.5D0+PYR(0))
12372 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12373 MINT(22)=-MINT(21)
12374 KCC=MINT(2)+10
12375
12376 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12377C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12378 KCS=(-1)**INT(1.5D0+PYR(0))
12379 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12380 MINT(22)=-MINT(21)
12381 KCC=MINT(2)+10
12382
12383 ELSEIF(ISUB.EQ.294) THEN
12384C...qj + g -> ~qj_L + ~g
12385 IF(MINT(15).EQ.21) JS=2
12386 I=MINT(14+JS)
12387 IA=IABS(I)
12388 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12389 MINT(23-JS)=KSUSY1+21
12390 KCC=MINT(2)+6
12391 IF(JS.EQ.2) KCC=KCC+2
12392 KCS=ISIGN(1,I)
12393
12394 ELSEIF(ISUB.EQ.295) THEN
12395C...qj + g -> ~qj_R + ~g
12396 IF(MINT(15).EQ.21) JS=2
12397 I=MINT(14+JS)
12398 IA=IABS(I)
12399 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12400 MINT(23-JS)=KSUSY1+21
12401 KCC=MINT(2)+6
12402 IF(JS.EQ.2) KCC=KCC+2
12403 KCS=ISIGN(1,I)
12404 ENDIF
12405
12406 ELSEIF(ISUB.LE.330) THEN
12407 IF(ISUB.EQ.311)THEN
12408C...g + g -> g* + g* (UED)
12409 KCC=MINT(2)+12
12410 KCS=(-1)**INT(1.5D0+PYR(0))
12411 MUED(1)=472
12412 MUED(2)=472
12413 MINT(21)=IUEDEQ(472)
12414 MINT(22)=IUEDEQ(472)
12415 ELSEIF(ISUB.EQ.312)THEN
12416C...q + g -> q*_D + g*, q*_S + g*
12417C...The two channels have the same cross section
12418 KKFLMI=450
12419 IF(PYR(0).GT.0.5)KKFLMI=456
12420 IF(MINT(15).EQ.21) JS=2
12421 KCC=MINT(2)+6
12422 IF(MINT(15).EQ.21)KCC=KCC+2
12423 IF(MINT(15).NE.21)THEN
12424 KCS=ISIGN(1,MINT(15))
12425 MUED(2)=472
12426 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12427 MINT(22)=IUEDEQ(472)
12428 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12429 ENDIF
12430 IF(MINT(16).NE.21)THEN
12431 KCS=ISIGN(1,MINT(16))
12432 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12433 MUED(1)=472
12434 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12435 MINT(21)=IUEDEQ(472)
12436 ENDIF
12437 ELSEIF(ISUB.EQ.313)THEN
12438C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12439C...The two channels have the same cross section
12440 KKFLMI=450
12441 IF(PYR(0).GT.0.5)KKFLMI=456
12442 KCC=MINT(2)
12443 IF(MINT(15).EQ.MINT(16))THEN
12444 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12445 MUED(2)=MINT(21)
12446 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12447 MINT(22)=MINT(21)
12448 ELSE
12449 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12450 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12451 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12452 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12453 ENDIF
12454 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12455 ELSEIF(ISUB.EQ.314)THEN
12456C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12457C...The two channels have the same cross section
12458 KKFLMI=450
12459 IF(PYR(0).GT.0.5)KKFLMI=456
12460 KCS=(-1)**INT(1.5D0+PYR(0))
12461 XFLAOUT=PYR(0)
12462 IF(XFLAOUT.LE.0.2)THEN
12463 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12464 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12465 ELSEIF(XFLAOUT.LE.0.4)THEN
12466 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12467 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12468 ELSEIF(XFLAOUT.LE.0.6)THEN
12469 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12470 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12471 ELSEIF(XFLAOUT.LE.0.8)THEN
12472 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12473 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12474 ELSE
12475 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12476 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12477 ENDIF
12478 MINT(22)=-MINT(21)
12479 MUED(2)=-MUED(1)
12480 KCC=MINT(2)+10
12481 ELSEIF(ISUB.EQ.315)THEN
12482C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12483C...The two channels have the same cross section
12484 KKFLMI=450
12485 IF(PYR(0).GT.0.5)KKFLMI=456
12486 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12487 MUED(2)=-MINT(21)
12488 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12489 MINT(22)=-MINT(21)
12490 KCC=4
12491 ELSEIF(ISUB.EQ.316)THEN
12492C...q + qbar' -> q*_D + q*_S_bar'
12493 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12494 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12495 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12496 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12497 KCC=MINT(2)+2
12498 ELSEIF(ISUB.EQ.317)THEN
12499C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12500C...The two channels have the same cross section
12501 KKFLMI=450
12502 IF(PYR(0).GT.0.5)KKFLMI=456
12503 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12504 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12505 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12506 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12507 KCC=MINT(2)+2
12508 ELSEIF(ISUB.EQ.318)THEN
12509C...q + q' -> q*_D + q*_S'
12510 KCC=MINT(2)
12511 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12512 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12513 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12514 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12515 ELSEIF(ISUB.EQ.319)THEN
12516C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12517C...The two channels have the same cross section
12518 KKFLMI=450
12519 IF(PYR(0).GT.0.5)KKFLMI=456
12520 XFLAOUT=PYR(0)
12521 IIFLAV=0
12522C...N.B. NFLAVOURS=IUED(3)
12523C DO I=1,NFLAVOURS
12524 DO 433 I=1,IUED(3)
12525 IF(I.NE.IABS(MINT(15)))THEN
12526 IIFLAV=IIFLAV+1
12527 IOKFLA(IIFLAV)=I
12528 ENDIF
12529 433 CONTINUE
12530 FLASTEP=1./(IUED(3)-1)
12531 DO I=1,IUED(3)-1
12532 FLAVV=FLASTEP*I
12533 IF(XFLAOUT.LE.FLAVV)THEN
12534 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12535 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12536 GOTO 435
12537 ENDIF
12538 ENDDO
12539 435 CONTINUE
12540 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12541 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12542 CALL PYSTOP(5000000)
12543 ENDIF
12544 MINT(22)=-MINT(21)
12545 KCC=4
12546 ENDIF
12547
12548 ELSEIF(ISUB.LE.340) THEN
12549
12550 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12551C...q + qbar' -> H+ + H0
12552 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12553 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12554 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12555 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12556 MINT(23-JS)=KFPR(ISUB,2)
12557 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12558C...f + fbar -> A0 + H0; th arbitrary
12559 IF(PYR(0).GT.0.5D0) JS=2
12560 MINT(20+JS)=KFPR(ISUB,1)
12561 MINT(23-JS)=KFPR(ISUB,2)
12562 ELSEIF(ISUB.EQ.301) THEN
12563C...f + fbar -> H+ H-
12564 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12565 MINT(22)=-MINT(21)
12566 ENDIF
12567CMRENNA--
12568
12569 ELSEIF(ISUB.LE.360) THEN
12570
12571 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12572C...l + l -> H_L++/--, H_R++/--
12573 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12574 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12575 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12576
12577 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12578C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12579 IF(MINT(15).EQ.22) JS=2
12580 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12581 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12582 KCC=22
12583
12584 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12585C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12586 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12587 MINT(22)=-MINT(21)
12588
12589 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12590C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12591C...as inner process).
12592 DO 450 JT=1,2
12593 I=MINT(14+JT)
12594 IA=IABS(I)
12595 IF(IA.LE.10) THEN
12596 RVCKM=VINT(180+I)*PYR(0)
12597 DO 440 J=1,MSTP(1)
12598 IB=2*J-1+MOD(IA,2)
12599 IPM=(5-ISIGN(1,I))/2
12600 IDC=J+MDCY(IA,2)+2
12601 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12602 MINT(20+JT)=ISIGN(IB,I)
12603 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12604 IF(RVCKM.LE.0D0) GOTO 450
12605 440 CONTINUE
12606 ELSE
12607 IB=2*((IA+1)/2)-1+MOD(IA,2)
12608 MINT(20+JT)=ISIGN(IB,I)
12609 ENDIF
12610 450 CONTINUE
12611 KCC=22
12612 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12613 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12614
12615 ELSEIF(ISUB.EQ.353) THEN
12616C...f + fbar -> Z_R0
12617 KFRES=KFPR(ISUB,1)
12618
12619 ELSEIF(ISUB.EQ.354) THEN
12620C...f + fbar' -> W+/-
12621 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12622 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12623 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12624
12625 ENDIF
12626
12627 ELSEIF(ISUB.LE.380) THEN
12628
12629 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12630C...f + fbar -> charged+ charged- technicolor
12631 KSW=(-1)**INT(1.5D0+PYR(0))
12632 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12633 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12634
12635 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12636C...f + fbar -> neutral neutral technicolor
12637 MINT(21)=KFPR(ISUB,1)
12638 MINT(22)=KFPR(ISUB,2)
12639
12640 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12641C...f + fbar' -> neutral charged technicolor
12642 IN=1
12643 IC=2
12644 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12645 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12646 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12647 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12648 MINT(20+JS)=KFPR(ISUB,IN)
12649
12650 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12651C...f + fbar' -> charged neutral technicolor
12652 IN=2
12653 IC=1
12654 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12655 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12656 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12657 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12658 MINT(23-JS)=KFPR(ISUB,IN)
12659 ENDIF
12660
12661 ELSEIF(ISUB.LE.400) THEN
12662 IF(ISUB.EQ.381) THEN
12663C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12664 KCC=MINT(2)
12665 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12666
12667 ELSEIF(ISUB.EQ.382) THEN
12668C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12669 MINT(21)=ISIGN(KFLF,MINT(15))
12670 MINT(22)=-MINT(21)
12671 KCC=4
12672
12673 ELSEIF(ISUB.EQ.383) THEN
12674C...f + fbar -> g + g; th arbitrary, TC extensions
12675 MINT(21)=21
12676 MINT(22)=21
12677 KCC=MINT(2)+4
12678
12679 ELSEIF(ISUB.EQ.384) THEN
12680C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12681 IF(MINT(15).EQ.21) JS=2
12682 KCC=MINT(2)+6
12683 IF(MINT(15).EQ.21) KCC=KCC+2
12684 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12685 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12686
12687 ELSEIF(ISUB.EQ.385) THEN
12688C...g + g -> f + fbar; th arbitrary, TC extensions
12689 KCS=(-1)**INT(1.5D0+PYR(0))
12690 MINT(21)=ISIGN(KFLF,KCS)
12691 MINT(22)=-MINT(21)
12692 KCC=MINT(2)+10
12693
12694 ELSEIF(ISUB.EQ.386) THEN
12695C...g + g -> g + g; th arbitrary, TC extensions
12696 KCC=MINT(2)+12
12697 KCS=(-1)**INT(1.5D0+PYR(0))
12698
12699 ELSEIF(ISUB.EQ.387) THEN
12700C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12701 MINT(21)=ISIGN(MINT(55),MINT(15))
12702 MINT(22)=-MINT(21)
12703 KCC=4
12704
12705 ELSEIF(ISUB.EQ.388) THEN
12706C...g + g -> Q + Qbar; th arbitrary, TC extensions
12707 KCS=(-1)**INT(1.5D0+PYR(0))
12708 MINT(21)=ISIGN(MINT(55),KCS)
12709 MINT(22)=-MINT(21)
12710 KCC=MINT(2)+10
12711
12712 ELSEIF(ISUB.EQ.391) THEN
12713C...f + fbar -> G*.
12714 KFRES=KFPR(ISUB,1)
12715
12716 ELSEIF(ISUB.EQ.392) THEN
12717C...g + g -> G*.
12718 KCC=21
12719 KFRES=KFPR(ISUB,1)
12720
12721 ELSEIF(ISUB.EQ.393) THEN
12722C...q + qbar -> g + G*; th arbitrary.
12723 IF(PYR(0).GT.0.5D0) JS=2
12724 MINT(20+JS)=KFPR(ISUB,1)
12725 MINT(23-JS)=KFPR(ISUB,2)
12726 KCC=17+JS
12727
12728 ELSEIF(ISUB.EQ.394) THEN
12729C...q + g -> q + G*; th = (p(f) - p(f))**2
12730 IF(MINT(15).EQ.21) JS=2
12731 MINT(23-JS)=KFPR(ISUB,2)
12732 KCC=15+JS
12733 KCS=ISIGN(1,MINT(14+JS))
12734
12735 ELSEIF(ISUB.EQ.395) THEN
12736C...g + g -> G* + g; th arbitrary.
12737 IF(PYR(0).GT.0.5D0) JS=2
12738 MINT(23-JS)=KFPR(ISUB,2)
12739 KCC=22+JS
12740 ENDIF
12741
12742 ELSEIF(ISUB.LE.420) THEN
12743 IF(ISUB.EQ.401) THEN
12744C...g + g -> t + b + H+/-
12745 KCS=(-1)**INT(1.5D0+PYR(0))
12746 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12747 MINT(22)=ISIGN(5,-KCS)
12748 KCC=11+INT(0.5D0+PYR(0))
12749 KFRES=ISIGN(KFHIGG,-KCS)
12750
12751 ELSEIF(ISUB.EQ.402) THEN
12752C...q + qbar -> t + b + H+/-
12753 KFL=(-1)**INT(1.5D0+PYR(0))
12754 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12755 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12756 KCC=4
12757 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12758 ENDIF
12759
12760C...QUARKONIA+++
12761C...Additional code by Stefan Wolf
12762 ELSEIF(ISUB.LE.430) THEN
12763 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12764C...g + g -> QQ~[n] + g
12765C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12766C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12767C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12768C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12769C...or from ISUB.EQ.68 (for ISUB.NE.421)
12770C...[g + g -> g + g; th arbitrary]
12771 MINT(21)=KFPR(ISUBSV,1)
12772 MINT(22)=KFPR(ISUBSV,2)
12773 IF(ISUB.EQ.421) THEN
12774 KCC=24
12775 KCS=(-1)**INT(1.5D0+PYR(0))
12776 ELSE
12777 KCC=MINT(2)+12
12778 KCS=(-1)**INT(1.5D0+PYR(0))
12779 ENDIF
12780
12781 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12782C...q + g -> q + QQ~[n]
12783C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12784C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12785C...KCC copied from ISUB.EQ.28
12786C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12787 IF(MINT(15).EQ.21) JS=2
12788 MINT(23-JS)=KFPR(ISUBSV,2)
12789 KCC=MINT(2)+6
12790 IF(MINT(15).EQ.21) KCC=KCC+2
12791 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12792 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12793
12794 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12795C...q + q~ -> g + QQ~[n]
12796C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12797C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12798C...KCC copied from ISUB.EQ.13
12799C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12800 IF(PYR(0).GT.0.5) JS=2
12801 MINT(20+JS)=21
12802 MINT(23-JS)=KFPR(ISUBSV,2)
12803 KCC=MINT(2)+4
12804 ENDIF
12805
12806 ELSEIF(ISUB.LE.440) THEN
12807 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12808C...g + g -> QQ~[n] + g
12809C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12810C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12811C...KCC and KCS copied from ISUB.EQ.86-89
12812C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12813 MINT(21)=KFPR(ISUBSV,1)
12814 MINT(22)=KFPR(ISUBSV,2)
12815 KCC=24
12816 KCS=(-1)**INT(1.5D0+PYR(0))
12817
12818 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12819C...q + g -> q + QQ~[n]
12820C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12821C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12822C...KCC and KCS copied from ISUB.EQ.112
12823C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12824 IF(MINT(15).EQ.21) JS=2
12825 MINT(23-JS)=KFPR(ISUBSV,2)
12826 KCC=15+JS
12827 KCS=ISIGN(1,MINT(14+JS))
12828
12829 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12830C...q + q~ -> g + QQ~[n]
12831C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12832C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12833C...KCC copied from ISUB.EQ.111
12834C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12835 IF(PYR(0).GT.0.5) JS=2
12836 MINT(20+JS)=21
12837 MINT(23-JS)=KFPR(ISUBSV,2)
12838 KCC=17+JS
12839 ENDIF
12840C...QUARKONIA---
12841
12842 ENDIF
12843
12844 IF(ISET(ISUB).EQ.11) THEN
12845C...Store documentation for user-defined processes
12846 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12847 KUPPO(1)=MINT(83)+5
12848 KUPPO(2)=MINT(83)+6
12849 I=MINT(83)+6
12850 DO 470 IUP=3,NUP
12851 KUPPO(IUP)=0
12852 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12853 IDOC=IDOC-1
12854 MINT(4)=MINT(4)-1
12855 GOTO 470
12856 ENDIF
12857 I=I+1
12858 KUPPO(IUP)=I
12859 K(I,1)=21
12860 K(I,2)=IDUP(IUP)
12861 IF(IDUP(IUP).EQ.0) K(I,2)=90
12862 K(I,3)=0
12863 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12864 K(I,4)=0
12865 K(I,5)=0
12866 DO 460 J=1,5
12867 P(I,J)=PUP(J,IUP)
12868 460 CONTINUE
12869 V(I,5)=VTIMUP(IUP)
12870 470 CONTINUE
12871 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12872 & -BEZUP)
12873
12874C...Store final state partons for user-defined processes
12875 N=IPU2
12876 DO 490 IUP=3,NUP
12877 N=N+1
12878 K(N,1)=1
12879 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12880 K(N,2)=IDUP(IUP)
12881 IF(IDUP(IUP).EQ.0) K(N,2)=90
12882 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12883 K(N,3)=KUPPO(IUP)
12884 ELSE
12885 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12886 ENDIF
12887 K(N,4)=0
12888 K(N,5)=0
12889C...Search for daughters of intermediate colourless particles.
12890 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12891 DO 475 IUPDAU=IUP+1,NUP
12892 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12893 & N+IUPDAU-IUP
12894 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12895 475 CONTINUE
12896 ENDIF
12897 DO 480 J=1,5
12898 P(N,J)=PUP(J,IUP)
12899 480 CONTINUE
12900 V(N,5)=VTIMUP(IUP)
12901 490 CONTINUE
12902 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12903
12904C...Arrange colour flow for user-defined processes
12905 NLBL=0
12906 DO 540 IUP1=1,NUP
12907 I1=MINT(84)+IUP1
12908 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12909 IF(K(I1,1).EQ.1) K(I1,1)=3
12910 IF(K(I1,1).EQ.11) K(I1,1)=14
12911C...Find a not yet considered colour/anticolour line.
12912 DO 530 ISDE1=1,2
12913 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12914 NMAT=0
12915 DO 500 ILBL=1,NLBL
12916 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12917 500 CONTINUE
12918 IF(NMAT.EQ.0) THEN
12919 NLBL=NLBL+1
12920 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12921C...Find all others belonging to same line.
12922 I3=I1
12923 I4=0
12924 DO 520 IUP2=IUP1+1,NUP
12925 I2=MINT(84)+IUP2
12926 DO 510 ISDE2=1,2
12927 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12928 IF(ISDE2.EQ.ISDE1) THEN
12929 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12930 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12931 I3=I2
12932 ELSEIF(I4.NE.0) THEN
12933 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12934 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12935 I4=I2
12936 ELSEIF(IUP2.LE.2) THEN
12937 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12938 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12939 I4=I2
12940 ELSE
12941 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12942 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12943 I4=I2
12944 ENDIF
12945 ENDIF
12946 510 CONTINUE
12947 520 CONTINUE
12948 ENDIF
12949 530 CONTINUE
12950 540 CONTINUE
12951
12952 ELSEIF(IDOC.EQ.7) THEN
12953C...Resonance not decaying; store kinematics
12954 I=MINT(83)+7
12955 K(IPU3,1)=1
12956 K(IPU3,2)=KFRES
12957 K(IPU3,3)=I
12958 P(IPU3,4)=SHUSER
12959 P(IPU3,5)=SHUSER
12960 K(I,1)=21
12961 K(I,2)=KFRES
12962 P(I,4)=SHUSER
12963 P(I,5)=SHUSER
12964 N=IPU3
12965 MINT(21)=KFRES
12966 MINT(22)=0
12967
12968C...Special cases: colour flow in coloured resonances
12969 KCRES=PYCOMP(KFRES)
12970 IF(KCHG(KCRES,2).NE.0) THEN
12971 K(IPU3,1)=3
12972 DO 550 J=1,2
12973 JC=J
12974 IF(KCS.EQ.-1) JC=3-J
12975 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12976 & MINT(84)+ICOL(KCC,1,JC)
12977 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12978 & MINT(84)+ICOL(KCC,2,JC)
12979 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12980 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12981 550 CONTINUE
12982 ELSE
12983 K(IPU1,4)=IPU2
12984 K(IPU1,5)=IPU2
12985 K(IPU2,4)=IPU1
12986 K(IPU2,5)=IPU1
12987 ENDIF
12988
12989 ELSEIF(IDOC.EQ.8) THEN
12990C...2 -> 2 processes: store outgoing partons in their CM-frame
12991 DO 560 JT=1,2
12992 I=MINT(84)+2+JT
12993 KCA=PYCOMP(MINT(20+JT))
12994 K(I,1)=1
12995 IF(KCHG(KCA,2).NE.0) K(I,1)=3
12996 K(I,2)=MINT(20+JT)
12997 K(I,3)=MINT(83)+IDOC+JT-2
12998 KFAA=IABS(K(I,2))
12999 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13000 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13001 ELSE
13002 P(I,5)=PYMASS(K(I,2))
13003 ENDIF
13004 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13005 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13006 560 CONTINUE
13007 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13008 KFA1=IABS(MINT(21))
13009 KFA2=IABS(MINT(22))
13010 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13011 & THEN
13012 MINT(51)=1
13013 RETURN
13014 ENDIF
13015 P(IPU3,5)=0D0
13016 P(IPU4,5)=0D0
13017 ENDIF
13018 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13019 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13020 P(IPU4,4)=SHR-P(IPU3,4)
13021 P(IPU4,3)=-P(IPU3,3)
13022 N=IPU4
13023 MINT(7)=MINT(83)+7
13024 MINT(8)=MINT(83)+8
13025
13026C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13027 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13028
13029 ELSEIF(IDOC.EQ.9) THEN
13030C...2 -> 3 processes: store outgoing partons in their CM frame
13031 DO 570 JT=1,2
13032 I=MINT(84)+2+JT
13033 KCA=PYCOMP(MINT(20+JT))
13034 K(I,1)=1
13035 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13036 K(I,2)=MINT(20+JT)
13037 K(I,3)=MINT(83)+IDOC+JT-3
13038 JTA=JT
13039C...t and b in opposide order in event list as compared to
13040C...matrix element?
13041 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13042 IF(IABS(K(I,2)).LE.22) THEN
13043 P(I,5)=PYMASS(K(I,2))
13044 ELSE
13045 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13046 ENDIF
13047 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13048 P(I,1)=PT*COS(VINT(198+5*JTA))
13049 P(I,2)=PT*SIN(VINT(198+5*JTA))
13050 570 CONTINUE
13051 K(IPU5,1)=1
13052 K(IPU5,2)=KFRES
13053 K(IPU5,3)=MINT(83)+IDOC
13054 P(IPU5,5)=SHR
13055 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13056 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13057 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13058 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13059 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13060 PMT3=SQRT(PMS3)
13061 P(IPU5,3)=PMT3*SINH(VINT(211))
13062 P(IPU5,4)=PMT3*COSH(VINT(211))
13063 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13064 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13065 IF(SQL12.LE.0D0) THEN
13066 MINT(51)=1
13067 RETURN
13068 ENDIF
13069 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13070 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13071 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13072 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13073C...t and b in opposide order in event list as compared to
13074C...matrix element
13075 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13076 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13077 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13078 END IF
13079 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13080 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13081 MINT(23)=KFRES
13082 N=IPU5
13083 MINT(7)=MINT(83)+7
13084 MINT(8)=MINT(83)+8
13085
13086 ELSEIF(IDOC.EQ.11) THEN
13087C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13088 PHI(1)=PARU(2)*PYR(0)
13089 PHI(2)=PHI(1)-PHIR
13090 DO 580 JT=1,2
13091 I=MINT(84)+2+JT
13092 K(I,1)=1
13093 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13094 K(I,2)=MINT(20+JT)
13095 K(I,3)=MINT(83)+IDOC+JT-2
13096 P(I,5)=PYMASS(K(I,2))
13097 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13098 MINT(51)=1
13099 RETURN
13100 ENDIF
13101 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13102 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13103 P(I,1)=PTABS*COS(PHI(JT))
13104 P(I,2)=PTABS*SIN(PHI(JT))
13105 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13106 P(I,4)=0.5D0*SHPR*Z(JT)
13107 IZW=MINT(83)+6+JT
13108 K(IZW,1)=21
13109 K(IZW,2)=23
13110 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13111 K(IZW,3)=IZW-2
13112 P(IZW,1)=-P(I,1)
13113 P(IZW,2)=-P(I,2)
13114 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13115 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13116 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13117 580 CONTINUE
13118 I=MINT(83)+9
13119 K(IPU5,1)=1
13120 K(IPU5,2)=KFRES
13121 K(IPU5,3)=I
13122 P(IPU5,5)=SHR
13123 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13124 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13125 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13126 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13127 K(I,1)=21
13128 K(I,2)=KFRES
13129 DO 590 J=1,5
13130 P(I,J)=P(IPU5,J)
13131 590 CONTINUE
13132 N=IPU5
13133 MINT(23)=KFRES
13134
13135 ELSEIF(IDOC.EQ.12) THEN
13136C...Z0 and W+/- scattering: store bosons and outgoing partons
13137 PHI(1)=PARU(2)*PYR(0)
13138 PHI(2)=PHI(1)-PHIR
13139 JTRAN=INT(1.5D0+PYR(0))
13140 DO 600 JT=1,2
13141 I=MINT(84)+2+JT
13142 K(I,1)=1
13143 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13144 K(I,2)=MINT(20+JT)
13145 K(I,3)=MINT(83)+IDOC+JT-2
13146 P(I,5)=PYMASS(K(I,2))
13147 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13148 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13149 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13150 P(I,1)=PTABS*COS(PHI(JT))
13151 P(I,2)=PTABS*SIN(PHI(JT))
13152 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13153 P(I,4)=0.5D0*SHPR*Z(JT)
13154 IZW=MINT(83)+6+JT
13155 K(IZW,1)=21
13156 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13157 K(IZW,2)=23
13158 ELSE
13159 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13160 ENDIF
13161 K(IZW,3)=IZW-2
13162 P(IZW,1)=-P(I,1)
13163 P(IZW,2)=-P(I,2)
13164 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13165 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13166 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13167 IPU=MINT(84)+4+JT
13168 K(IPU,1)=3
13169 K(IPU,2)=KFPR(ISUB,JT)
13170 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13171 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13172 K(IPU,3)=MINT(83)+8+JT
13173 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13174 P(IPU,5)=PYMASS(K(IPU,2))
13175 ELSE
13176 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13177 ENDIF
13178 MINT(22+JT)=K(IPU,2)
13179 600 CONTINUE
13180C...Find rotation and boost for hard scattering subsystem
13181 I1=MINT(83)+7
13182 I2=MINT(83)+8
13183 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13184 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13185 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13186 GAMCM=(P(I1,4)+P(I2,4))/SHR
13187 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13188 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13189 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13190 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13191 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13192 PHICM=PYANGL(PX,PY)
13193C...Store hard scattering subsystem. Rotate and boost it
13194 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13195 & P(IPU6,5)**2
13196 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13197 CTHWZ=VINT(23)
13198 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13199 PHIWZ=VINT(24)-PHICM
13200 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13201 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13202 P(IPU5,3)=PABS*CTHWZ
13203 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13204 P(IPU6,1)=-P(IPU5,1)
13205 P(IPU6,2)=-P(IPU5,2)
13206 P(IPU6,3)=-P(IPU5,3)
13207 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13208 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13209 DO 620 JT=1,2
13210 I1=MINT(83)+8+JT
13211 I2=MINT(84)+4+JT
13212 K(I1,1)=21
13213 K(I1,2)=K(I2,2)
13214 DO 610 J=1,5
13215 P(I1,J)=P(I2,J)
13216 610 CONTINUE
13217 620 CONTINUE
13218 N=IPU6
13219 MINT(7)=MINT(83)+9
13220 MINT(8)=MINT(83)+10
13221 ENDIF
13222
13223 IF(ISET(ISUB).EQ.11) THEN
13224 ELSEIF(IDOC.GE.8) THEN
13225C...Store colour connection indices
13226 DO 630 J=1,2
13227 JC=J
13228 IF(KCS.EQ.-1) JC=3-J
13229 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13230 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13231 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13232 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13233 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13234 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13235 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13236 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13237 630 CONTINUE
13238
13239C...Copy outgoing partons to documentation lines
13240 IMAX=2
13241 IF(IDOC.EQ.9) IMAX=3
13242 DO 650 I=1,IMAX
13243 I1=MINT(83)+IDOC-IMAX+I
13244 I2=MINT(84)+2+I
13245 K(I1,1)=21
13246 K(I1,2)=K(I2,2)
13247 IF(IDOC.LE.9) K(I1,3)=0
13248 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13249 DO 640 J=1,5
13250 P(I1,J)=P(I2,J)
13251 640 CONTINUE
13252 650 CONTINUE
13253
13254 ELSEIF(IDOC.EQ.9) THEN
13255C...Store colour connection indices
13256 DO 660 J=1,2
13257 JC=J
13258 IF(KCS.EQ.-1) JC=3-J
13259 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13260 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13261 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13262 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13263 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13264 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13265 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13266 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13267 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13268 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13269 660 CONTINUE
13270
13271C...Copy outgoing partons to documentation lines
13272 DO 680 I=1,3
13273 I1=MINT(83)+IDOC-3+I
13274 I2=MINT(84)+2+I
13275 K(I1,1)=21
13276 K(I1,2)=K(I2,2)
13277 K(I1,3)=0
13278 DO 670 J=1,5
13279 P(I1,J)=P(I2,J)
13280 670 CONTINUE
13281 680 CONTINUE
13282 ENDIF
13283
13284C...Copy outgoing partons to list of allowed radiators.
13285 NPART=0
13286 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13287 DO 690 I=MINT(84)+3,N
13288 NPART=NPART+1
13289 IPART(NPART)=I
13290 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13291 690 CONTINUE
13292 ENDIF
13293
13294C...Low-pT events: remove gluons used for string drawing purposes
13295 IF(ISUB.EQ.95) THEN
13296 IF(MINT(35).LE.1) THEN
13297 K(IPU3,1)=K(IPU3,1)+10
13298 K(IPU4,1)=K(IPU4,1)+10
13299 ENDIF
13300 DO 700 J=41,66
13301 VINTSV(J)=VINT(J)
13302 VINT(J)=0D0
13303 700 CONTINUE
13304 DO 720 I=MINT(83)+5,MINT(83)+8
13305 DO 710 J=1,5
13306 P(I,J)=0D0
13307 710 CONTINUE
13308 720 CONTINUE
13309 ENDIF
13310
13311 RETURN
13312 END
13313
13314C***********************************************************************
13315
13316C...PYEVOL
13317C...Handles intertwined pT-ordered spacelike initial-state parton
13318C...and multiple interactions.
13319
13320 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13321C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13322C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13323C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13324
13325C...Double precision and integer declarations.
13326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13327 IMPLICIT INTEGER(I-N)
13328 INTEGER PYK,PYCHGE,PYCOMP
13329C...External
13330 EXTERNAL PYALPS
13331 DOUBLE PRECISION PYALPS
13332C...Parameter statement for maximum size of showers.
13333 PARAMETER (MAXNUR=1000)
13334C...Commonblocks.
13335 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13336 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13338 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13339 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13340 COMMON/PYINT1/MINT(400),VINT(400)
13341 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13342 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13343 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13344 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13345 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13346 COMMON/PYCTAG/NCT,MCT(4000,2)
13347 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13348 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13349 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13350C...Local arrays and saved variables.
13351 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13352 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13353 & ,PSAV,KSAV,VSAV
13354
13355 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13356 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13357
13358C----------------------------------------------------------------------
13359C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13360C...done only once per event, while MODE=0 is repeated each time the
13361C...evolution needs to be restarted.
13362 IF (MODE.EQ.-1) THEN
13363 ISUBHD=MINT(1)
13364 NSAV=N
13365 NPARTS=NPART
13366C...Store hard scattering variables
13367 M15SV=MINT(15)
13368 M16SV=MINT(16)
13369 M21SV=MINT(21)
13370 M22SV=MINT(22)
13371 DO 100 J=11,80
13372 VINTSV(J)=VINT(J)
13373 100 CONTINUE
13374 DO 120 J=1,5
13375 DO 110 IS=1,4
13376 I=IS+MINT(84)
13377 PSAV(IS,J)=P(I,J)
13378 KSAV(IS,J)=K(I,J)
13379 VSAV(IS,J)=V(I,J)
13380 110 CONTINUE
13381 120 CONTINUE
13382
13383C...Set shat for hardest scattering
13384 SHAT(1)=VINT(44)
13385 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13386 & *VINT(2)
13387
13388C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13389 RMC=PMAS(4,1)
13390 RMB=PMAS(5,1)
13391 ALAM4=PARP(61)
13392 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13393 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13394 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13395
13396C----------------------------------------------------------------------
13397C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13398C...interaction initiators, with no previous evolution. Check the input
13399C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13400C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13401C...smaller than the CM energy / 2.)
13402 ELSEIF (MODE.EQ.0) THEN
13403C...Reset counters and switches
13404 N=NSAV
13405 NPART=NPARTS
13406 MINT(30)=0
13407 MINT(31)=1
13408 MINT(36)=1
13409C...Reset hard scattering variables
13410 MINT(1)=ISUBHD
13411 DO 130 J=11,80
13412 VINT(J)=VINTSV(J)
13413 130 CONTINUE
13414 DO 150 J=1,5
13415 DO 140 IS=1,4
13416 I=IS+MINT(84)
13417 P(I,J)=PSAV(IS,J)
13418 K(I,J)=KSAV(IS,J)
13419 V(I,J)=VSAV(IS,J)
13420 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13421 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13422 140 CONTINUE
13423 150 CONTINUE
13424C...Reset statistics on activity in event.
13425 DO 160 J=351,359
13426 MINT(J)=0
13427 VINT(J)=0D0
13428 160 CONTINUE
13429C...Reset extra companion reweighting factor
13430 VINT(140)=1D0
13431
13432C...We do not generate MI for soft process (ISUB=95), but the
13433C...initialization must be done regardless, for later purposes.
13434 MINT(36)=1
13435
13436C...Initialize multiple interactions.
13437 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13438 IF(MINT(51).NE.0) RETURN
13439
13440C...Decide whether quarks in hard scattering were valence or sea
13441 PT2HD=VINT(54)
13442 DO 170 JS=1,2
13443 MINT(30)=JS
13444 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13445 IF(MINT(51).NE.0) RETURN
13446 170 CONTINUE
13447
13448C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13449 VINT(18)=0D0
13450 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13451 IF (MSTP(70).EQ.2) THEN
13452C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13453 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13454 ELSEIF (MSTP(70).EQ.3) THEN
13455C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13456 ALPHA0 = MAX(1D-6,PARP(73))
13457 Q20 = ALAM3**2/PARP(64)
13458 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13459 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13460 ENDIF
13461C...Also store PT2MIN in VINT(17).
13462 180 VINT(17)=PT2MIN
13463
13464C...Set FS masses zero now.
13465 VINT(63)=0D0
13466 VINT(64)=0D0
13467
13468C...Initialize IS showers with VINT(56) as max scale.
13469 PT2ISR=VINT(56)
13470 PT20=PT2MIN
13471 IF (MSTP(70).EQ.0) THEN
13472 PT20=MAX(PT2MIN,PARP(62)**2)
13473 ELSEIF (MSTP(70).EQ.1) THEN
13474 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13475 ENDIF
13476 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13477 IF(MINT(51).NE.0) RETURN
13478
13479 RETURN
13480
13481C----------------------------------------------------------------------
13482C...MODE= 1: Evolve event from PTMAX to PTMIN.
13483 ELSEIF (MODE.EQ.1) THEN
13484
13485C...Skip if no phase space.
13486 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13487
13488C...Starting pT2 max scale (to be udpated successively).
13489 PT2CMX=PT2MAX
13490
13491C...Evolve two sides of the event to find which branches at highest pT.
13492 200 JSMX=-1
13493 MIMX=0
13494 PT2MX=0D0
13495
13496C...Loop over current shower initiators.
13497 IF (MSTP(61).GE.1) THEN
13498 DO 230 MI=1,MINT(31)
13499 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13500 ISUB=96
13501 IF (MI.EQ.1) ISUB=ISUBHD
13502 MINT(1)=ISUB
13503 MINT(36)=MI
13504C...Set up shat, initiator x values, and x remaining in BR.
13505 VINT(44)=SHAT(MI)
13506 VINT(141)=XMI(1,MI)
13507 VINT(142)=XMI(2,MI)
13508 VINT(143)=1D0
13509 VINT(144)=1D0
13510 DO 210 JI=1,MINT(31)
13511 IF (JI.EQ.MINT(36)) GOTO 210
13512 VINT(143)=VINT(143)-XMI(1,JI)
13513 VINT(144)=VINT(144)-XMI(2,JI)
13514 210 CONTINUE
13515C...Loop over sides.
13516C...Generate trial branchings for this interaction. The hardest
13517C...branching so far is automatically updated if necessary in /PYISMX/.
13518 DO 220 JS=1,2
13519 MINT(30)=JS
13520 PT20=PT2MIN
13521 IF (MSTP(70).EQ.0) THEN
13522 PT20=MAX(PT2MIN,PARP(62)**2)
13523 ELSEIF (MSTP(70).EQ.1) THEN
13524 PT20=MAX(PT2MIN,
13525 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13526 ENDIF
13527 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13528 IF (MINT(51).NE.0) RETURN
13529 220 CONTINUE
13530 230 CONTINUE
13531 ENDIF
13532
13533C...Generate trial additional interaction.
13534 MINT(36)=MINT(31)+1
13535 240 IF (MOD(MSTP(81),10).GE.1) THEN
13536 MINT(1)=96
13537C...Set up X remaining in BR.
13538 VINT(143)=1D0
13539 VINT(144)=1D0
13540 DO 250 JI=1,MINT(31)
13541 VINT(143)=VINT(143)-XMI(1,JI)
13542 VINT(144)=VINT(144)-XMI(2,JI)
13543 250 CONTINUE
13544C...Generate trial interaction
13545 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13546 IF (MINT(51).EQ.1) RETURN
13547 ENDIF
13548
13549C...And the winner is:
13550 IF (PT2MX.LT.PT2MIN) THEN
13551 GOTO 330
13552 ELSEIF (JSMX.EQ.0) THEN
13553C...Accept additional interaction (may still fail).
13554 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13555 IF(MINT(51).NE.0) RETURN
13556 IF (IFAIL.EQ.0) THEN
13557 SHAT(MINT(36))=VINT(44)
13558C...Decide on flavours (valence/sea/companion).
13559 DO 270 JS=1,2
13560 MINT(30)=JS
13561 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13562 IF(MINT(51).NE.0) RETURN
13563 270 CONTINUE
13564 ENDIF
13565 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13566C...Reconstruct kinematics of acceptable ISR branching.
13567C...Set up shat, initiator x values, and x remaining in BR.
13568 MINT(30)=JSMX
13569 MINT(36)=MIMX
13570 VINT(44)=SHAT(MINT(36))
13571 VINT(141)=XMI(1,MINT(36))
13572 VINT(142)=XMI(2,MINT(36))
13573 VINT(143)=1D0
13574 VINT(144)=1D0
13575 DO 280 JI=1,MINT(31)
13576 IF (JI.EQ.MINT(36)) GOTO 280
13577 VINT(143)=VINT(143)-XMI(1,JI)
13578 VINT(144)=VINT(144)-XMI(2,JI)
13579 280 CONTINUE
13580 PT2NEW=PT2MX
13581 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13582 IF (MINT(51).EQ.1) RETURN
13583 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13584C...Bookeep joining. Cannot (yet) be constructed kinematically.
13585 MINT(354)=MINT(354)+1
13586 VINT(354)=VINT(354)+SQRT(PT2MX)
13587 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13588 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13589 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13590 ENDIF
13591
13592C...Update PT2 iteration scale.
13593 PT2CMX=PT2MX
13594
13595C...Loop back to continue evolution.
13596 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13597 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13598 ELSE
13599 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13600 ENDIF
13601
13602C----------------------------------------------------------------------
13603C...MODE= 2: (Re-)store user information on hardest interaction etc.
13604 ELSEIF (MODE.EQ.2) THEN
13605
13606C...Revert to "ordinary" meanings of some parameters.
13607 290 DO 310 JS=1,2
13608 MINT(12+JS)=K(IMI(JS,1,1),2)
13609 VINT(140+JS)=XMI(JS,1)
13610 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13611 VINT(142+JS)=1D0
13612 DO 300 MI=1,MINT(31)
13613 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13614 300 CONTINUE
13615 310 CONTINUE
13616
13617C...Restore saved quantities for hardest interaction.
13618 MINT(1)=ISUBHD
13619 MINT(15)=M15SV
13620 MINT(16)=M16SV
13621 MINT(21)=M21SV
13622 MINT(22)=M22SV
13623 DO 320 J=11,80
13624 VINT(J)=VINTSV(J)
13625 320 CONTINUE
13626
13627 ENDIF
13628
13629 330 RETURN
13630 END
13631
13632C*********************************************************************
13633
13634C...PYSSPA
13635C...Generates spacelike parton showers.
13636
13637 SUBROUTINE PYSSPA(IPU1,IPU2)
13638
13639C...Double precision and integer declarations.
13640 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13641 IMPLICIT INTEGER(I-N)
13642 INTEGER PYK,PYCHGE,PYCOMP
13643 PARAMETER (MAXNUR=1000)
13644C...Commonblocks.
13645 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13646 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13649 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13650 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13651 COMMON/PYINT1/MINT(400),VINT(400)
13652 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13653 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13654 COMMON/PYCTAG/NCT,MCT(4000,2)
13655 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13656 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13657C...Local arrays and data.
13658 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13659 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13660 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13661 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13662 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13663 DATA IS/2*0/
13664
13665C...Read out basic information; set global Q^2 scale.
13666 IPUS1=IPU1
13667 IPUS2=IPU2
13668 ISUB=MINT(1)
13669 Q2MX=VINT(56)
13670 VINT2R=VINT(2)*VINT(143)*VINT(144)
13671 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13672 &MIN(VINT2R,PARP(67)*VINT(56))
13673 FCQ2MX=1D0
13674
13675C...Define which processes ME corrections have been implemented for.
13676 MECOR=0
13677 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13678 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13679 & ISUB.EQ.144) MECOR=1
13680 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13681 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13682 ENDIF
13683
13684C...Initialize QCD evolution and check phase space.
13685 Q2MNC=PARP(62)**2
13686 Q2MNCS(1)=Q2MNC
13687 Q2MNCS(2)=Q2MNC
13688 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13689 Q0S=PARP(15)**2
13690 PS=VINT(3)**2
13691 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13692 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13693 Q2INT=SQRT(Q0S*Q2EFF)
13694 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13695 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13696 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13697 ENDIF
13698 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13699 Q0S=PARP(15)**2
13700 PS=VINT(4)**2
13701 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13702 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13703 Q2INT=SQRT(Q0S*Q2EFF)
13704 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13705 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13706 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13707 ENDIF
13708 MCEV=0
13709 ALAMS=PARU(112)
13710 PARU(112)=PARP(61)
13711 FQ2C=1D0
13712 TCMX=0D0
13713 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13714 MCEV=1
13715 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13716 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13717 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13718 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13719 & MCEV=0
13720 ENDIF
13721
13722C...Initialize QED evolution and check phase space.
13723 MEEV=0
13724 XEE=1D-10
13725 SPME=PMAS(11,1)**2
13726 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13727 &SPME=PMAS(13,1)**2
13728 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13729 &SPME=PMAS(15,1)**2
13730 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13731 TEMX=0D0
13732 FWTE=10D0
13733 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13734 MEEV=1
13735 TEMX=LOG(Q2MX/SPME)
13736 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13737 ENDIF
13738 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13739 MEEV=2
13740 TEMX=TCMX
13741 FWTE=1D0
13742 ENDIF
13743 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13744
13745C...Loopback point in case of failure to reconstruct kinematics.
13746 NS=N
13747 NPARTS=NPART
13748 LOOP=0
13749 MNT352=MINT(352)
13750 MNT353=MINT(353)
13751 VNT352=VINT(352)
13752 VNT353=VINT(353)
13753 100 LOOP=LOOP+1
13754 IF(LOOP.GT.100) THEN
13755 MINT(51)=1
13756 RETURN
13757 ENDIF
13758 N=NS
13759 NPART=NPARTS
13760 MINT(352)=MNT352
13761 MINT(353)=MNT353
13762 VINT(352)=VNT352
13763 VINT(353)=VNT353
13764
13765C...Initial values: flavours, momenta, virtualities.
13766 DO 120 JT=1,2
13767 MORE(JT)=1
13768 KFBEAM(JT)=MINT(10+JT)
13769 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13770 KFLS(JT)=MINT(14+JT)
13771 KFLS(JT+2)=KFLS(JT)
13772 XS(JT)=VINT(40+JT)
13773 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13774 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13775 ZS(JT)=1D0
13776 Q2S(JT)=FCQ2MX*Q2MX
13777 DQ2(JT)=0D0
13778 TEVCSV(JT)=TCMX
13779 ALAM(JT)=PARP(61)
13780 THE2(JT)=1D0
13781 TEVESV(JT)=TEMX
13782 MCESV(JT)=0
13783C...Calculate initial parton distribution weights.
13784 MINT(105)=MINT(102+JT)
13785 MINT(109)=MINT(106+JT)
13786 VINT(120)=VINT(2+JT)
13787C.... ALICE
13788C.... Store side in MINT(124)
13789 MINT(124) = JT
13790C....
13791 IF(XS(JT).LT.1D0-XEE) THEN
13792 IF(MINT(31).GE.2) MINT(30)=JT
13793 IF(MSTP(57).LE.1) THEN
13794 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13795 ELSE
13796 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13797 ENDIF
13798 ENDIF
13799 DO 110 KFL=-25,25
13800 XFS(JT,KFL)=XFB(KFL)
13801 110 CONTINUE
13802C...Special kinematics check for c/b quarks (that g -> c cbar or
13803C...b bbar kinematically possible).
13804 KFLCB=IABS(KFLS(JT))
13805 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13806 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13807 MINT(51)=1
13808 RETURN
13809 ENDIF
13810 ENDIF
13811 120 CONTINUE
13812 DSH=VINT(44)
13813 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13814
13815C...Find if interference with final state partons.
13816 MFIS=0
13817 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13818 IF(MFIS.NE.0) THEN
13819 DO 140 I=1,2
13820 KCFI(I)=0
13821 KCA=PYCOMP(IABS(KFLS(I)))
13822 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13823 NFIS(I)=0
13824 IF(KCFI(I).NE.0) THEN
13825 IF(I.EQ.1) IPFS=IPUS1
13826 IF(I.EQ.2) IPFS=IPUS2
13827 DO 130 J=1,2
13828 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13829 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13830 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13831 NFIS(I)=NFIS(I)+1
13832 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13833 & P(ICSI,2)**2))
13834 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13835 ENDIF
13836 130 CONTINUE
13837 ENDIF
13838 140 CONTINUE
13839 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13840 ENDIF
13841
13842C...Pick up leg with highest virtuality.
13843 JTOLD=1
13844 150 N=N+1
13845 JT=1
13846 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13847 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13848 IF(MORE(JT).EQ.0) JT=3-JT
13849 JTOLD=JT
13850 KFLB=KFLS(JT)
13851 XB=XS(JT)
13852 DO 160 KFL=-25,25
13853 XFB(KFL)=XFS(JT,KFL)
13854 160 CONTINUE
13855 DSHR=2D0*SQRT(DSH)
13856 DSHZ=DSH/ZS(JT)
13857
13858C...Check if allowed to branch.
13859 MCEV=0
13860 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13861 MCEV=1
13862 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13863 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13864 ENDIF
13865 MEEV=0
13866 IF(MINT(44+JT).EQ.3) THEN
13867 MEEV=1
13868 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13869 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13870 & MEEV=0
13871C***Currently kill QED shower for resolved photoproduction.
13872 IF(MINT(18+JT).EQ.1) MEEV=0
13873C***Currently kill shower for W inside electron.
13874 IF(IABS(KFLB).EQ.24) THEN
13875 MCEV=0
13876 MEEV=0
13877 ENDIF
13878 ENDIF
13879 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13880 &MEEV=2
13881 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13882 Q2B=0D0
13883 GOTO 260
13884 ENDIF
13885
13886C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13887 Q2B=Q2S(JT)
13888 TEVCB=TEVCSV(JT)
13889 TEVEB=TEVESV(JT)
13890 IF(MSTP(62).LE.1) THEN
13891 IF(ZS(JT).GT.0.99999D0) THEN
13892 Q2B=Q2S(JT)
13893 ELSE
13894 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13895 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13896 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13897 ENDIF
13898 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13899 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13900 ENDIF
13901 IF(MCEV.EQ.1) THEN
13902 ALSDUM=PYALPS(FQ2C*Q2B)
13903 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13904 ALAM(JT)=PARU(117)
13905 B0=(33D0-2D0*MSTU(118))/6D0
13906 ENDIF
13907 IF(MEEV.EQ.2) TEVEB=TEVCB
13908 TEVCBS=TEVCB
13909 TEVEBS=TEVEB
13910
13911C...Select side for interference with final state partons.
13912 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13913 IFI=N-NS
13914 ISFI(IFI)=0
13915 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13916 ISFI(IFI)=1
13917 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13918 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13919 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13920 ISFI(IFI)=1
13921 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13922 ENDIF
13923 ENDIF
13924
13925C...Calculate preweighting factor for ME-corrected processes.
13926 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13927
13928C...Calculate Altarelli-Parisi weights.
13929 DO 170 KFL=-25,25
13930 WTAPC(KFL)=0D0
13931 WTAPE(KFL)=0D0
13932 WTSF(KFL)=0D0
13933 170 CONTINUE
13934C...q -> q (g or gamma emission), g -> q.
13935 IF(IABS(KFLB).LE.10) THEN
13936 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13937 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13938 EQ2=1D0/9D0
13939 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13940 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13941 & (XEC*(1D0-XEC)))
13942 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13943 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13944 WTAPC(21)=WTGF*WTAPC(21)
13945 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13946 ENDIF
13947C...f -> f, gamma -> f.
13948 ELSEIF(IABS(KFLB).LE.20) THEN
13949 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13950 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13951 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13952 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13953 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13954 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13955 WTAPE(22)=WTGF*WTAPE(22)
13956 ENDIF
13957C...f -> g, g -> g.
13958 ELSEIF(KFLB.EQ.21) THEN
13959 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13960 DO 180 KFL=1,MSTP(58)
13961 WTAPC(KFL)=WTAPQ
13962 WTAPC(-KFL)=WTAPQ
13963 180 CONTINUE
13964 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13965 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13966 DO 190 KFL=1,MSTP(58)
13967 WTAPC(KFL)=WTFG*WTAPC(KFL)
13968 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13969 190 CONTINUE
13970 WTAPC(21)=WTGG*WTAPC(21)
13971 ENDIF
13972C...f -> gamma, W+, W-.
13973 ELSEIF(KFLB.EQ.22) THEN
13974 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13975 WTAPE(11)=WTAPF
13976 WTAPE(-11)=WTAPF
13977 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13978 WTAPE(11)=WTFG*WTAPE(11)
13979 WTAPE(-11)=WTFG*WTAPE(-11)
13980 ENDIF
13981 ELSEIF(KFLB.EQ.24) THEN
13982 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13983 & (XEE*(XB+XEE)))/XB
13984 ELSEIF(KFLB.EQ.-24) THEN
13985 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13986 & (XEE*(XB+XEE)))/XB
13987 ENDIF
13988
13989C...Calculate parton distribution weights and sum.
13990 NTRY=0
13991 200 NTRY=NTRY+1
13992 IF(NTRY.GT.500) THEN
13993 MINT(51)=1
13994 RETURN
13995 ENDIF
13996 WTSUMC=0D0
13997 WTSUME=0D0
13998 XFBO=MAX(1D-10,XFB(KFLB))
13999 DO 210 KFL=-25,25
14000 WTSF(KFL)=XFB(KFL)/XFBO
14001 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14002 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14003 210 CONTINUE
14004 WTSUMC=MAX(0.0001D0,WTSUMC)
14005 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14006
14007C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14008 NTRY2=0
14009 220 NTRY2=NTRY2+1
14010 IF(NTRY2.GT.500) THEN
14011 MINT(51)=1
14012 RETURN
14013 ENDIF
14014 IF(MCEV.EQ.1) THEN
14015 IF(MSTP(64).LE.0) THEN
14016 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14017 ELSEIF(MSTP(64).EQ.1) THEN
14018 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14019 ELSE
14020 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14021 ENDIF
14022 ENDIF
14023 IF(MEEV.EQ.1) THEN
14024 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14025 & (PARU(101)*FWTE*WTSUME*TEMX)))
14026 ELSEIF(MEEV.EQ.2) THEN
14027 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14028 ENDIF
14029
14030C...Translate t into Q2 scale; choose between QCD and QED evolution.
14031 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14032 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14033 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14034C...Ensure that Q2 is above threshold for charm/bottom.
14035 KFLCB=IABS(KFLB)
14036 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14037 &MCEV.EQ.1) THEN
14038 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14039 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14040 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14041 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14042 ENDIF
14043 ENDIF
14044 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14045 &MEEV.EQ.2) THEN
14046 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14047 ENDIF
14048 MCE=0
14049 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14050 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14051 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14052 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14053 IF(Q2EB.GT.Q2MNE) MCE=2
14054 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14055 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14056 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14057 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14058 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14059 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14060 MCE=1
14061 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14062 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14063 ELSE
14064 MCE=2
14065 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14066 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14067 ENDIF
14068
14069C...Evolution possibly ended. Update t values.
14070 IF(MCE.EQ.0) THEN
14071 Q2B=0D0
14072 GOTO 260
14073 ELSEIF(MCE.EQ.1) THEN
14074 Q2B=Q2CB
14075 Q2REF=FQ2C*Q2B
14076 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14077 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14078 ELSE
14079 Q2B=Q2EB
14080 Q2REF=Q2B
14081 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14082 ENDIF
14083
14084C...Select flavour for branching parton.
14085 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14086 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14087 KFLA=-25
14088 240 KFLA=KFLA+1
14089 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14090 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14091 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14092 IF(KFLA.EQ.25) THEN
14093 Q2B=0D0
14094 GOTO 260
14095 ENDIF
14096
14097C...Choose z value and corrective weight.
14098 WTZ=0D0
14099C...q -> q + g or q -> q + gamma.
14100 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14101 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14102 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14103 WTZ=0.5D0*(1D0+Z**2)
14104C...q -> g + q.
14105 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14106 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14107 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14108C...f -> f + gamma.
14109 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14110 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14111 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14112 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14113 ELSE
14114 Z=XB+XB*(XEE/(1D0-XEE))*
14115 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14116 ENDIF
14117 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14118C...f -> gamma + f.
14119 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14120 Z=XB+XB*(XEE/(1D0-XEE))*
14121 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14122 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14123C...f -> W+- + f.
14124 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14125 Z=XB+XB*(XEE/(1D0-XEE))*
14126 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14127 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14128 & (Q2B/(Q2B+PMAS(24,1)**2))
14129C...g -> q + qbar.
14130 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14131 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14132 WTZ=1D0-2D0*Z*(1D0-Z)
14133C...g -> g + g.
14134 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14135 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14136 WTZ=(1D0-Z*(1D0-Z))**2
14137C...gamma -> f + fbar.
14138 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14139 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14140 WTZ=1D0-2D0*Z*(1D0-Z)
14141 ENDIF
14142 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14143
14144C...Option with resummation of soft gluon emission as effective z shift.
14145 IF(MCE.EQ.1) THEN
14146 IF(MSTP(65).GE.1) THEN
14147 RSOFT=6D0
14148 IF(KFLB.NE.21) RSOFT=8D0/3D0
14149 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14150 IF(Z.LE.XB) GOTO 220
14151 ENDIF
14152
14153C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14154 IF(MSTP(64).GE.2) THEN
14155 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14156 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14157 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14158 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14159 ENDIF
14160 ENDIF
14161
14162C...Remove kinematically impossible branchings.
14163 UHAT=Q2B-DSH*(1D0-Z)/Z
14164 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14165
14166C...Select phi angle of branching at random.
14167 PHIBR=PARU(2)*PYR(0)
14168
14169C...Matrix-element corrections for some processes.
14170 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14171 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14172 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14173 WTZ=WTZ*WTME/WTFF
14174 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14175 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14176 WTZ=WTZ*WTME/WTGF
14177 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14178 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14179 WTZ=WTZ*WTME/WTFG
14180 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14181 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14182 WTZ=WTZ*WTME/WTGG
14183 ENDIF
14184 ENDIF
14185
14186C...Impose angular constraint in first branching from interference
14187C...with final state partons.
14188 IF(MCE.EQ.1) THEN
14189 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14190 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14191 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14192 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14193 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14194 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14195 ENDIF
14196 ENDIF
14197
14198C...Option with angular ordering requirement.
14199 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14200 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14201 IF(THE2T.GT.THE2(JT)) GOTO 220
14202 ENDIF
14203 ENDIF
14204
14205C...Weighting with new parton distributions.
14206 MINT(105)=MINT(102+JT)
14207 MINT(109)=MINT(106+JT)
14208 VINT(120)=VINT(2+JT)
14209 IF(MINT(31).GE.2) MINT(30)=JT
14210C.... ALICE
14211C.... Store side in MINT(124)
14212 MINT(124) = JT
14213C....
14214 IF(MSTP(57).LE.1) THEN
14215 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14216 ELSE
14217 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14218 ENDIF
14219 XFBN=XFN(KFLB)
14220 IF(XFBN.LT.1D-20) THEN
14221 IF(KFLA.EQ.KFLB) THEN
14222 TEVCB=TEVCBS
14223 TEVEB=TEVEBS
14224 WTAPC(KFLB)=0D0
14225 WTAPE(KFLB)=0D0
14226 GOTO 200
14227 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14228 TEVCB=0.5D0*(TEVCBS+TEVCB)
14229 GOTO 230
14230 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14231 TEVEB=0.5D0*(TEVEBS+TEVEB)
14232 GOTO 230
14233 ELSE
14234 XFBN=1D-10
14235 XFN(KFLB)=XFBN
14236 ENDIF
14237 ENDIF
14238 DO 250 KFL=-25,25
14239 XFB(KFL)=XFN(KFL)
14240 250 CONTINUE
14241 XA=XB/Z
14242C.... ALICE
14243C.... Store side in MINT(124)
14244 MINT(124) = JT
14245C....
14246 IF(MINT(31).GE.2) MINT(30)=JT
14247 IF(MSTP(57).LE.1) THEN
14248 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14249 ELSE
14250 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14251 ENDIF
14252 XFAN=XFA(KFLA)
14253 IF(XFAN.LT.1D-20) GOTO 200
14254 WTSFA=WTSF(KFLA)
14255 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14256
14257C...Define two hard scatterers in their CM-frame.
14258 260 IF(N.EQ.NS+2) THEN
14259 DQ2(JT)=Q2B
14260 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14261 DO 280 JR=1,2
14262 I=NS+JR
14263 IF(JR.EQ.1) IPO=IPUS1
14264 IF(JR.EQ.2) IPO=IPUS2
14265 DO 270 J=1,5
14266 K(I,J)=0
14267 P(I,J)=0D0
14268 V(I,J)=0D0
14269 270 CONTINUE
14270 K(I,1)=14
14271 K(I,2)=KFLS(JR+2)
14272 K(I,4)=IPO
14273 K(I,5)=IPO
14274 P(I,3)=DPLCM*(-1)**(JR+1)
14275 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14276 P(I,5)=-SQRT(DQ2(JR))
14277 K(IPO,1)=14
14278 K(IPO,3)=I
14279 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14280 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14281 MCT(I,1)=MCT(IPO,1)
14282 MCT(I,2)=MCT(IPO,2)
14283 280 CONTINUE
14284
14285C...Find maximum allowed mass of timelike parton.
14286 ELSEIF(N.GT.NS+2) THEN
14287 JR=3-JT
14288 DQ2(3)=Q2B
14289 DPC(1)=P(IS(1),4)
14290 DPC(2)=P(IS(2),4)
14291 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14292 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14293 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14294 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14295 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14296 IKIN=0
14297 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14298 & 1D-10*DPD(1)) IKIN=1
14299 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14300 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14301 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14302 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14303
14304C...Generate timelike parton shower (if required).
14305 IT=N
14306 DO 290 J=1,5
14307 K(IT,J)=0
14308 P(IT,J)=0D0
14309 V(IT,J)=0D0
14310 290 CONTINUE
14311C...f -> f + g (gamma).
14312 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14313 K(IT,2)=21
14314 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14315C...f -> g (gamma, W+-) + f.
14316 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14317 K(IT,2)=KFLB
14318 IF(KFLS(JT+2).EQ.24) THEN
14319 K(IT,2)=-12
14320 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14321 K(IT,2)=12
14322 ENDIF
14323C...g (gamma) -> f + fbar, g + g.
14324 ELSE
14325 K(IT,2)=-KFLS(JT+2)
14326 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14327 ENDIF
14328 K(IT,1)=3
14329 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14330 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14331 P(IT,5)=PYMASS(K(IT,2))
14332 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14333 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14334 MSTJ48=MSTJ(48)
14335 PARJ85=PARJ(85)
14336 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14337 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14338 IF(MSTP(63).EQ.1) THEN
14339 Q2TIM=DMSMA
14340 ELSEIF(MSTP(63).EQ.2) THEN
14341 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14342 ELSE
14343 Q2TIM=DMSMA
14344 MSTJ(48)=1
14345 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14346 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14347 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14348 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14349 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14350 ENDIF
14351C...Only do timelike shower here if using PYSHOW
14352 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14353 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14354 ENDIF
14355 MSTJ(48)=MSTJ48
14356 PARJ(85)=PARJ85
14357 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14358 ENDIF
14359
14360C...Reconstruct kinematics of branching: timelike parton shower.
14361 DMS=P(IT,5)**2
14362 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14363 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14364 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14365 & (4D0*DSH*DPC(3)**2)
14366 IF(DPT2.LT.0D0) GOTO 100
14367 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14368 & DSHR)/DPC(3)-DPC(3)
14369 P(IT,1)=SQRT(DPT2)
14370 P(IT,3)=DPB(1)*(-1)**(JT+1)
14371 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14372 IF(N.GE.IT+1) THEN
14373 DPB(1)=SQRT(DPB(1)**2+DPT2)
14374 DPB(2)=SQRT(DPB(1)**2+DMS)
14375 DPB(3)=P(IT+1,3)
14376 DPB(4)=SQRT(DPB(3)**2+DMS)
14377 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14378 & DPB(1))
14379 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14380 THE=PYANGL(P(IT,3),P(IT,1))
14381 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14382 ENDIF
14383
14384C...Reconstruct kinematics of branching: spacelike parton.
14385 DO 300 J=1,5
14386 K(N+1,J)=0
14387 P(N+1,J)=0D0
14388 V(N+1,J)=0D0
14389 300 CONTINUE
14390 K(N+1,1)=14
14391 K(N+1,2)=KFLB
14392 P(N+1,1)=P(IT,1)
14393 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14394 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14395 P(N+1,5)=-SQRT(DQ2(3))
14396 MCT(N+1,1)=0
14397 MCT(N+1,2)=0
14398
14399C...Define colour flow of branching.
14400 K(IS(JT),3)=N+1
14401 K(IT,3)=N+1
14402 IM1=N+1
14403 IM2=N+1
14404C...f -> f + gamma (Z, W).
14405 IF(IABS(K(IT,2)).GE.22) THEN
14406 K(IT,1)=1
14407 ID1=IS(JT)
14408 ID2=IS(JT)
14409C...f -> gamma (Z, W) + f.
14410 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14411 ID1=IT
14412 ID2=IT
14413C...gamma -> q + qbar, g + g.
14414 ELSEIF(K(N+1,2).EQ.22) THEN
14415 ID1=IS(JT)
14416 ID2=IT
14417 IM1=ID2
14418 IM2=ID1
14419C...q -> q + g.
14420 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14421 ID1=IT
14422 ID2=IS(JT)
14423C...q -> g + q.
14424 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14425 ID1=IS(JT)
14426 ID2=IT
14427C...qbar -> qbar + g.
14428 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14429 ID1=IS(JT)
14430 ID2=IT
14431C...qbar -> g + qbar.
14432 ELSEIF(K(N+1,2).LT.0) THEN
14433 ID1=IT
14434 ID2=IS(JT)
14435C...g -> g + g; g -> q + qbar.
14436 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14437 ID1=IS(JT)
14438 ID2=IT
14439 ELSE
14440 ID1=IT
14441 ID2=IS(JT)
14442 ENDIF
14443 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14444 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14445 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14446 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14447 IF(ID1.NE.ID2) THEN
14448 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14449 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14450 ENDIF
14451 N=N+1
14452 IF(K(IT,1).EQ.1) THEN
14453 K(IT,4)=0
14454 K(IT,5)=0
14455 ENDIF
14456
14457C...Boost to new CM-frame.
14458 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14459 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14460 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14461 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14462 IR=N+(JT-1)*(IS(1)-N)
14463 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14464 & 0D0,0D0,0D0)
14465
14466C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14467 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14468 NPART=NPART+1
14469 IPART(NPART)=IT
14470 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14471 ENDIF
14472
14473C...Global statistics.
14474 MINT(352)=MINT(352)+1
14475 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14476 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14477
14478 ENDIF
14479
14480C...Update kinematics variables.
14481 IS(JT)=N
14482 DQ2(JT)=Q2B
14483 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14484 DSH=DSHZ
14485
14486C...Save quantities; loop back.
14487 Q2S(JT)=Q2B
14488 DPHI(JT)=PHIBR
14489 MCESV(JT)=MCE
14490 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14491 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14492 KFLS(JT+2)=KFLS(JT)
14493 KFLS(JT)=KFLA
14494 XS(JT)=XA
14495 ZS(JT)=Z
14496 DO 310 KFL=-25,25
14497 XFS(JT,KFL)=XFA(KFL)
14498 310 CONTINUE
14499 TEVCSV(JT)=TEVCB
14500 TEVESV(JT)=TEVEB
14501 ELSE
14502 MORE(JT)=0
14503 IF(JT.EQ.1) IPU1=N
14504 IF(JT.EQ.2) IPU2=N
14505 ENDIF
14506 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14507 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14508 IF(MSTU(21).GE.1) N=NS
14509 IF(MSTU(21).GE.1) RETURN
14510 ENDIF
14511 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14512
14513C...Boost hard scattering partons to frame of shower initiators.
14514 DO 320 J=1,3
14515 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14516 320 CONTINUE
14517 K(N+2,1)=1
14518 DO 330 J=1,5
14519 P(N+2,J)=P(NS+1,J)
14520 330 CONTINUE
14521 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14522 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14523 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14524 IMIN=MINT(83)+5
14525 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14526 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14527 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14528
14529C...Store user information. Reset Lambda value.
14530 IF(MINT(31).LE.1) THEN
14531 K(IPU1,3)=MINT(83)+3
14532 K(IPU2,3)=MINT(83)+4
14533 ELSE
14534 K(IPU1,3)=MINT(83)+1
14535 K(IPU2,3)=MINT(83)+2
14536 ENDIF
14537 DO 340 JT=1,2
14538 MINT(12+JT)=KFLS(JT)
14539 VINT(140+JT)=XS(JT)
14540 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14541 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14542 340 CONTINUE
14543 PARU(112)=ALAMS
14544
14545 RETURN
14546 END
14547
14548C*********************************************************************
14549
14550C...PYPTIS
14551C...Generates pT-ordered spacelike initial-state parton showers and
14552C...trial joinings.
14553C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14554C... interaction initiators at PT2NOW.
14555C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14556C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14557C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14558C... is below PT2CUT.
14559C... (Also generate test joinings if MSTP(96)=1.)
14560C...MODE= 1: Accept stored shower branching. Update event record etc.
14561C...PT2NOW : Starting (max) PT2 scale for evolution.
14562C...PT2CUT : Lower limit for evolution.
14563C...PT2 : Result of evolution. Generated PT2 for trial emission.
14564C...IFAIL : Status return code. IFAIL=0 when all is well.
14565
14566 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14567
14568C...Double precision and integer declarations.
14569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14570 IMPLICIT INTEGER(I-N)
14571 INTEGER PYK,PYCHGE,PYCOMP
14572C...Parameter statement for maximum size of showers.
14573 PARAMETER (MAXNUR=1000)
14574C...Commonblocks.
14575 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14576 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14577 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14578 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14579 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14580 COMMON/PYINT1/MINT(400),VINT(400)
14581 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14582 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14583 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14584 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14585 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14586 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14587 COMMON/PYCTAG/NCT,MCT(4000,2)
14588 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14589 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14590 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14591C...Local variables
14592 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14593 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14594 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14595 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14596 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14597 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14598C...For check on excessive weights.
14599 CHARACTER CHWT*12
14600
14601C...Only give errors for very large weights, otherwise just warnings
14602 DATA WTEMAX /1.5D0/
14603C...Only give errors for large pT, otherwise just warnings
14604 DATA PTEMAX /5D0/
14605
14606 IFAIL=-1
14607
14608C----------------------------------------------------------------------
14609C...MODE=-1: Initialize initial state showers from scratch, i.e.
14610C...starting from the hardest interaction initiators.
14611 IF (MODE.EQ.-1) THEN
14612C...Set hard scattering SHAT.
14613 SHTNOW(1)=VINT(44)
14614C...Mass thresholds and Lambda for QCD evolution.
14615 AEM2PI=PARU(101)/PARU(2)
14616 RMB=PMAS(5,1)
14617 RMC=PMAS(4,1)
14618 ALAM4=PARP(61)
14619 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14620 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14621 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14622 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14623C...Optionally use Lambda_MC = Lambda_CMW
14624 IF (MSTP(64).EQ.3) THEN
14625 ALAM5 = ALAM5 * 1.569
14626 ALAM4 = ALAM4 * 1.618
14627 ALAM3 = ALAM3 * 1.661
14628 ENDIF
14629 RMB2=RMB**2
14630 RMC2=RMC**2
14631C...Massive quark forced creation threshold (in M**2).
14632 TMIN=1.01D0
14633C...Set upper limit for X (ensures some X left for beam remnant).
14634 XMXC=1D0-2D0*PARP(111)/VINT(1)
14635
14636 IF (MSTP(61).GE.1) THEN
14637C...Initial values: flavours, momenta, virtualities.
14638 DO 100 JS=1,2
14639 NISGEN(JS,1)=0
14640
14641C...Special kinematics check for c/b quarks (that g -> c cbar or
14642C...b bbar kinematically possible).
14643 KFLB=K(IMI(JS,1,1),2)
14644 KFLCB=IABS(KFLB)
14645 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14646C...Check PT2MAX > mQ^2
14647 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14648 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14649 & 'No Q creation possible.')
14650 MINT(51)=1
14651 RETURN
14652 ELSE
14653C...Check for physical z values (m == MQ / sqrt(s))
14654C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14655 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14656 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14657 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14658 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14659 & 'Q creation.')
14660 MINT(51)=1
14661 RETURN
14662 ENDIF
14663 ENDIF
14664 ENDIF
14665 100 CONTINUE
14666 ENDIF
14667
14668 MINT(354)=0
14669C...Zero joining array
14670 DO 110 MJ=1,240
14671 MJOIND(1,MJ)=0
14672 MJOIND(2,MJ)=0
14673 110 CONTINUE
14674
14675C----------------------------------------------------------------------
14676C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14677C...MINT(30). Store if emission PT2 scale is largest so far.
14678C...Also generate test joinings if MSTP(96)=1.
14679 ELSEIF(MODE.EQ.0) THEN
14680 IFAIL=-1
14681 MECOR=0
14682 ISUB=MINT(1)
14683 JS=MINT(30)
14684C...No shower for structureless beam
14685 IF (MINT(44+JS).EQ.1) RETURN
14686 MI=MINT(36)
14687 SHAT=VINT(44)
14688C...Absolute shower max scale = VINT(56)
14689 PT2=MIN(PT2NOW,VINT(56))
14690 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14691C...Define for which processes ME corrections have been implemented.
14692 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14693 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14694 & .142.OR.ISUB.EQ.144) MECOR=1
14695 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14696 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14697C...Calculate preweighting factor for ME-corrected processes.
14698 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14699 ENDIF
14700C...Basic info on daughter for which to find mother.
14701 KFLB=K(IMI(JS,MI,1),2)
14702 KFLBA=IABS(KFLB)
14703C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14704C...second companion.
14705 KSVCB=MAX(-1,IMI(JS,MI,2))
14706C...Treat "first" companion of a pair like an ordinary sea quark
14707C...(except that creation diagram is not allowed)
14708 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14709C...X (rescaled to [0,1])
14710 XB=XMI(JS,MI)/VINT(142+JS)
14711C...Massive quarks (use physical masses.)
14712 RMQ2=0D0
14713 MQMASS=0
14714 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14715 RMQ2=RMC2
14716 IF (KFLBA.EQ.5) RMQ2=RMB2
14717C...Special threshold treatment for non-photon beams
14718 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14719 ENDIF
14720
14721C...Flags for parton distribution calls.
14722 MINT(105)=MINT(102+JS)
14723 MINT(109)=MINT(106+JS)
14724 VINT(120)=VINT(2+JS)
14725
14726C.... ALICE
14727C.... Store side in MINT(124)
14728 MINT(124) = JS
14729C....
14730C...Calculate initial parton distribution weights.
14731 IF(XB.GE.XMXC) THEN
14732 RETURN
14733 ELSEIF(MQMASS.EQ.0) THEN
14734 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14735 ELSE
14736C...Initialize massive quark PT2 dependent pdf underestimate.
14737 PT20=PT2
14738 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14739C.!.Tentative treatment of massive valence quarks.
14740 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14741 XG0=XFB(21)
14742 TPM0=LOG(PT20/RMQ2)
14743 WPDF0=TPM0*XG0/XQ0
14744 ENDIF
14745 IF (KFLBA.LE.6) THEN
14746C...For quarks, only include respective sea, val, or cmp part.
14747 IF (KSVCB.LE.0) THEN
14748 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14749 ELSE
14750C...Find companion's companion
14751 MISEA=0
14752 120 MISEA=MISEA+1
14753 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14754 XS=XMI(JS,MISEA)
14755 XREM=VINT(142+JS)
14756 YS=XS/(XREM+XS)
14757C...Momentum fraction of the companion quark.
14758C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14759 YB=XB*(1D0-YS)
14760 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14761 ENDIF
14762 ENDIF
14763
14764C...Determine overestimated z range: switch at c and b masses.
14765 130 IF (PT2.GT.TMIN*RMB2) THEN
14766 IZRG=3
14767 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14768 B0=23D0/6D0
14769 ALAM2=ALAM5**2
14770 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14771 IZRG=2
14772 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14773 B0=25D0/6D0
14774 ALAM2=ALAM4**2
14775 ELSE
14776 IZRG=1
14777 PT2MNE=PT2CUT
14778 B0=27D0/6D0
14779 ALAM2=ALAM3**2
14780 ENDIF
14781C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14782 ALAM2=ALAM2/PARP(64)
14783C...Overestimated ZMAX:
14784 IF (MQMASS.EQ.0) THEN
14785C...Massless
14786 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14787 & /PT2MNE)-1D0)
14788 ELSE
14789C...Massive (limit for bremsstrahlung diagram > creation)
14790 FMQ=SQRT(RMQ2/SHTNOW(MI))
14791 ZMAX=1D0/(1D0+FMQ)
14792 ENDIF
14793 ZMIN=XB/XMXC
14794
14795C...If kinematically impossible then do not evolve.
14796 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14797
14798C...Reset Altarelli-Parisi and PDF weights.
14799 DO 140 KFL=-5,5
14800 WTAP(KFL)=0D0
14801 WTPDF(KFL)=0D0
14802 140 CONTINUE
14803 WTAP(21)=0D0
14804 WTPDF(21)=0D0
14805C...Zero joining weights and compute X(partner) and X(mother) values.
14806 IF (MSTP(96).NE.0) THEN
14807 NJN=0
14808 DO 150 MJ=1,MINT(31)
14809 WTAPJ(MJ)=0D0
14810 WTPDFJ(MJ)=0D0
14811 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14812 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14813 & +XMI(JS,MI))
14814 150 CONTINUE
14815 ENDIF
14816
14817C...Approximate Altarelli-Parisi weights (integrated AP dz).
14818C...q -> q, g -> q or q -> q + gamma (already set which).
14819 IF(KFLBA.LE.5) THEN
14820C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14821 IF (KSVCB.LT.0) THEN
14822 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14823 ELSE
14824 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14825 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14826 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14827 ENDIF
14828 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14829 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14830 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14831 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14832 WTAP(KFLB)=WTFF*WTAP(KFLB)
14833 WTAP(21)=WTGF*WTAP(21)
14834 WTAPE=WTFF*WTAPE
14835 ENDIF
14836 IF (KSVCB.GE.1) THEN
14837C...Kill normal creation but add joining diagrams for cmp quark.
14838 WTAP(21)=0D0
14839 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14840 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14841 & " quark here. Not handled yet, giving up!")
14842 PT2=0D0
14843 MINT(51)=1
14844 RETURN
14845 ENDIF
14846C...Check for possible joinings
14847 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14848C...Find companion's companion.
14849 MJ=0
14850 160 MJ=MJ+1
14851 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14852 IF (MJOIND(JS,MJ).EQ.0) THEN
14853 Y(MI)=YB+YS
14854 Z=YB/Y(MI)
14855 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14856 IF (WTAPJ(MJ).GT.1D-6) THEN
14857 NJN=1
14858 ELSE
14859 WTAPJ(MJ)=0D0
14860 ENDIF
14861 ENDIF
14862C...Add trial gluon joinings.
14863 DO 170 MJ=1,MINT(31)
14864 KFLC=K(IMI(JS,MJ,1),2)
14865 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14866 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14867 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14868 IF (WTAPJ(MJ).GT.1D-6) THEN
14869 NJN=NJN+1
14870 ELSE
14871 WTAPJ(MJ)=0D0
14872 ENDIF
14873 170 CONTINUE
14874 ENDIF
14875 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14876C...Kill creation diagram for val quarks and sea quarks with companions.
14877 WTAP(21)=0D0
14878 ELSEIF (MQMASS.EQ.0) THEN
14879C...Extra safety factor for massless sea quark creation.
14880 WTAP(21)=WTAP(21)*1.25D0
14881 ENDIF
14882
14883C... q -> g, g -> g.
14884 ELSEIF(KFLB.EQ.21) THEN
14885C...Here we decide later whether a quark picked up is valence or
14886C...sea, so we maintain the extra factor sqrt(z) since we deal
14887C...with the *sum* of sea and valence in this context.
14888 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14889C...new: do not allow backwards evol to pick up heavy flavour.
14890 DO 180 KFL=1,MIN(3,MSTP(58))
14891 WTAP(KFL)=WTAPQ
14892 WTAP(-KFL)=WTAPQ
14893 180 CONTINUE
14894 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14895 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14896 WTAPQ=WTFG*WTAPQ
14897 WTAP(21)=WTGG*WTAP(21)
14898 ENDIF
14899C...Check for possible joinings (companions handled separately above)
14900 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14901 & THEN
14902 DO 190 MJ=1,MINT(31)
14903 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14904 KSVCC=IMI(JS,MJ,2)
14905 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14906 IF (KSVCC.GE.1) GOTO 190
14907 KFLC=K(IMI(JS,MJ,1),2)
14908C...Only try g -> g + g once.
14909 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14910 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14911 IF (KFLC.EQ.21) THEN
14912 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14913 ELSE
14914 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14915 ENDIF
14916 IF (WTAPJ(MJ).GT.1D-6) THEN
14917 NJN=NJN+1
14918 ELSE
14919 WTAPJ(MJ)=0D0
14920 ENDIF
14921 190 CONTINUE
14922 ENDIF
14923 ENDIF
14924
14925C...Initialize massive quark evolution
14926 IF (MQMASS.NE.0) THEN
14927 RML=(RMQ2+VINT(18))/ALAM2
14928 TML=LOG(RML)
14929 TPL=LOG((PT2+VINT(18))/ALAM2)
14930 TPM=LOG((PT2+VINT(18))/RMQ2)
14931 WN=WTAP(21)*WPDF0/B0
14932 ENDIF
14933
14934
14935C...Loopback point for iteration
14936 NTRY=0
14937 NTHRES=0
14938 200 NTRY=NTRY+1
14939 IF(NTRY.GT.500) THEN
14940 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14941 MINT(51)=1
14942 RETURN
14943 ENDIF
14944
14945C... Calculate PDF weights and sum for evolution rate.
14946 WTSUM=0D0
14947 XFBO=MAX(1D-10,XFB(KFLB))
14948 DO 210 KFL=-5,5
14949 WTPDF(KFL)=XFB(KFL)/XFBO
14950 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14951 210 CONTINUE
14952C...Only add gluon mother diagram for massless KFLB.
14953 IF(MQMASS.EQ.0) THEN
14954 WTPDF(21)=XFB(21)/XFBO
14955 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14956 ENDIF
14957 WTSUM=MAX(0.0001D0,WTSUM)
14958 WTSUMS=WTSUM
14959C...Add joining diagrams where applicable.
14960 WTJOIN=0D0
14961 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14962 DO 220 MJ=1,MINT(31)
14963 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14964 WTPDFJ(MJ)=1D0/XFBO
14965C...x and x*pdf (+ sea/val) for parton C.
14966 KFLC=K(IMI(JS,MJ,1),2)
14967 KFLCA=IABS(KFLC)
14968 KSVCC=MAX(-1,IMI(JS,MJ,2))
14969 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14970 MINT(30)=JS
14971 MINT(36)=MJ
14972C.... ALICE
14973C.... Store side in MINT(124)
14974 MINT(124) = JS
14975C....
14976 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14977 MINT(36)=MI
14978 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14979 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14980 ELSEIF (KSVCC.GE.1) THEN
14981 print*, 'error! parton C is companion!'
14982 ENDIF
14983 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14984C...x and x*pdf (+ sea/val) for parton A.
14985 KFLA=21
14986 KSVCA=0
14987 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14988 KFLA=KFLB
14989 KSVCA=KSVCB
14990 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14991 KFLA=KFLC
14992 KSVCA=KSVCC
14993 ENDIF
14994 MINT(30)=JS
14995C.... ALICE
14996C.... Store side in MINT(124)
14997 MINT(124) = JS
14998C....
14999 IF (KSVCA.LE.0) THEN
15000C...Consider C the "evolved" parton if B is gluon. Val/sea
15001C...counting will then be done correctly in PYPDFU.
15002 IF (KFLBA.EQ.21) MINT(36)=MJ
15003 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15004 MINT(36)=MI
15005 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15006 ELSE
15007C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15008 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15009 ENDIF
15010 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15011 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15012 220 CONTINUE
15013 ENDIF
15014
15015C...Pick normal pT2 (in overestimated z range).
15016 230 PT2OLD=PT2
15017 WTSUM=WTSUMS
15018 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15019 KFLC=21
15020
15021C...Evolve q -> q gamma separately, pick it if larger pT.
15022 IF(KFLBA.LE.5) THEN
15023 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15024 IF(PT2QED.GT.PT2) THEN
15025 PT2=PT2QED
15026 KFLC=22
15027 KFLA=KFLB
15028 ENDIF
15029 ENDIF
15030
15031C... Evolve massive quark creation separately.
15032 MCRQQ=0
15033 IF (MQMASS.NE.0) THEN
15034 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15035 & -VINT(18)
15036C... Ensure mininimum PT2CR and force creation near threshold.
15037 IF (PT2CR.LT.TMIN*RMQ2) THEN
15038 NTHRES=NTHRES+1
15039 IF (NTHRES.GT.50) THEN
15040 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15041 & 'massive quark creation. Gave up trying.')
15042 MINT(51)=1
15043C...Special return code if failing before any evolution at all: bad event
15044 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15045 RETURN
15046 ENDIF
15047 PT2=0D0
15048 PT2CR=TMIN*RMQ2
15049 MCRQQ=2
15050 ENDIF
15051C... Select largest PT2 (brems or creation):
15052 IF (PT2CR.GT.PT2) THEN
15053 MCRQQ=MAX(MCRQQ,1)
15054 WTSUM=0D0
15055 PT2=PT2CR
15056 KFLA=21
15057 ELSE
15058 MCRQQ=0
15059 KFLA=KFLB
15060 ENDIF
15061C... Compute logarithms for this PT2
15062 TPL=LOG((PT2+VINT(18))/ALAM2)
15063 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15064 WTCRQQ=TPM/LOG(PT2/RMQ2)
15065 ENDIF
15066
15067C...Evolve joining separately
15068 MJOIN=0
15069 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15070 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15071 & -VINT(18)
15072 IF (PT2JN.GE.PT2) THEN
15073 MJOIN=1
15074 PT2=PT2JN
15075 ENDIF
15076 ENDIF
15077
15078C...Loopback if crossed c/b mass thresholds.
15079 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15080 PT2=RMB2
15081 GOTO 130
15082 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15083 PT2=RMC2
15084 GOTO 130
15085 ENDIF
15086
15087C...Speed up shower. Skip if higher-PT acceptable branching
15088C...already found somewhere else.
15089C...Also finish if below lower cutoff.
15090
15091 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15092
15093C...Select parton A flavour (massive Q handled above.)
15094 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15095 WTRAN=PYR(0)*WTSUM
15096 KFLA=-6
15097 240 KFLA=KFLA+1
15098 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15099 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15100 IF(KFLA.EQ.6) KFLA=21
15101 ELSEIF (MJOIN.EQ.1) THEN
15102C...Tentative joining accept/reject.
15103 WTRAN=PYR(0)*WTJOIN
15104 MJ=0
15105 250 MJ=MJ+1
15106 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15107 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15108 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15109 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15110 & ' Rejected.')
15111 GOTO 230
15112 ENDIF
15113C...x*pdf (+ sea/val) at new pT2 for parton B.
15114 IF (KSVCB.LE.0) THEN
15115 MINT(30)=JS
15116C.... ALICE
15117C.... Store side in MINT(124)
15118 MINT(124) = JS
15119C....
15120 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15121 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15122 ELSE
15123C...Companion distributions do not evolve.
15124 XFB(KFLB)=XFBO
15125 ENDIF
15126 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15127 KFLC=K(IMI(JS,MJ,1),2)
15128 KFLCA=IABS(KFLC)
15129 KSVCC=MAX(-1,IMI(JS,MJ,2))
15130 IF (KSVCB.GE.1) KSVCC=-1
15131C...x*pdf (+ sea/val) at new pT2 for parton C.
15132 MINT(30)=JS
15133 MINT(36)=MJ
15134C.... ALICE
15135C.... Store side in MINT(124)
15136 MINT(124) = JS
15137C....
15138 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15139 MINT(36)=MI
15140 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15141 WTVETO=WTVETO/XFJ(KFLC)
15142C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15143 KFLA=21
15144 KSVCA=0
15145 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15146 KFLA=KFLB
15147 KSVCA=KSVCB
15148 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15149 KFLA=KFLC
15150 KSVCA=KSVCC
15151 ENDIF
15152 IF (KSVCA.LE.0) THEN
15153 MINT(30)=JS
15154C.... ALICE
15155C.... Store side in MINT(124)
15156 MINT(124) = JS
15157C....
15158 IF (KFLB.EQ.21) MINT(36)=MJ
15159 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15160 MINT(36)=MI
15161 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15162 ELSE
15163 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15164 ENDIF
15165 WTVETO=WTVETO*XFJ(KFLA)
15166C...Monte Carlo veto.
15167 IF (WTVETO.LT.PYR(0)) GOTO 200
15168C...If accept, save PT2 of this joining.
15169 IF (PT2.GT.PT2MX) THEN
15170 PT2MX=PT2
15171 JSMX=2+JS
15172 MJN1MX=MJ
15173 MJN2MX=MI
15174 WTAPJ(MJ)=0D0
15175 NJN=0
15176 ENDIF
15177C...Exit and continue evolution.
15178 GOTO 390
15179 ENDIF
15180 KFLAA=IABS(KFLA)
15181
15182C...Choose z value (still in overestimated range) and corrective weight.
15183C...Unphysical z will be rejected below when Q2 has is computed.
15184 WTZ=0D0
15185
15186C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15187C...q -> q + g or q -> q + gamma (already set which).
15188 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15189 IF (KSVCB.LT.0) THEN
15190 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15191 ELSE
15192 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15193 Z=((1-ZFAC)/(1+ZFAC))**2
15194 ENDIF
15195 WTZ=0.5D0*(1D0+Z**2)
15196C...Massive weight correction.
15197 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15198C...Valence quark weight correction (extra sqrt)
15199 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15200
15201C...q -> g + q.
15202C...NB: MQ>0 not yet implemented. Forced absent above.
15203 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15204 KFLC=KFLA
15205 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15206 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15207
15208C...g -> q + qbar.
15209 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15210 KFLC=-KFLB
15211 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15212 WTZ=Z**2+(1D0-Z)**2
15213C...Massive correction
15214 IF (MQMASS.NE.0) THEN
15215 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15216C...Extra safety margin for light sea quark creation
15217 ELSEIF (KSVCB.LT.0) THEN
15218 WTZ=WTZ/1.25D0
15219 ENDIF
15220
15221C...g -> g + g.
15222 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15223 KFLC=21
15224 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15225 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15226 WTZ=(1D0-Z*(1D0-Z))**2
15227 ENDIF
15228
15229C...Derive Q2 from pT2.
15230 Q2B=PT2/(1D0-Z)
15231 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15232
15233C...Loopback if outside allowed z range for given pT2.
15234 RM2C=PYMASS(KFLC)**2
15235 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15236 IF (PT2ADJ.LT.1D-6) GOTO 230
15237
15238C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15239C...No modification for very first emission if using ME correction
15240 MSTP67 = MSTP(67)
15241 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15242 MSTP67 = 0
15243 ENDIF
15244
15245C...For 1st branching, limit phase space by s-hat with color-partner
15246 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15247 MSIDE=1
15248 IDIP=IMI(JS,MI,1)
15249C...Use anticolor tag for antiquark, or for gluon half the time
15250 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15251 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15252C...Tag
15253 MCTAG=MCT(IDIP,MSIDE)
15254C...Default is to set up phase space using the opposite incoming parton
15255 JDIP=IMI(3-JS,MI,1)
15256 NDIP=0
15257C...Alternatively, look for final-state color partner (pick first if several)
15258 DO 260 IFS=1,NPART
15259 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15260 JDIP=IPART(IFS)
15261 NDIP=NDIP+1
15262 ENDIF
15263 260 CONTINUE
15264C...Compute mass of pair
15265 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15266 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15267 IF (MSTP67.EQ.1) THEN
15268C...1 Option to completely kill radiation above s_dip * PARP(67)
15269 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15270 ELSE IF (MSTP67.EQ.2) THEN
15271C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15272C... (-> improved power showers?)
15273 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15274 ENDIF
15275
15276C...For subsequent branchings, loopback if nonordered in angle/rapidity
15277 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15278 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15279 & GOTO 230
15280 ENDIF
15281
15282C...Select phi angle of branching at random.
15283 PHI=PARU(2)*PYR(0)
15284
15285C...Matrix-element corrections for some processes.
15286 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15287 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15288 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15289 WTZ=WTZ*WTME/WTFF
15290 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15291 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15292 WTZ=WTZ*WTME/WTGF
15293 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15294 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15295 WTZ=WTZ*WTME/WTFG
15296 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15297 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15298 WTZ=WTZ*WTME/WTGG
15299 ENDIF
15300 ENDIF
15301
15302C...Parton distributions at new pT2 but old x.
15303 MINT(30)=JS
15304C.... ALICE
15305C.... Store side in MINT(124)
15306 MINT(124) = JS
15307C....
15308 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15309C...Treat val and cmp separately
15310 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15311 IF (KSVCB.GE.1)
15312 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15313 XFBN=XFN(KFLB)
15314 IF(XFBN.LT.1D-20) THEN
15315 IF(KFLA.EQ.KFLB) THEN
15316 WTAP(KFLB)=0D0
15317 GOTO 200
15318 ELSE
15319 XFBN=1D-10
15320 XFN(KFLB)=XFBN
15321 ENDIF
15322 ENDIF
15323 DO 270 KFL=-5,5
15324 XFB(KFL)=XFN(KFL)
15325 270 CONTINUE
15326 XFB(21)=XFN(21)
15327
15328C...Parton distributions at new pT2 and new x.
15329 XA=XB/Z
15330 MINT(30)=JS
15331C.... ALICE
15332C.... Store side in MINT(124)
15333 MINT(124) = JS
15334C....
15335 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15336 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15337C...q -> q + g: only consider respective sea, val, or cmp content.
15338 IF (KSVCB.LE.0) THEN
15339 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15340 ELSE
15341 YA=XA*(1D0-YS)
15342 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15343 ENDIF
15344 ENDIF
15345 XFAN=XFA(KFLA)
15346 IF(XFAN.LT.1D-20) THEN
15347 GOTO 200
15348 ENDIF
15349
15350C...If weighting fails continue evolution.
15351 WTTOT=0D0
15352 IF (MCRQQ.EQ.0) THEN
15353 WTPDFA=1D0/WTPDF(KFLA)
15354 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15355 ELSEIF(MCRQQ.EQ.1) THEN
15356 WTPDFA=TPM/WPDF0
15357 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15358 XBEST=TPM/TPM0*XQ0
15359 ELSEIF(MCRQQ.EQ.2) THEN
15360C...Force massive quark creation.
15361 WTTOT=1D0
15362 ENDIF
15363
15364C...Loop back if trial emission fails.
15365 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15366 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15367 IF(WTTOT.LT.0D0) THEN
15368 WRITE(CHWT,'(1P,E12.4)') WTTOT
15369 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15370 ELSEIF(WTTOT.GT.WTACC) THEN
15371 WRITE(CHWT,'(1P,E12.4)') WTTOT
15372 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15373C...Too high weight: write out as error, but do not update error counter
15374 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15375 CALL PYERRM(19,
15376 & '(PYPTIS:) Weight '//CHWT//' above unity')
15377 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15378 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15379 ELSE
15380 CALL PYERRM(9,
15381 & '(PYPTIS:) Weight '//CHWT//' above unity')
15382 ENDIF
15383C...Useful for debugging but commented out for distribution:
15384C print*, 'JS, MI',JS, MI
15385C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15386C print*, 'A -> B C',KFLA, KFLB, KFLC
15387C XFAO=XFBO/WTPDFA
15388C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15389 ENDIF
15390
15391C...Save acceptable branching.
15392 IF(PT2.GT.PT2MX) THEN
15393 MIMX=MINT(36)
15394 JSMX=JS
15395 PT2MX=PT2
15396 KFLAMX=KFLA
15397 KFLCMX=KFLC
15398 RM2CMX=RM2C
15399 Q2BMX=Q2B
15400 ZMX=Z
15401 PT2AMX=PT2ADJ
15402 PHIMX=PHI
15403 ENDIF
15404
15405C----------------------------------------------------------------------
15406C...MODE= 1: Accept stored shower branching. Update event record etc.
15407 ELSEIF (MODE.EQ.1) THEN
15408 MI=MIMX
15409 JS=JSMX
15410 SHAT=SHTNOW(MI)
15411 SIDE=3D0-2D0*JS
15412C...Shift down rest of event record to make room for insertion.
15413 IT=IMISEP(MI)+1
15414 IM=IT+1
15415 IS=IMI(JS,MI,1)
15416 DO 290 I=N,IT,-1
15417 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15418 KT1=K(I,4)/MSTU(5)**2
15419 KT2=K(I,5)/MSTU(5)**2
15420 ID1=MOD(K(I,4),MSTU(5))
15421 ID2=MOD(K(I,5),MSTU(5))
15422 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15423 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15424 IF (ID1.GE.IT) ID1=ID1+2
15425 IF (ID2.GE.IT) ID2=ID2+2
15426 IF (IM1.GE.IT) IM1=IM1+2
15427 IF (IM2.GE.IT) IM2=IM2+2
15428 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15429 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15430 DO 280 IX=1,5
15431 K(I+2,IX)=K(I,IX)
15432 P(I+2,IX)=P(I,IX)
15433 V(I+2,IX)=V(I,IX)
15434 280 CONTINUE
15435 MCT(I+2,1)=MCT(I,1)
15436 MCT(I+2,2)=MCT(I,2)
15437 290 CONTINUE
15438 N=N+2
15439C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15440 DO 300 JI=1,MINT(31)
15441 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15442 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15443 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15444 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15445 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15446C...Also update companion pointers to the present mother.
15447 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15448 300 CONTINUE
15449 DO 310 IFS=1,NPART
15450 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15451 310 CONTINUE
15452C...Zero entries dedicated for new timelike and mother partons.
15453 DO 330 I=IT,IT+1
15454 DO 320 J=1,5
15455 K(I,J)=0
15456 P(I,J)=0D0
15457 V(I,J)=0D0
15458 320 CONTINUE
15459 MCT(I,1)=0
15460 MCT(I,2)=0
15461 330 CONTINUE
15462
15463C...Define timelike and new mother partons. History.
15464 K(IT,1)=3
15465 K(IT,2)=KFLCMX
15466 K(IM,1)=14
15467 K(IM,2)=KFLAMX
15468 K(IS,3)=IM
15469 K(IT,3)=IM
15470C...Set mother origin = side.
15471 K(IM,3)=MINT(83)+JS+2
15472 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15473
15474C...Define colour flow of branching.
15475 IM1=IM
15476 IM2=IM
15477C...q -> q + gamma.
15478 IF(K(IT,2).EQ.22) THEN
15479 K(IT,1)=1
15480 ID1=IS
15481 ID2=IS
15482C...q -> q + g.
15483 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15484 ID1=IT
15485 ID2=IS
15486C...q -> g + q.
15487 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15488 ID1=IS
15489 ID2=IT
15490C...qbar -> qbar + g.
15491 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15492 ID1=IS
15493 ID2=IT
15494C...qbar -> g + qbar.
15495 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15496 ID1=IT
15497 ID2=IS
15498C...g -> g + g; g -> q + qbar..
15499 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15500 ID1=IS
15501 ID2=IT
15502 ELSE
15503 ID1=IT
15504 ID2=IS
15505 ENDIF
15506 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15507 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15508 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15509 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15510 IF(ID1.NE.ID2) THEN
15511 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15512 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15513 ENDIF
15514 IF(K(IT,1).EQ.1) THEN
15515 K(IT,4)=0
15516 K(IT,5)=0
15517 ENDIF
15518C...Update IMI and colour tag arrays.
15519 IMI(JS,MI,1)=IM
15520 DO 340 MC=1,2
15521 MCT(IT,MC)=0
15522 MCT(IM,MC)=0
15523 340 CONTINUE
15524 DO 350 JCS=4,5
15525 KCS=JCS
15526C...If mother flag not yet set for spacelike parton, trace it.
15527 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15528 IF(MINT(51).NE.0) RETURN
15529 350 CONTINUE
15530 DO 360 JCS=4,5
15531 KCS=JCS
15532C...If mother flag not yet set for timelike parton, trace it.
15533 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15534 IF(MINT(51).NE.0) RETURN
15535 360 CONTINUE
15536
15537C...Boost recoiling parton to compensate for Q2 scale.
15538 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15539 & (1D0+(1D0+Q2BMX/SHAT)**2)
15540 IR=IMI(3-JS,MI,1)
15541 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15542
15543C...Define system to be rotated and boosted
15544C...(not including the 2 just added partons)
15545C...(but including the docu lines for first interaction)
15546 IMIN=IMISEP(MI-1)+1
15547 IF (MI.EQ.1) IMIN=MINT(83)+5
15548 IMAX=IMISEP(MI)-2
15549
15550C...Rotate back system in phi to compensate for subsequent rotation.
15551 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15552
15553C...Define kinematics of new partons in old frame.
15554 IMAX=IMISEP(MI)
15555 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15556 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15557 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15558 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15559 P(IT,1)=P(IM,1)
15560 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15561 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15562 P(IT,5)=SQRT(RM2CMX)
15563
15564C...Update internal line, now spacelike
15565 P(IS,1)=P(IM,1)-P(IT,1)
15566 P(IS,2)=P(IM,2)-P(IT,2)
15567 P(IS,3)=P(IM,3)-P(IT,3)
15568 P(IS,4)=P(IM,4)-P(IT,4)
15569 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15570C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15571 IF (P(IS,5).LT.0D0) THEN
15572 P(IS,5)=-SQRT(ABS(P(IS,5)))
15573 ELSE
15574 P(IS,5)=SQRT(P(IS,5))
15575 ENDIF
15576
15577C...Boost entire system and rotate to new frame.
15578C...(including docu lines)
15579 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15580 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15581 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15582 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15583 MINT(51)=1
15584 IFAIL=-1
15585 RETURN
15586 ENDIF
15587 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15588 I1=IMI(1,MI,1)
15589 THETA=PYANGL(P(I1,3),P(I1,1))
15590 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15591
15592C...Global statistics.
15593 MINT(352)=MINT(352)+1
15594 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15595 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15596
15597C...Add parton with relevant pT scale for timelike shower.
15598 IF (K(IT,2).NE.22) THEN
15599 NPART=NPART+1
15600 IPART(NPART)=IT
15601 PTPART(NPART)=SQRT(PT2AMX)
15602 ENDIF
15603
15604C...Update saved variables.
15605 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15606 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15607 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15608 PT2SAV(JSMX,MIMX)=PT2MX
15609 ZSAV(JS,MIMX)=ZMX
15610
15611 KSA=IABS(K(IS,2))
15612 KMA=IABS(K(IM,2))
15613 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15614C...Gluon reconstructs to quark.
15615C...Decide whether newly created quark is valence or sea:
15616 MINT(30)=JS
15617 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15618 IF(MINT(51).NE.0) RETURN
15619 ENDIF
15620 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15621C...Quark reconstructs to gluon.
15622C...Now some guy may have lost his companion. Check.
15623 ICMP=IMI(JS,MI,2)
15624 IF (ICMP.GT.0) THEN
15625 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15626 & //' away. Cannot handle that yet. Giving up.')
15627 MINT(51)=1
15628 RETURN
15629 ELSEIF(ICMP.LT.0) THEN
15630C...A sea quark with companion still in BR was reconstructed to a gluon.
15631C...Companion should now be removed from the beam remnant.
15632C...(Momentum integral is automatically updated in next call to PYPDFU.)
15633 ICMP=-ICMP
15634 IFL=-K(IS,2)
15635 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15636 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15637 DO 370 JI=1,MINT(31)
15638 KMI=-IMI(JS,JI,2)
15639 JFL=-K(IMI(JS,JI,1),2)
15640 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15641 & ,2)+1
15642 370 CONTINUE
15643 380 CONTINUE
15644 NVC(JS,IFL)=NVC(JS,IFL)-1
15645 ENDIF
15646C...Set gluon IMI(JS,MI,2) = 0.
15647 IMI(JS,MI,2)=0
15648 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15649C...Quark reconstructing to quark. If sea with companion still in BR
15650C...then update associated x value.
15651C...(Momentum integral is automatically updated in next call to PYPDFU.)
15652 IF (IMI(JS,MI,2).LT.0) THEN
15653 ICMP=-IMI(JS,MI,2)
15654 IFL=-K(IS,2)
15655 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15656 ENDIF
15657 ENDIF
15658
15659 ENDIF
15660
15661C...If reached this point, normal exit.
15662 390 IFAIL=0
15663
15664 RETURN
15665 END
15666
15667C*********************************************************************
15668
15669C...PYMEMX
15670C...Generates maximum ME weight in some initial-state showers.
15671C...Inparameter MECOR: kind of hard scattering process
15672C...Outparameter WTFF: maximum weight for fermion -> fermion
15673C... WTGF: maximum weight for gluon/photon -> fermion
15674C... WTFG: maximum weight for fermion -> gluon/photon
15675C... WTGG: maximum weight for gluon -> gluon
15676
15677 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15678
15679C...Double precision and integer declarations.
15680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15681 IMPLICIT INTEGER(I-N)
15682 INTEGER PYK,PYCHGE,PYCOMP
15683C...Commonblocks.
15684 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15685 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15686 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15687 COMMON/PYINT1/MINT(400),VINT(400)
15688 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15689 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15690
15691C...Default maximum weight.
15692 WTFF=1D0
15693 WTGF=1D0
15694 WTFG=1D0
15695 WTGG=1D0
15696
15697C...Select maximum weight by process.
15698 IF(MECOR.EQ.1) THEN
15699 WTFF=1D0
15700 WTGF=3D0
15701 ELSEIF(MECOR.EQ.2) THEN
15702 WTFG=1D0
15703 WTGG=1D0
15704 ENDIF
15705
15706 RETURN
15707 END
15708
15709C*********************************************************************
15710
15711C...PYMEWT
15712C...Calculates actual ME weight in some initial-state showers.
15713C...Inparameter MECOR: kind of hard scattering process
15714C... IFLCB: flavour combination of branching,
15715C... 1 for fermion -> fermion,
15716C... 2 for gluon/photon -> fermion
15717C... 3 for fermion -> gluon/photon,
15718C... 4 for gluon -> gluon
15719C... Q2: Q2 value of shower branching
15720C... Z: Z value of branching
15721C...In+outparameter PHIBR: azimuthal angle of branching
15722C...Outparameter WTME: actual ME weight
15723
15724 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15725
15726C...Double precision and integer declarations.
15727 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15728 IMPLICIT INTEGER(I-N)
15729 INTEGER PYK,PYCHGE,PYCOMP
15730C...Commonblocks.
15731 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15733 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15734 COMMON/PYINT1/MINT(400),VINT(400)
15735 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15736 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15737
15738C...Default output.
15739 WTME=1D0
15740
15741C...Define kinematics of shower branching in Mandelstam variables.
15742 SQM=VINT(44)
15743 SH=SQM/Z
15744 TH=-Q2
15745 UH=Q2-SQM*(1D0-Z)/Z
15746
15747C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15748 IF(MECOR.EQ.1) THEN
15749 IF(IFLCB.EQ.1) THEN
15750 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15751 ELSEIF(IFLCB.EQ.2) THEN
15752 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15753 ENDIF
15754
15755C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15756 ELSEIF(MECOR.EQ.2) THEN
15757 IF(IFLCB.EQ.3) THEN
15758 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15759 ELSEIF(IFLCB.EQ.4) THEN
15760 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15761 ENDIF
15762
15763C...Matrix-element corrections for q + qbar -> Higgs (h0)
15764 ELSEIF(MECOR.EQ.3) THEN
15765 IF(IFLCB.EQ.2) THEN
15766 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15767 1 (SH**2+2D0*SQM*(SQM-SH))
15768 ENDIF
15769 ENDIF
15770
15771 RETURN
15772 END
15773
15774C*********************************************************************
15775
15776C...PYPTMI
15777C...Handles the generation of additional interactions in the new
15778C...multiple interactions framework.
15779C...MODE=-1 : Initalize MI from scratch.
15780C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15781C... Sudakov for PT2, abort if below PT2CUT.
15782C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15783C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15784C...PT2NOW : Starting (max) PT2 scale for evolution.
15785C...PT2CUT : Lower limit for evolution.
15786C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15787C...IFAIL : Status return code.
15788C... = 0: All is well.
15789C... < 0: Phase space exhausted, generation to be terminated.
15790C... > 0: Additional interaction vetoed, but continue evolution.
15791
15792 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15793C...Double precision and integer declarations.
15794 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15795 IMPLICIT INTEGER(I-N)
15796 INTEGER PYK,PYCHGE,PYCOMP
15797C...Parameter statement for maximum size of showers.
15798 PARAMETER (MAXNUR=1000)
15799C...Commonblocks.
15800 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15801 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15803 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15804 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15805 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15806 COMMON/PYINT1/MINT(400),VINT(400)
15807 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15808 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15809 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15810 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15811 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15812 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15813 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15814 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15815 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15816 COMMON/PYCTAG/NCT,MCT(4000,2)
15817C...Local arrays and saved variables.
15818 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15819
15820 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15821 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15822 & /PYISMX/,/PYCTAG/
15823 SAVE XT2FAC,SIGS
15824
15825 IFAIL=0
15826C...Set MI subprocess = QCD 2 -> 2.
15827 ISUB=96
15828
15829C----------------------------------------------------------------------
15830C...MODE=-1: Initialize from scratch
15831 IF (MODE.EQ.-1) THEN
15832C...Initialize PT2 array.
15833 PT2MI(1)=VINT(54)
15834C...Initialize list of incoming beams and partons from two sides.
15835 DO 110 JS=1,2
15836 DO 100 MI=1,240
15837 IMI(JS,MI,1)=0
15838 IMI(JS,MI,2)=0
15839 100 CONTINUE
15840 NMI(JS)=1
15841 IMI(JS,1,1)=MINT(84)+JS
15842 IMI(JS,1,2)=0
15843 XMI(JS,1)=VINT(40+JS)
15844C...Rescale x values to fractions of photon energy.
15845 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15846C...Hard reset: hard interaction initiators motherless by definition.
15847 K(MINT(84)+JS,3)=2+JS
15848 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15849 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15850 110 CONTINUE
15851 IMISEP(0)=MINT(84)
15852 IMISEP(1)=N
15853 IF (MOD(MSTP(81),10).GE.1) THEN
15854 IF(MSTP(82).LE.1) THEN
15855 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15856 & ,5))
15857 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15858 & VINT(317)/(VINT(318)*VINT(320))
15859 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15860 ELSE
15861 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15862 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15863 ENDIF
15864 ENDIF
15865C...Zero entries relating to scatterings beyond the first.
15866 DO 120 MI=2,240
15867 IMI(1,MI,1)=0
15868 IMI(2,MI,1)=0
15869 IMI(1,MI,2)=0
15870 IMI(2,MI,2)=0
15871 IMISEP(MI)=IMISEP(1)
15872 PT2MI(MI)=0D0
15873 XMI(1,MI)=0D0
15874 XMI(2,MI)=0D0
15875 120 CONTINUE
15876C...Initialize factors for PDF reshaping.
15877 DO 140 JS=1,2
15878 KFBEAM(JS)=MINT(10+JS)
15879 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15880 KFABM=IABS(KFBEAM(JS))
15881 KFSBM=ISIGN(1,KFBEAM(JS))
15882
15883C...Zero flavour content of incoming beam particle.
15884 KFIVAL(JS,1)=0
15885 KFIVAL(JS,2)=0
15886 KFIVAL(JS,3)=0
15887C... Flavour content of baryon.
15888 IF(KFABM.GT.1000) THEN
15889 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15890 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15891 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15892C... Flavour content of pi+-, K+-.
15893 ELSEIF(KFABM.EQ.211) THEN
15894 KFIVAL(JS,1)=KFSBM*2
15895 KFIVAL(JS,2)=-KFSBM
15896 ELSEIF(KFABM.EQ.321) THEN
15897 KFIVAL(JS,1)=-KFSBM*3
15898 KFIVAL(JS,2)=KFSBM*2
15899C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15900 ENDIF
15901
15902C...Zero initial valence and companion content.
15903 DO 130 IFL=-6,6
15904 NVC(JS,IFL)=0
15905 130 CONTINUE
15906 140 CONTINUE
15907C...Set up colour line tags starting from hard interaction initiators.
15908 NCT=0
15909C...Reset colour tag array and colour processing flags.
15910 DO 150 I=IMISEP(0)+1,N
15911 MCT(I,1)=0
15912 MCT(I,2)=0
15913 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15914 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15915 150 CONTINUE
15916C... Consider each side in turn.
15917 DO 170 JS=1,2
15918 I1=IMI(JS,1,1)
15919 I2=IMI(3-JS,1,1)
15920 DO 160 JCS=4,5
15921 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15922 & GOTO 160
15923 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15924 KCS=JCS
15925 CALL PYCTTR(I1,KCS,I2)
15926 IF(MINT(51).NE.0) RETURN
15927 160 CONTINUE
15928 170 CONTINUE
15929
15930C...Range checking for companion quark pdf large-x param.
15931 IF (MSTP(87).LT.0) THEN
15932 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15933 & ' MSTP(87)=0')
15934 MSTP(87)=0
15935 ELSEIF (MSTP(87).GT.4) THEN
15936 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15937 & ' MSTP(87)=4')
15938 MSTP(87)=4
15939 ENDIF
15940
15941C----------------------------------------------------------------------
15942C...MODE=0: Generate trial interaction. Return codes:
15943C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15944C...IFAIL = 0: Additional interaction generated at PT2.
15945C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15946 ELSEIF (MODE.EQ.0) THEN
15947C...Abolute MI max scale = VINT(62)
15948 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15949 180 IF(MSTP(82).LE.1) THEN
15950 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15951 IF(XT2.LT.VINT(149)) IFAIL=-2
15952 ELSE
15953 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15954 IFAIL=-3
15955 ELSE
15956 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15957 & LOG(PYR(0)))-VINT(149)
15958 ENDIF
15959 ENDIF
15960C...Also exit if below lower limit or if higher trial branching
15961C...already found.
15962 PT2=0.25D0*VINT(2)*XT2
15963 IF (PT2.LE.PT2CUT) IFAIL=-4
15964 IF (PT2.LE.PT2MX) IFAIL=-5
15965 IF (IFAIL.NE.0) THEN
15966 PT2=0D0
15967 RETURN
15968 ENDIF
15969 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15970 VINT(25)=4D0*PT2/VINT(2)
15971 XT2=VINT(25)
15972
15973C...Choose tau and y*. Calculate cos(theta-hat).
15974 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15975 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15976 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15977 ELSE
15978 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15979 ENDIF
15980 VINT(21)=TAU
15981C...New: require shat > 1.
15982 IF(TAU*VINT(2).LT.1D0) GOTO 180
15983 CALL PYKLIM(2)
15984 RYST=PYR(0)
15985 MYST=1
15986 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15987 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15988 CALL PYKMAP(2,MYST,PYR(0))
15989 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15990
15991C...Check that x not used up. Accept or reject kinematical variables.
15992 X1M=SQRT(TAU)*EXP(VINT(22))
15993 X2M=SQRT(TAU)*EXP(-VINT(22))
15994 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
15995 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
15996 CALL PYSIGH(NCHN,SIGS)
15997 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
15998 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
15999 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16000
16001C...Save if highest PT so far.
16002 IF (PT2.GT.PT2MX) THEN
16003 JSMX=0
16004 MIMX=MINT(31)+1
16005 PT2MX=PT2
16006 ENDIF
16007
16008C----------------------------------------------------------------------
16009C...MODE=1: Generate and save accepted scattering.
16010 ELSEIF (MODE.EQ.1) THEN
16011 PT2=PT2NOW
16012C...Reset K, P, V, and MCT vectors.
16013 DO 200 I=N+1,N+4
16014 DO 190 J=1,5
16015 K(I,J)=0
16016 P(I,J)=0D0
16017 V(I,J)=0D0
16018 190 CONTINUE
16019 MCT(I,1)=0
16020 MCT(I,2)=0
16021 200 CONTINUE
16022
16023 NTRY=0
16024C...Choose flavour of reacting partons (and subprocess).
16025 210 NTRY=NTRY+1
16026 IF (NTRY.GT.50) THEN
16027 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16028 & //'interaction. Giving up!')
16029 MINT(51)=1
16030 RETURN
16031 ENDIF
16032 RSIGS=SIGS*PYR(0)
16033 DO 220 ICHN=1,NCHN
16034 KFL1=ISIG(ICHN,1)
16035 KFL2=ISIG(ICHN,2)
16036 ICONMI=ISIG(ICHN,3)
16037 RSIGS=RSIGS-SIGH(ICHN)
16038 IF(RSIGS.LE.0D0) GOTO 230
16039 220 CONTINUE
16040
16041C...Reassign to appropriate process codes.
16042 230 ISUBMI=ICONMI/10
16043 ICONMI=MOD(ICONMI,10)
16044
16045C...Choose new quark flavour for annihilation graphs
16046 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16047 SH=VINT(21)*VINT(2)
16048 CALL PYWIDT(21,SH,WDTP,WDTE)
16049 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16050 DO 250 I=1,MDCY(21,3)
16051 KFLF=KFDP(I+MDCY(21,2)-1,1)
16052 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16053 IF(RKFL.LE.0D0) GOTO 260
16054 250 CONTINUE
16055 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16056 IF(KFLF.GE.4) GOTO 240
16057 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16058 KFLF=4
16059 ICONMI=ICONMI-2
16060 ELSEIF(ISUBMI.EQ.53) THEN
16061 KFLF=5
16062 ICONMI=ICONMI-4
16063 ENDIF
16064 ENDIF
16065
16066C...Final state flavours and colour flow: default values
16067 JS=1
16068 KFL3=KFL1
16069 KFL4=KFL2
16070 KCC=20
16071 KCS=ISIGN(1,KFL1)
16072
16073 IF(ISUBMI.EQ.11) THEN
16074C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16075 KCC=ICONMI
16076 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16077
16078 ELSEIF(ISUBMI.EQ.12) THEN
16079C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16080 KFL3=ISIGN(KFLF,KFL1)
16081 KFL4=-KFL3
16082 KCC=4
16083
16084 ELSEIF(ISUBMI.EQ.13) THEN
16085C...f + fbar -> g + g; th arbitrary
16086 KFL3=21
16087 KFL4=21
16088 KCC=ICONMI+4
16089
16090 ELSEIF(ISUBMI.EQ.28) THEN
16091C...f + g -> f + g; th = (p(f)-p(f))**2
16092 IF(KFL1.EQ.21) JS=2
16093 KCC=ICONMI+6
16094 IF(KFL1.EQ.21) KCC=KCC+2
16095 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16096 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16097
16098 ELSEIF(ISUBMI.EQ.53) THEN
16099C...g + g -> f + fbar; th arbitrary
16100 KCS=(-1)**INT(1.5D0+PYR(0))
16101 KFL3=ISIGN(KFLF,KCS)
16102 KFL4=-KFL3
16103 KCC=ICONMI+10
16104
16105 ELSEIF(ISUBMI.EQ.68) THEN
16106C...g + g -> g + g; th arbitrary
16107 KCC=ICONMI+12
16108 KCS=(-1)**INT(1.5D0+PYR(0))
16109 ENDIF
16110
16111C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16112 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16113 & .OR.IABS(KFL4).EQ.5) THEN
16114 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16115 IF (PT2.LE.1.05*RMMAX2) THEN
16116 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16117 & //' too close to threshold (2nd try).')
16118 GOTO 210
16119 ENDIF
16120 ENDIF
16121
16122C...Store flavours of scattering.
16123 MINT(13)=KFL1
16124 MINT(14)=KFL2
16125 MINT(15)=KFL1
16126 MINT(16)=KFL2
16127 MINT(21)=KFL3
16128 MINT(22)=KFL4
16129
16130C...Set flavours and mothers of scattering partons.
16131 K(N+1,1)=14
16132 K(N+2,1)=14
16133 K(N+3,1)=3
16134 K(N+4,1)=3
16135 K(N+1,2)=KFL1
16136 K(N+2,2)=KFL2
16137 K(N+3,2)=KFL3
16138 K(N+4,2)=KFL4
16139 K(N+1,3)=MINT(83)+1
16140 K(N+2,3)=MINT(83)+2
16141 K(N+3,3)=N+1
16142 K(N+4,3)=N+2
16143
16144C...Store colour connection indices.
16145 DO 270 J=1,2
16146 JC=J
16147 IF(KCS.EQ.-1) JC=3-J
16148 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16149 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16150 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16151 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16152 270 CONTINUE
16153
16154C...Store incoming and outgoing partons in their CM-frame.
16155 SHR=SQRT(VINT(21))*VINT(1)
16156 P(N+1,3)=0.5D0*SHR
16157 P(N+1,4)=0.5D0*SHR
16158 P(N+2,3)=-0.5D0*SHR
16159 P(N+2,4)=0.5D0*SHR
16160 P(N+3,5)=PYMASS(K(N+3,2))
16161 P(N+4,5)=PYMASS(K(N+4,2))
16162 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16163 IFAIL=1
16164 RETURN
16165 ENDIF
16166 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16167 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16168 P(N+4,4)=SHR-P(N+3,4)
16169 P(N+4,3)=-P(N+3,3)
16170
16171C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16172 PHI=PARU(2)*PYR(0)
16173 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16174
16175C...Global statistics.
16176 MINT(351)=MINT(351)+1
16177 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16178 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16179
16180C...Keep track of loose colour ends and information on scattering.
16181 MINT(31)=MINT(31)+1
16182 MINT(36)=MINT(31)
16183 PT2MI(MINT(36))=PT2
16184 IMISEP(MINT(31))=N+4
16185 DO 280 JS=1,2
16186 IMI(JS,MINT(31),1)=N+JS
16187 IMI(JS,MINT(31),2)=0
16188 XMI(JS,MINT(31))=VINT(40+JS)
16189 NMI(JS)=NMI(JS)+1
16190C...Update cumulative counters
16191 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16192 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16193 280 CONTINUE
16194
16195C...Add to list of final state partons
16196 IPART(NPART+1)=N+3
16197 IPART(NPART+2)=N+4
16198 PTPART(NPART+1)=SQRT(PT2)
16199 PTPART(NPART+2)=SQRT(PT2)
16200 NPART=NPART+2
16201
16202C...Initialize ISR
16203 NISGEN(1,MINT(31))=0
16204 NISGEN(2,MINT(31))=0
16205
16206C...Update ER
16207 N=N+4
16208 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16209 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16210 MINT(51)=1
16211 RETURN
16212 ENDIF
16213
16214C...Finally, assign colour tags to new partons
16215 DO 300 JS=1,2
16216 I1=IMI(JS,MINT(31),1)
16217 I2=IMI(3-JS,MINT(31),1)
16218 DO 290 JCS=4,5
16219 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16220 & GOTO 290
16221 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16222 KCS=JCS
16223 CALL PYCTTR(I1,KCS,I2)
16224 IF(MINT(51).NE.0) RETURN
16225 290 CONTINUE
16226 300 CONTINUE
16227
16228C----------------------------------------------------------------------
16229C...MODE=2: Decide whether quarks in last scattering were valence,
16230C...companion, or sea.
16231 ELSEIF (MODE.EQ.2) THEN
16232 JS=MINT(30)
16233 MI=MINT(36)
16234 PT2=PT2NOW
16235 KFSBM=ISIGN(1,MINT(10+JS))
16236 IFL=K(IMI(JS,MI,1),2)
16237 IMI(JS,MI,2)=0
16238 IF (IABS(IFL).GE.6) THEN
16239 IF (IABS(IFL).EQ.6) THEN
16240 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16241 ENDIF
16242 RETURN
16243 ENDIF
16244C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16245C...(Do not include the parton itself in the X rescaling.)
16246 X=XMI(JS,MI)
16247 XRSC=X/(VINT(142+JS)+X)
16248C...Note: XPSVC = x*pdf.
16249 MINT(30)=JS
16250C.... ALICE
16251C.... Store side in MINT(124)
16252 MINT(124) = JS
16253C....
16254 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16255 SEA=XPSVC(IFL,-1)
16256 VAL=XPSVC(IFL,0)
16257C...Ensure that pdfs are positive definite
16258 IF (SEA.LT.0D0) THEN
16259 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16260 SEA=MAX(0D0,SEA)
16261 ELSEIF (VAL.LT.0D0) THEN
16262 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16263 VAL=MAX(0D0,VAL)
16264 ENDIF
16265 CMP=0D0
16266 DO 310 IVC=1,NVC(JS,IFL)
16267 CMP=CMP+XPSVC(IFL,IVC)
16268 310 CONTINUE
16269
16270 NTRY=0
16271C...Decide (Extra factor x cancels in the dvision).
16272 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16273 IVNOW=1
16274 NTRY=NTRY+1
16275 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16276C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16277 IVNOW=0
16278 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16279 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16280 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16281 IF(KFIVAL(JS,1).EQ.0) THEN
16282 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16283 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16284 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16285 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16286 ELSE
16287C...Count down valence remaining. Do not count current scattering.
16288 DO 340 I1=1,NMI(JS)
16289 IF (I1.EQ.MINT(36)) GOTO 340
16290 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16291 & IVNOW=IVNOW-1
16292 340 CONTINUE
16293 ENDIF
16294 IF(IVNOW.EQ.0) GOTO 330
16295C...Mark valence.
16296 IMI(JS,MI,2)=0
16297C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16298 IF(KFIVAL(JS,1).EQ.0) THEN
16299 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16300 KFIVAL(JS,1)=IFL
16301 KFIVAL(JS,2)=-IFL
16302 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16303 KFIVAL(JS,1)=IFL
16304 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16305 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16306 ENDIF
16307 ENDIF
16308
16309 ELSEIF (RVCS.LE.VAL+SEA) THEN
16310C...If sea, add opposite sign companion parton. Store X and I.
16311 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16312 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16313C...Set pointer to companion
16314 IMI(JS,MI,2)=-NVC(JS,-IFL)
16315
16316 ELSE
16317C...If companion, check whether we've got any in the books
16318 IF (NVC(JS,IFL).EQ.0) THEN
16319 CMP=0D0
16320C...Only report error first time for this event
16321 IF (NTRY.EQ.1)
16322 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16323C...Try a few times
16324 IF (NTRY.LE.10) THEN
16325 GOTO 320
16326C... But if it stil fails, abort this event
16327 ELSE
16328 MINT(51)=1
16329 RETURN
16330 ENDIF
16331 ENDIF
16332C...If several possibilities, decide which one
16333 CMPSUM=VAL+SEA
16334 ISEL=0
16335 350 ISEL=ISEL+1
16336 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16337 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16338C...Find original sea (anti-)quark. Do not consider current scattering.
16339 IASSOC=0
16340 DO 360 I1=1,NMI(JS)
16341 IF (I1.EQ.MINT(36)) GOTO 360
16342 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16343 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16344 IMI(JS,MI,2)=IMI(JS,I1,1)
16345 IMI(JS,I1,2)=IMI(JS,MI,1)
16346 ENDIF
16347 360 CONTINUE
16348C...Mark companion "out-kicked".
16349 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16350 ENDIF
16351
16352 ENDIF
16353 RETURN
16354 END
16355
16356C*********************************************************************
16357
16358C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16359C...Giving the x*f pdf of a companion quark, with its partner at XS,
16360C...using an approximate gluon density like (1-X)^NPOW/X. The value
16361C...corresponds to an unrescaled range between 0 and 1-X.
16362
16363 FUNCTION PYFCMP(XC,XS,NPOW)
16364 IMPLICIT NONE
16365 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16366 INTEGER NPOW
16367
16368 PYFCMP=0D0
16369C...Parent gluon momentum fraction
16370 Y=XC+XS
16371 IF (Y.GE.1D0) RETURN
16372C...Common factor (includes factor XC, since PYFCMP=x*f)
16373 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16374C...Store normalized companion x*f distribution.
16375 IF (NPOW.LE.0) THEN
16376 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16377 ELSEIF (NPOW.EQ.1) THEN
16378 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16379 ELSEIF (NPOW.EQ.2) THEN
16380 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16381 & +3D0*XS*(1D0+XS)*LOG(XS)))
16382 ELSEIF (NPOW.EQ.3) THEN
16383 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16384 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16385 ELSEIF (NPOW.GE.4) THEN
16386 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16387 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16388 ENDIF
16389 RETURN
16390 END
16391
16392C*********************************************************************
16393
16394C...PYPCMP: Auxiliary to PYPDFU.
16395C...Giving the momentum integral of a companion quark, with its
16396C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16397C...The value corresponds to an unrescaled range between 0 and 1-XS.
16398
16399 FUNCTION PYPCMP(XS,NPOW)
16400 IMPLICIT NONE
16401 DOUBLE PRECISION XS, PYPCMP
16402 INTEGER NPOW
16403 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16404 PYPCMP=0D0
16405 ELSEIF (NPOW.LE.0) THEN
16406 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16407 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16408 ELSEIF (NPOW.EQ.1) THEN
16409 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16410 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16411 ELSEIF (NPOW.EQ.2) THEN
16412 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16413 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16414 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16415 & -3D0*XS*LOG(XS)*(1+XS)))
16416 ELSEIF (NPOW.EQ.3) THEN
16417 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16418 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16419 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16420 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16421 ELSE
16422 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16423 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16424 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16425 & -6D0*XS*LOG(XS)*(1D0+XS)))
16426 ENDIF
16427 RETURN
16428 END
16429
16430C*********************************************************************
16431
16432C...PYUPRE
16433C...Rearranges contents of the HEPEUP commonblock so that
16434C...mothers precede daughters and daughters of a decay are
16435C...listed consecutively.
16436
16437 SUBROUTINE PYUPRE
16438
16439C...Double precision and integer declarations.
16440 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16441 IMPLICIT INTEGER(I-N)
16442
16443C...User process event common block.
16444 INTEGER MAXNUP
16445 PARAMETER (MAXNUP=500)
16446 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16447 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16448 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16449 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16450 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16451 SAVE /HEPEUP/
16452
16453C...Local arrays.
16454 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16455 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16456 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16457
16458C...Check whether a rearrangement is required.
16459 NEED=0
16460 DO 100 IUP=1,NUP
16461 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16462 100 CONTINUE
16463 DO 110 IUP=2,NUP
16464 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16465 110 CONTINUE
16466
16467 IF(NEED.NE.0) THEN
16468C...Find the new order that particles should have.
16469 NEWPOS(0)=0
16470 NNEW=0
16471 INEW=-1
16472 120 INEW=INEW+1
16473 DO 130 IUP=1,NUP
16474 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16475 NNEW=NNEW+1
16476 NEWPOS(NNEW)=IUP
16477 ENDIF
16478 130 CONTINUE
16479 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16480 IF(NNEW.NE.NUP) THEN
16481 CALL PYERRM(2,
16482 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16483 RETURN
16484 ENDIF
16485
16486C...Copy old info into temporary storage.
16487 DO 150 I=1,NUP
16488 IDUPT(I)=IDUP(I)
16489 ISTUPT(I)=ISTUP(I)
16490 MOTUPT(1,I)=MOTHUP(1,I)
16491 MOTUPT(2,I)=MOTHUP(2,I)
16492 ICOUPT(1,I)=ICOLUP(1,I)
16493 ICOUPT(2,I)=ICOLUP(2,I)
16494 DO 140 J=1,5
16495 PUPT(J,I)=PUP(J,I)
16496 140 CONTINUE
16497 VTIUPT(I)=VTIMUP(I)
16498 SPIUPT(I)=SPINUP(I)
16499 150 CONTINUE
16500
16501C...Copy info back into HEPEUP in right order.
16502 DO 180 I=1,NUP
16503 IOLD=NEWPOS(I)
16504 IDUP(I)=IDUPT(IOLD)
16505 ISTUP(I)=ISTUPT(IOLD)
16506 MOTHUP(1,I)=0
16507 MOTHUP(2,I)=0
16508 DO 160 IMOT=1,I-1
16509 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16510 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16511 160 CONTINUE
16512 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16513 MOTHSW=MOTHUP(1,I)
16514 MOTHUP(1,I)=MOTHUP(2,I)
16515 MOTHUP(2,I)=MOTHSW
16516 ENDIF
16517 ICOLUP(1,I)=ICOUPT(1,IOLD)
16518 ICOLUP(2,I)=ICOUPT(2,IOLD)
16519 DO 170 J=1,5
16520 PUP(J,I)=PUPT(J,IOLD)
16521 170 CONTINUE
16522 VTIMUP(I)=VTIUPT(IOLD)
16523 SPINUP(I)=SPIUPT(IOLD)
16524 180 CONTINUE
16525 ENDIF
16526
16527c...If incoming particles are massive recalculate to put them massless.
16528 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16529 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16530 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16531 PUP(4,1)=0.5D0*PPLUS
16532 PUP(3,1)=PUP(4,1)
16533 PUP(5,1)=0D0
16534 PUP(4,2)=0.5D0*PMINUS
16535 PUP(3,2)=-PUP(4,2)
16536 PUP(5,2)=0D0
16537 ENDIF
16538
16539 RETURN
16540 END
16541
16542C*********************************************************************
16543
16544C...PYADSH
16545C...Administers the generation of successive final-state showers
16546C...in external processes.
16547
16548 SUBROUTINE PYADSH(NFIN)
16549
16550C...Double precision and integer declarations.
16551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16552 IMPLICIT INTEGER(I-N)
16553 INTEGER PYK,PYCHGE,PYCOMP
16554C...Parameter statement for maximum size of showers.
16555 PARAMETER (MAXNUR=1000)
16556C...Commonblocks.
16557 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16558 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16559 COMMON/PYCTAG/NCT,MCT(4000,2)
16560 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16561 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16562 COMMON/PYINT1/MINT(400),VINT(400)
16563 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16564C...Local array.
16565 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16566
16567C...Set primary vertex.
16568 DO 100 J=1,5
16569 V(MINT(83)+5,J)=0D0
16570 V(MINT(83)+6,J)=0D0
16571 V(MINT(84)+1,J)=0D0
16572 V(MINT(84)+2,J)=0D0
16573 100 CONTINUE
16574
16575C...Isolate systems of particles with the same mother.
16576 NSYS=0
16577 IMS=-1
16578 DO 140 I=MINT(84)+3,NFIN
16579 IM=K(I,3)
16580 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16581 IF(IM.NE.IMS) THEN
16582 NSYS=NSYS+1
16583 IBEG(NSYS)=I
16584 IMS=IM
16585 ENDIF
16586
16587C...Set production vertices.
16588 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16589 & THEN
16590 DO 110 J=1,4
16591 V(I,J)=0D0
16592 110 CONTINUE
16593 ELSE
16594 DO 120 J=1,4
16595 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16596 120 CONTINUE
16597 ENDIF
16598 IF(MSTP(125).GE.1) THEN
16599 IDOC=I-MSTP(126)+4
16600 DO 130 J=1,5
16601 V(IDOC,J)=V(I,J)
16602 130 CONTINUE
16603 ENDIF
16604 140 CONTINUE
16605
16606C...End loop over systems. Return if no showers to be performed.
16607 IBEG(NSYS+1)=NFIN+1
16608 IF(MSTP(71).LE.0) RETURN
16609
16610C...Loop through systems of particles; check that sensible size.
16611 DO 270 ISYS=1,NSYS
16612 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16613 IF(MINT(35).LE.2) THEN
16614 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16615 GOTO 270
16616 ELSEIF(NSIZ.LE.1) THEN
16617 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16618 GOTO 270
16619 ELSEIF(NSIZ.GT.80) THEN
16620 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16621 GOTO 270
16622 ENDIF
16623 ENDIF
16624
16625C...Save status codes and daughters of showering particles; reset them.
16626 DO 150 J=1,4
16627 PSUM(J)=0D0
16628 150 CONTINUE
16629 DO 170 II=1,NSIZ
16630 I=IBEG(ISYS)-1+II
16631 KSAV(II,1)=K(I,1)
16632 IF(K(I,1).GT.10) THEN
16633 K(I,1)=1
16634 IF(KSAV(II,1).EQ.14) K(I,1)=3
16635 ENDIF
16636 IF(KSAV(II,1).LE.10) THEN
16637 ELSEIF(K(I,1).EQ.1) THEN
16638 KSAV(II,4)=K(I,4)
16639 KSAV(II,5)=K(I,5)
16640 K(I,4)=0
16641 K(I,5)=0
16642 ELSE
16643 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16644 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16645 K(I,4)=K(I,4)-KSAV(II,4)
16646 K(I,5)=K(I,5)-KSAV(II,5)
16647 ENDIF
16648 DO 160 J=1,4
16649 PSUM(J)=PSUM(J)+P(I,J)
16650 160 CONTINUE
16651 170 CONTINUE
16652
16653C...Perform shower.
16654 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16655 & PSUM(3)**2))
16656 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16657 NSAV=N
16658 IF(MINT(35).LE.2) THEN
16659 IF(NSIZ.EQ.2) THEN
16660 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16661 ELSE
16662 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16663 ENDIF
16664
16665C...For external processes, first call, also ISR partons radiate.
16666C...Can use existing PYPART list, removing partons that radiate later.
16667 ELSEIF(ISYS.EQ.1) THEN
16668 NPARTN=0
16669 DO 175 II=1,NPART
16670 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16671 NPARTN=NPARTN+1
16672 IPART(NPARTN)=IPART(II)
16673 PTPART(NPARTN)=PTPART(II)
16674 ENDIF
16675 175 CONTINUE
16676 NPART=NPARTN
16677 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16678 ELSE
16679C...For subsequent calls use the systems excluded above.
16680 NPART=NSIZ
16681 NPARTD=0
16682 DO 180 II=1,NSIZ
16683 I=IBEG(ISYS)-1+II
16684 IPART(II)=I
16685 PTPART(II)=0.5D0*QMAX
16686 180 CONTINUE
16687 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16688 ENDIF
16689
16690C...Look up showered copies of original showering particles.
16691 DO 260 II=1,NSIZ
16692 I=IBEG(ISYS)-1+II
16693 IMV=I
16694C...Particles without daughters need not be studied.
16695 IF(KSAV(II,1).LE.10) GOTO 260
16696 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16697 ELSEIF(K(I,1).EQ.11) THEN
16698 190 IMV=MOD(K(IMV,4),MSTU(5))
16699 IF(K(IMV,1).EQ.11) GOTO 190
16700 ELSE
16701 KDA1=MOD(K(I,4),MSTU(5))
16702 IF(KDA1.GT.0) THEN
16703 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16704 ENDIF
16705 KDA2=MOD(K(I,5),MSTU(5))
16706 IF(KDA2.GT.0) THEN
16707 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16708 ENDIF
16709 DO 200 I3=I+1,N
16710 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16711 & THEN
16712 IMV=I3
16713 KDA1=MOD(K(I3,4),MSTU(5))
16714 IF(KDA1.GT.0) THEN
16715 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16716 ENDIF
16717 KDA2=MOD(K(I3,5),MSTU(5))
16718 IF(KDA2.GT.0) THEN
16719 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16720 ENDIF
16721 ENDIF
16722 200 CONTINUE
16723 ENDIF
16724
16725C...Restore daughter info of original partons to showered copies.
16726 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16727 IF(KSAV(II,1).LE.10) THEN
16728 ELSEIF(K(I,1).EQ.1) THEN
16729 K(IMV,4)=KSAV(II,4)
16730 K(IMV,5)=KSAV(II,5)
16731 ELSE
16732 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16733 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16734 ENDIF
16735
16736C...Reset mother info of existing daughters to showered copies.
16737 DO 210 I3=IBEG(ISYS+1),NFIN
16738 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16739 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16740 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16741 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16742 ENDIF
16743 210 CONTINUE
16744
16745C...Boost all original daughters to new frame of showered copy.
16746C...Also update their colour tags.
16747 IF(IMV.NE.I) THEN
16748 DO 220 J=1,3
16749 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16750 220 CONTINUE
16751 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16752 DO 230 J=1,3
16753 BETA(J)=FAC*BETA(J)
16754 230 CONTINUE
16755 DO 250 I3=IBEG(ISYS+1),NFIN
16756 IMO=I3
16757 240 IMO=K(IMO,3)
16758 IF(MSTP(128).LE.0) THEN
16759 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16760 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16761 & THEN
16762 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16763 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16764 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16765 ENDIF
16766 ELSE
16767 IF(IMO.EQ.IMV) THEN
16768 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16769 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16770 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16771 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16772 GOTO 240
16773 ENDIF
16774 ENDIF
16775 250 CONTINUE
16776 ENDIF
16777 260 CONTINUE
16778
16779C...End of loop over showering systems
16780 270 CONTINUE
16781
16782 RETURN
16783 END
16784
16785C*********************************************************************
16786
16787C...PYVETO
16788C...Interface to UPVETO, which allows user to veto event generation
16789C...on the parton level, after parton showers but before multiple
16790C...interactions, beam remnants and hadronization is added.
16791
16792 SUBROUTINE PYVETO(IVETO)
16793
16794C...All real arithmetic in double precision.
16795 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16796C...Three Pythia functions return integers, so need declaring.
16797 INTEGER PYK,PYCHGE,PYCOMP
16798
16799C...PYTHIA commonblocks.
16800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16801 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16802 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16803 COMMON/PYINT1/MINT(400),VINT(400)
16804 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16805C...HEPEVT commonblock.
16806 PARAMETER (NMXHEP=4000)
16807 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16808 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16809 DOUBLE PRECISION PHEP,VHEP
16810 SAVE /HEPEVT/
16811C...Local array.
16812 DIMENSION IRESO(100)
16813
16814C...Define longitudinal boost from initiator rest frame to cm frame.
16815 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16816 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16817
16818C...Presentation is different if using pT-ordered shower
16819 IF(MINT(35).EQ.3) THEN
16820 GAMMA=1D0
16821 GABEZ=0D0
16822 ENDIF
16823
16824C... Reset counters.
16825 NEVHEP=0
16826 NHEP=0
16827 NRESO=0
16828
16829C...Oth pass: identify beam and incoming partons
16830 DO 140 I=MINT(83)+1,MINT(83)+6
16831 ISTORE=0
16832 IF(K(I,2).EQ.94) THEN
16833
16834 ELSE
16835 NRESO=NRESO+1
16836 IRESO(NRESO)=I
16837 IMOTH=K(I,3)
16838 ENDIF
16839 140 CONTINUE
16840
16841C...First pass: identify final locations of resonances
16842C...and of their daughters before showering.
16843 DO 150 I=MINT(84)+3,N
16844 ISTORE=0
16845 IMOTH=0
16846
16847C...Skip shower CM frame documentation lines.
16848 IF(K(I,2).EQ.94) THEN
16849
16850C... Store a new intermediate product, when mother in documentation.
16851 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16852 & K(I,3).LE.MINT(84)) THEN
16853 ISTORE=1
16854 NHEP=NHEP+1
16855 II=NHEP
16856 NRESO=NRESO+1
16857 IRESO(NRESO)=I
16858 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16859
16860C... Store a new intermediate product, when mother in main section.
16861 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16862 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16863 ISTORE=1
16864 NHEP=NHEP+1
16865 II=NHEP
16866 NRESO=NRESO+1
16867 IRESO(NRESO)=I
16868 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16869 ENDIF
16870
16871 IF(ISTORE.EQ.1) THEN
16872C...Copy parton info, boosting momenta along z axis to cm frame.
16873 ISTHEP(II)=2
16874 IDHEP(II)=K(I,2)
16875 PHEP(1,II)=P(I,1)
16876 PHEP(2,II)=P(I,2)
16877 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16878 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16879 PHEP(5,II)=P(I,5)
16880C...Store one mother. Rest of history and vertex info zeroed.
16881 JMOHEP(1,II)=IMOTH
16882 JMOHEP(2,II)=0
16883 JDAHEP(1,II)=0
16884 JDAHEP(2,II)=0
16885 VHEP(1,II)=0D0
16886 VHEP(2,II)=0D0
16887 VHEP(3,II)=0D0
16888 VHEP(4,II)=0D0
16889 ENDIF
16890 150 CONTINUE
16891
16892C...Second pass: identify current set of "final" partons.
16893 DO 200 I=MINT(84)+3,N
16894 ISTORE=0
16895 IMOTH=0
16896
16897C...Store a final parton.
16898 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16899 ISTORE=1
16900 NHEP=NHEP+1
16901 II=NHEP
16902C..Trace it back through shower, to check if from documented particle.
16903 IHIST=I
16904 ISAVE=IHIST
16905 160 CONTINUE
16906 IF(IHIST.GT.MINT(84)) THEN
16907 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16908 DO 170 IRI=1,NRESO
16909 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16910 170 CONTINUE
16911 ISAVE=IHIST
16912 IHIST=K(IHIST,3)
16913 IF(IMOTH.EQ.0) GOTO 160
16914 IMOTH=MAX(0,IMOTH-6)
16915 ELSEIF(IHIST.LE.4) THEN
16916 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16917 ISTORE=0
16918 NHEP=NHEP-1
16919 ELSE
16920 IMOTH=0
16921 ENDIF
16922 ENDIF
16923 ENDIF
16924
16925 IF(ISTORE.EQ.1) THEN
16926C...Copy parton info, boosting momenta along z axis to cm frame.
16927 ISTHEP(II)=1
16928 IDHEP(II)=K(I,2)
16929 PHEP(1,II)=P(I,1)
16930 PHEP(2,II)=P(I,2)
16931 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16932 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16933 PHEP(5,II)=P(I,5)
16934C...Store one mother. Rest of history and vertex info zeroed.
16935 JMOHEP(1,II)=IMOTH
16936 JMOHEP(2,II)=0
16937 JDAHEP(1,II)=0
16938 JDAHEP(2,II)=0
16939 VHEP(1,II)=0D0
16940 VHEP(2,II)=0D0
16941 VHEP(3,II)=0D0
16942 VHEP(4,II)=0D0
16943 ENDIF
16944 200 CONTINUE
16945C...Call user-written routine to decide whether to keep events.
16946 CALL UPVETO(IVETO)
16947 RETURN
16948 END
16949C*********************************************************************
16950
16951C...PYRESD
16952C...Allows resonances to decay (including parton showers for hadronic
16953C...channels).
16954
16955 SUBROUTINE PYRESD(IRES)
16956
16957C...Double precision and integer declarations.
16958 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16959 IMPLICIT INTEGER(I-N)
16960 INTEGER PYK,PYCHGE,PYCOMP
16961C...Parameter statement to help give large particle numbers.
16962 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16963 &KEXCIT=4000000,KDIMEN=5000000)
16964C...Parameter statement for maximum size of showers.
16965 PARAMETER (MAXNUR=1000)
16966C...Commonblocks.
16967 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16968 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16969 COMMON/PYCTAG/NCT,MCT(4000,2)
16970 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16971 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16972 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16973 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16974 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16975 COMMON/PYINT1/MINT(400),VINT(400)
16976 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16977 COMMON/PYINT4/MWID(500),WIDS(500,5)
16978 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16979 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16980 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16981C...Local arrays and complex and character variables.
16982 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16983 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16984 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16985 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16986 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16987 COMPLEX FGK,HA(6,6),HC(6,6)
16988 REAL TIR,UIR
16989 CHARACTER CODE*9,MASS*9
16990
16991C...The F, Xi and Xj functions of Gunion and Kunszt
16992C...(Phys. Rev. D33, 665, plus errata from the authors).
16993 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
16994 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
16995 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
16996 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
16997 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
16998 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
16999 &2D0*(D34/D56+D56/D34))
17000
17001C...Some general constants.
17002 XW=PARU(102)
17003 XWV=XW
17004 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17005 XW1=1D0-XW
17006 SQMZ=PMAS(23,1)**2
17007
17008 GMMZ=PMAS(23,1)*PMAS(23,2)
17009 SQMW=PMAS(24,1)**2
17010 GMMW=PMAS(24,1)*PMAS(24,2)
17011 SH=VINT(44)
17012
17013C...Boost and rotate to rest frame of incoming partons,
17014C...to get proper amount of smearing of decay angles.
17015 IBST=0
17016 IF(IRES.EQ.0) THEN
17017 IBST=1
17018 IIN1=MINT(84)+1
17019 IIN2=MINT(84)+2
17020C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17021C...(101,102) are off shell and can have inconsistent momenta, resulting
17022C...in boosts larger than unity. However, the corresponding docu partons
17023C...(5,6) are kept on shell, and have consistent momenta that can be used
17024C...to derive this boost instead. Ultimately, should change the way the new
17025C...shower stores intermediate partons, but just using partons (5,6) for now
17026C...does define the boost and furnishes a quick and much needed solution.
17027 IF (MINT(35).EQ.3) THEN
17028 IIN1=MINT(83)+5
17029 IIN2=MINT(83)+6
17030 ENDIF
17031 ETOTIN=P(IIN1,4)+P(IIN2,4)
17032 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17033 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17034 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17035 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17036 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17037 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17038 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17039 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17040 ENDIF
17041
17042C...Reset original resonance configuration.
17043 DO 100 JT=1,8
17044 IREF(1,JT)=0
17045 100 CONTINUE
17046
17047C...Define initial one, two or three objects for subprocess.
17048 IHDEC=0
17049 IF(IRES.EQ.0) THEN
17050 ISUB=MINT(1)
17051 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17052 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17053 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17054 JTMAX=1
17055 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17056 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17057 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17058 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17059 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17060 JTMAX=2
17061 ELSEIF(ISET(ISUB).EQ.5) THEN
17062 IREF(1,1)=MINT(84)+3
17063 IREF(1,2)=MINT(84)+4
17064 IREF(1,3)=MINT(84)+5
17065 IREF(1,4)=MINT(83)+7
17066 IREF(1,5)=MINT(83)+8
17067 IREF(1,6)=MINT(83)+9
17068 JTMAX=3
17069 ENDIF
17070
17071C...Define original resonance for odd cases.
17072 ELSE
17073 ISUB=0
17074 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17075 & IHDEC=1
17076 IF(IHDEC.EQ.1) ISUB=3
17077 IREF(1,1)=IRES
17078 IREF(1,4)=K(IRES,3)
17079 IRESTM=IRES
17080 IF(IREF(1,4).GT.MINT(84)) THEN
17081 110 ITMPMO=IREF(1,4)
17082 IF(K(ITMPMO,2).EQ.94) THEN
17083 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17084 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17085 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17086 IRESTM=ITMPMO
17087C...Explicitly check that reference particle exists, otherwise stop recursion
17088 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17089 IREF(1,4)=K(ITMPMO,3)
17090 GOTO 110
17091 ENDIF
17092 ENDIF
17093 ENDIF
17094 IF(IREF(1,4).GT.MINT(84)) THEN
17095 EMATCH=1D10
17096 IREF14=IREF(1,4)
17097 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17098 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17099 & EMATCH) THEN
17100 IREF(1,4)=II
17101 EMATCH=ABS(P(II,4)-P(IREF14,4))
17102 ENDIF
17103 120 CONTINUE
17104 ENDIF
17105 JTMAX=1
17106 ENDIF
17107
17108C...Check if initial resonance has been moved (in resonance + jet).
17109 DO 140 JT=1,3
17110 IF(IREF(1,JT).GT.0) THEN
17111 IF(K(IREF(1,JT),1).GT.10) THEN
17112 KFA=IABS(K(IREF(1,JT),2))
17113 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17114 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17115 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17116 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17117 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17118 ENDIF
17119 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17120 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17121 ENDIF
17122 DO 130 I=IREF(1,JT)+1,N
17123 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17124 & I.EQ.KDA2)) THEN
17125 IREF(1,JT)=I
17126 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17127 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17128 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17129 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17130 ENDIF
17131 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17132 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17133 ENDIF
17134 ENDIF
17135 130 CONTINUE
17136 ELSE
17137 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17138 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17139 ENDIF
17140 ENDIF
17141 ENDIF
17142 140 CONTINUE
17143
17144C...Set decay vertex for initial resonances
17145 DO 160 JT=1,JTMAX
17146 DO 150 I=1,4
17147 V(IREF(1,JT),I)=0D0
17148 150 CONTINUE
17149 160 CONTINUE
17150
17151C...Loop over decay history.
17152 NP=1
17153 IP=0
17154 170 IP=IP+1
17155 NINH=0
17156 JTMAX=2
17157 IF(IREF(IP,2).EQ.0) JTMAX=1
17158 IF(IREF(IP,3).NE.0) JTMAX=3
17159 IT4=0
17160 NSAV=N
17161
17162C...Check for Higgs which appears as decay product of user-process.
17163 IF(ISUB.EQ.0) THEN
17164 IHDEC=0
17165 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17166 & .EQ.36) IHDEC=1
17167 IF(IHDEC.EQ.1) ISUB=3
17168 ENDIF
17169
17170C...Start treatment of one, two or three resonances in parallel.
17171 180 N=NSAV
17172 DO 340 JT=1,JTMAX
17173 ID=IREF(IP,JT)
17174 KDCY(JT)=0
17175 KFL1(JT)=0
17176 KFL2(JT)=0
17177 KFL3(JT)=0
17178 KEQL(JT)=0
17179 NSD(JT)=ID
17180 ITJUNC(JT)=0
17181
17182C...Check whether particle can/is allowed to decay.
17183 IF(ID.EQ.0) GOTO 330
17184 KFA=IABS(K(ID,2))
17185 KCA=PYCOMP(KFA)
17186 IF(MWID(KCA).EQ.0) GOTO 330
17187 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17188 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17189 & KFA.EQ.18) IT4=IT4+1
17190 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17191 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17192
17193C...Choose lifetime and determine decay vertex.
17194 IF(K(ID,1).EQ.5) THEN
17195 V(ID,5)=0D0
17196 ELSEIF(K(ID,1).NE.4) THEN
17197 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17198 ENDIF
17199 DO 190 J=1,4
17200 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17201 190 CONTINUE
17202
17203C...Determine whether decay allowed or not.
17204 MOUT=0
17205 IF(MSTJ(22).EQ.2) THEN
17206 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17207 ELSEIF(MSTJ(22).EQ.3) THEN
17208 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17209 ELSEIF(MSTJ(22).EQ.4) THEN
17210 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17211 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17212 ENDIF
17213 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17214 K(ID,1)=4
17215 GOTO 330
17216 ENDIF
17217
17218C...Info for selection of decay channel: sign, pairings.
17219 IF(KCHG(KCA,3).EQ.0) THEN
17220 IPM=2
17221 ELSE
17222 IPM=(5-ISIGN(1,K(ID,2)))/2
17223 ENDIF
17224 KFB=0
17225 IF(JTMAX.EQ.2) THEN
17226 KFB=IABS(K(IREF(IP,3-JT),2))
17227 ELSEIF(JTMAX.EQ.3) THEN
17228 JT2=JT+1-3*(JT/3)
17229 KFB=IABS(K(IREF(IP,JT2),2))
17230 IF(KFB.NE.KFA) THEN
17231 JT2=JT+2-3*((JT+1)/3)
17232 KFB=IABS(K(IREF(IP,JT2),2))
17233 ENDIF
17234 ENDIF
17235
17236C...Select decay channel.
17237 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17238 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17239 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17240 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17241 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17242 IF(WDTE0S.LE.0D0) GOTO 330
17243 RKFL=WDTE0S*PYR(0)
17244 IDL=0
17245 200 IDL=IDL+1
17246 IDC=IDL+MDCY(KCA,2)-1
17247 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17248 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17249 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17250
17251C...Read out flavours and colour charges of decay channel chosen.
17252 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17253 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17254 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17255 KFC1A=PYCOMP(IABS(KFL1(JT)))
17256 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17257 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17258 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17259 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17260 KFC2A=PYCOMP(IABS(KFL2(JT)))
17261 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17262 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17263 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17264 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17265 KCQ3(JT)=0
17266 IF(KFL3(JT).NE.0) THEN
17267 KFC3A=PYCOMP(IABS(KFL3(JT)))
17268 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17269 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17270 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17271 ENDIF
17272
17273C...Set/save further info on channel.
17274 KDCY(JT)=1
17275 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17276 NSD(JT)=N
17277 HGZ(JT,1)=VINT(111)
17278 HGZ(JT,2)=VINT(112)
17279 HGZ(JT,3)=VINT(114)
17280 JTZ=JT
17281
17282C...Select masses; to begin with assume resonances narrow.
17283 DO 220 I=1,3
17284 P(N+I,5)=0D0
17285 PMMN(I)=0D0
17286 IF(I.EQ.1) THEN
17287 KFLW=IABS(KFL1(JT))
17288 KCW=KFC1A
17289 ELSEIF(I.EQ.2) THEN
17290 KFLW=IABS(KFL2(JT))
17291 KCW=KFC2A
17292 ELSEIF(I.EQ.3) THEN
17293 IF(KFL3(JT).EQ.0) GOTO 220
17294 KFLW=IABS(KFL3(JT))
17295 KCW=KFC3A
17296 ENDIF
17297 P(N+I,5)=PMAS(KCW,1)
17298CMRENNA++
17299C...This prevents SUSY/t particles from becoming too light.
17300 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17301 PMMN(I)=PMAS(KCW,1)
17302 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17303 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17304 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17305 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17306 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17307 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17308 PMMN(I)=MIN(PMMN(I),PMSUM)
17309 ENDIF
17310 210 CONTINUE
17311C MRENNA--
17312 ELSEIF(KFLW.EQ.6) THEN
17313 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17314 ENDIF
17315C...UED: select a graviton mass from continuous distribution
17316C...(stored in PMAS(39,1) so no value returned)
17317 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17318 & CALL PYGRAM(1)
17319 220 CONTINUE
17320
17321C...Check which two out of three are widest.
17322 IWID1=1
17323 IWID2=2
17324 PWID1=PMAS(KFC1A,2)
17325 PWID2=PMAS(KFC2A,2)
17326 KFLW1=IABS(KFL1(JT))
17327 KFLW2=IABS(KFL2(JT))
17328 IF(KFL3(JT).NE.0) THEN
17329 PWID3=PMAS(KFC3A,2)
17330 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17331 IWID1=3
17332 PWID1=PWID3
17333 KFLW1=IABS(KFL3(JT))
17334 ELSEIF(PWID3.GT.PWID2) THEN
17335 IWID2=3
17336 PWID2=PWID3
17337 KFLW2=IABS(KFL3(JT))
17338 ENDIF
17339 ENDIF
17340
17341C...If all narrow then only check that masses consistent.
17342 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17343 & PWID2.LT.PARP(41))) THEN
17344CMRENNA++
17345C....Handle near degeneracy cases.
17346 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17347 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17348 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17349 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17350 ENDIF
17351 ENDIF
17352CMRENNA--
17353 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17354 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17355 MINT(51)=1
17356 GOTO 720
17357 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17358 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17359 MINT(51)=1
17360 GOTO 720
17361 ENDIF
17362
17363C...For three wide resonances select narrower of three
17364C...according to BW decoupled from rest.
17365 ELSE
17366 PMTOT=P(ID,5)
17367 IF(KFL3(JT).NE.0) THEN
17368 IWID3=6-IWID1-IWID2
17369 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17370 & KFLW1-KFLW2
17371 LOOP=0
17372 230 LOOP=LOOP+1
17373 P(N+IWID3,5)=PYMASS(KFLW3)
17374 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17375 PMTOT=PMTOT-P(N+IWID3,5)
17376 ENDIF
17377C...Select other two correlated within remaining phase space.
17378 IF(IP.EQ.1) THEN
17379 CKIN45=CKIN(45)
17380 CKIN47=CKIN(47)
17381 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17382 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17383 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17384 & P(N+IWID2,5))
17385 CKIN(45)=CKIN45
17386 CKIN(47)=CKIN47
17387 ELSE
17388 CKIN(49)=PMMN(IWID1)
17389 CKIN(50)=PMMN(IWID2)
17390 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17391 & P(N+IWID2,5))
17392 CKIN(49)=0D0
17393 CKIN(50)=0D0
17394 ENDIF
17395 IF(MINT(51).EQ.1) GOTO 720
17396 ENDIF
17397
17398C...Begin fill decay products, with colour flow for coloured objects.
17399 MSTU10=MSTU(10)
17400 MSTU(10)=1
17401 MSTU(19)=1
17402
17403C...Three-body decays
17404 IF(KFL3(JT).NE.0) THEN
17405 DO 250 I=N+1,N+3
17406 DO 240 J=1,5
17407 K(I,J)=0
17408 V(I,J)=0D0
17409 240 CONTINUE
17410 MCT(I,1)=0
17411 MCT(I,2)=0
17412 250 CONTINUE
17413 K(N+1,1)=1
17414 K(N+1,2)=KFL1(JT)
17415 K(N+2,1)=1
17416 K(N+2,2)=KFL2(JT)
17417 K(N+3,1)=1
17418 K(N+3,2)=KFL3(JT)
17419 IDIN=ID
17420
17421C...Generate kinematics (default is flat)
17422 CALL PYTBDY(IDIN)
17423
17424C...Set generic colour flows whenever unambiguous,
17425C...(independently of the order of the decay products)
17426C...Sum up total colour content
17427 NANT=0
17428 NTRI=0
17429 NOCT=0
17430 KCQ(0)=KCQM(JT)
17431 KCQ(1)=KCQ1(JT)
17432 KCQ(2)=KCQ2(JT)
17433 KCQ(3)=KCQ3(JT)
17434 DO 255 J=0,3
17435 IF (KCQ(J).EQ.-1) THEN
17436 NANT=NANT+1
17437 IANT(NANT)=N+J
17438 ELSEIF (KCQ(J).EQ.1) THEN
17439 NTRI=NTRI+1
17440 ITRI(NTRI)=N+J
17441 ELSEIF (KCQ(J).EQ.2) THEN
17442 NOCT=NOCT+1
17443 IOCT(NOCT)=N+J
17444 ENDIF
17445 255 CONTINUE
17446
17447C...Set color flow for generic 1 -> N processes (N arbitrary)
17448 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17449C...All singlets: do nothing
17450
17451 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17452C...Two octets, zero triplets, n singlets:
17453 IF (KCQ(0).EQ.2) THEN
17454C...8 -> 8 + n(1)
17455 K(ID,4)=K(ID,4)+IOCT(2)
17456 K(ID,5)=K(ID,5)+IOCT(2)
17457 K(IOCT(2),1)=3
17458 K(IOCT(2),4)=MSTU(5)*ID
17459 K(IOCT(2),5)=MSTU(5)*ID
17460 MCT(IOCT(2),1)=MCT(ID,1)
17461 MCT(IOCT(2),2)=MCT(ID,2)
17462 ELSE
17463C...1 -> 8 + 8 + n(1)
17464 K(IOCT(1),1)=3
17465 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17466 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17467 K(IOCT(2),1)=3
17468 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17469 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17470 NCT=NCT+1
17471 MCT(IOCT(1),1)=NCT
17472 MCT(IOCT(2),2)=NCT
17473 NCT=NCT+1
17474 MCT(IOCT(2),1)=NCT
17475 MCT(IOCT(1),2)=NCT
17476 ENDIF
17477
17478 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17479C...Two triplets, zero octets, n singlets.
17480 IF (KCQ(0).EQ.1) THEN
17481C...3 -> 3 + n(1)
17482 K(ID,4)=K(ID,4)+ITRI(2)
17483 K(ITRI(2),1)=3
17484 K(ITRI(2),4)=MSTU(5)*ID
17485 MCT(ITRI(2),1)=MCT(ID,1)
17486 ELSEIF (KCQ(0).EQ.-1) THEN
17487C...3bar -> 3bar + n(1)
17488 K(ID,5)=K(ID,5)+IANT(2)
17489 K(IANT(2),1)=3
17490 K(IANT(2),5)=MSTU(5)*ID
17491 MCT(IANT(2),2)=MCT(ID,2)
17492 ELSE
17493C...1 -> 3 + 3bar + n(1)
17494 K(ITRI(1),1)=3
17495 K(ITRI(1),4)=MSTU(5)*IANT(1)
17496 K(IANT(1),1)=3
17497 K(IANT(1),5)=MSTU(5)*ITRI(1)
17498 NCT=NCT+1
17499 MCT(ITRI(1),1)=NCT
17500 MCT(IANT(1),2)=NCT
17501 ENDIF
17502
17503 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17504C...Two triplets, one octet, n singlets.
17505 IF (KCQ(0).EQ.2) THEN
17506C...8 -> 3 + 3bar + n(1)
17507 K(ID,4)=K(ID,4)+ITRI(1)
17508 K(ID,5)=K(ID,5)+IANT(1)
17509 K(ITRI(1),1)=3
17510 K(ITRI(1),4)=MSTU(5)*ID
17511 K(IANT(1),1)=3
17512 K(IANT(1),5)=MSTU(5)*ID
17513 MCT(ITRI(1),1)=MCT(ID,1)
17514 MCT(IANT(1),2)=MCT(ID,2)
17515 ELSEIF (KCQ(0).EQ.1) THEN
17516C...3 -> 8 + 3 + n(1)
17517 K(ID,4)=K(ID,4)+IOCT(1)
17518 K(IOCT(1),1)=3
17519 K(IOCT(1),4)=MSTU(5)*ID
17520 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17521 K(ITRI(2),1)=3
17522 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17523 MCT(IOCT(1),1)=MCT(ID,1)
17524 NCT=NCT+1
17525 MCT(IOCT(1),2)=NCT
17526 MCT(ITRI(2),1)=NCT
17527 ELSEIF (KCQ(0).EQ.-1) THEN
17528C...3bar -> 8 + 3bar + n(1)
17529 K(ID,5)=K(ID,5)+IOCT(1)
17530 K(IOCT(1),1)=3
17531 K(IOCT(1),5)=MSTU(5)*ID
17532 K(IOCT(1),4)=MSTU(5)*IANT(2)
17533 K(IANT(2),1)=3
17534 K(IANT(2),5)=MSTU(5)*IOCT(1)
17535 MCT(IOCT(1),2)=MCT(ID,2)
17536 NCT=NCT+1
17537 MCT(IOCT(1),1)=NCT
17538 MCT(IANT(2),2)=NCT
17539 ELSE
17540C...1 -> 3 + 3bar + 8 + n(1)
17541 K(ITRI(1),1)=3
17542 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17543 K(IOCT(1),1)=3
17544 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17545 K(IOCT(1),4)=MSTU(5)*IANT(1)
17546 K(IANT(1),1)=3
17547 K(IANT(1),5)=MSTU(5)*IOCT(1)
17548 NCT=NCT+1
17549 MCT(ITRI(1),1)=NCT
17550 MCT(IOCT(1),2)=NCT
17551 NCT=NCT+1
17552 MCT(IOCT(1),1)=NCT
17553 MCT(IANT(1),2)=NCT
17554 ENDIF
17555CPS-- End of generic cases
17556C...(could three octets also be handled?)
17557C...(could (some of) the RPV cases be made generic as well?)
17558
17559C...Special cases (= old treatment)
17560C...Set colour flow for t -> W + b + Z.
17561 ELSEIF(KFA.EQ.6) THEN
17562 K(N+2,1)=3
17563 ISID=4
17564 IF(KCQM(JT).EQ.-1) ISID=5
17565 IDAU=N+2
17566 K(ID,ISID)=K(ID,ISID)+IDAU
17567 K(IDAU,ISID)=MSTU(5)*ID
17568
17569C...Set colour flow in three-body decays - programmed as special cases.
17570
17571 ELSEIF(KFC2A.LE.6) THEN
17572 K(N+2,1)=3
17573 K(N+3,1)=3
17574 ISID=4
17575 IF(KFL2(JT).LT.0) ISID=5
17576 K(N+2,ISID)=MSTU(5)*(N+3)
17577 K(N+3,9-ISID)=MSTU(5)*(N+2)
17578C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17579 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17580 & .AND.KFL3(JT).NE.0) THEN
17581 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17582C...3-body decays of squarks to colour singlets plus one quark
17583 IF (KQSUMA.EQ.1) THEN
17584C...Find quark
17585 IQ=0
17586 IF (KCQ1(JT).NE.0) IQ=1
17587 IF (KCQ2(JT).NE.0) IQ=2
17588 IF (KCQ3(JT).NE.0) IQ=3
17589 ISID=4
17590 IF (K(N+IQ,2).LT.0) ISID=5
17591 K(N+IQ,1)=3
17592 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17593 K(N+IQ,ISID)=MSTU(5)*ID
17594 ENDIF
17595C...PS--
17596 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17597 K(N+1,1)=3
17598 K(N+2,1)=3
17599 K(N+3,1)=3
17600 ISID=4
17601 IF(KFL2(JT).LT.0) ISID=5
17602 K(N+1,ISID)=MSTU(5)*(N+2)
17603 K(N+1,9-ISID)=MSTU(5)*(N+3)
17604 K(N+2,ISID)=MSTU(5)*(N+1)
17605 K(N+3,9-ISID)=MSTU(5)*(N+1)
17606 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17607 K(N+2,1)=3
17608 K(N+3,1)=3
17609 ISID=4
17610 IF(KFL2(JT).LT.0) ISID=5
17611 K(ID,ISID)=K(ID,ISID)+(N+2)
17612 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17613 K(N+2,ISID)=MSTU(5)*ID
17614 K(N+3,9-ISID)=MSTU(5)*ID
17615CMRENNA--
17616
17617 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17618 & IABS(KCQ2(JT)).EQ.1) THEN
17619 K(N+2,1)=3
17620 K(N+3,1)=3
17621 ISID=4
17622 IF(KFL2(JT).LT.0) ISID=5
17623 K(N+2,ISID)=MSTU(5)*(N+3)
17624 K(N+3,9-ISID)=MSTU(5)*(N+2)
17625 ENDIF
17626
17627 NSAV=N
17628
17629C...Set colour flow in three-body decays with baryon number violation.
17630C...Neutralino and chargino decays first.
17631 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17632 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17633 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17634 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17635C...Insert junction to keep track of colours.
17636 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17637 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17638 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17639C...Set special junction codes:
17640 K(N+4,1)=42
17641 K(N+4,2)=88
17642
17643C...Order decay products by invariant mass. (will be used in PYSTRF).
17644 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)-
17645 & P(N+1,3)*P(N+2,3)
17646 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)-
17647 & P(N+1,3)*P(N+3,3)
17648 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)-
17649 & P(N+2,3)*P(N+3,3)
17650 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17651 K(N+4,4)=N+3+K(N+4,4)
17652 K(N+4,5)=N+1+MSTU(5)*(N+2)
17653 ELSEIF(PM13.LT.PM23) THEN
17654 K(N+4,4)=N+2+K(N+4,4)
17655 K(N+4,5)=N+1+MSTU(5)*(N+3)
17656 ELSE
17657 K(N+4,4)=N+1+K(N+4,4)
17658 K(N+4,5)=N+2+MSTU(5)*(N+3)
17659 ENDIF
17660 DO 260 J=1,5
17661 P(N+4,J)=0D0
17662 V(N+4,J)=0D0
17663 260 CONTINUE
17664C...Connect daughters to junction.
17665 DO 270 II=N+1,N+3
17666 K(II,4)=0
17667 K(II,5)=0
17668 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17669 270 CONTINUE
17670C...Particle counter should be stepped up one extra for junction.
17671 N=N+1
17672
17673C...Gluino decays.
17674 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17675 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17676 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17677C...Insert junction to keep track of colours.
17678 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17679 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17680 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17681 K(N+4,1)=42
17682 K(N+4,2)=88
17683 DO 280 J=1,5
17684 P(N+4,J)=0D0
17685 V(N+4,J)=0D0
17686 280 CONTINUE
17687 CTMSUM=0D0
17688 DO 290 II=N+1,N+3
17689 K(II,4)=0
17690 K(II,5)=0
17691C...Start by connecting all daughters to junction.
17692 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17693C...Only consider colour topologies with off shell resonances.
17694 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17695 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17696 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17697 IF (RMGLU-RMQ1.LT.RMRES) THEN
17698C...Calculate propagators for each colour topology.
17699 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17700 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17701 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17702 ELSE
17703 CTM2(II-N)=0D0
17704 ENDIF
17705 CTMSUM=CTMSUM+CTM2(II-N)
17706 290 CONTINUE
17707 CTMSUM=PYR(0)*CTMSUM
17708C...Select colour topology J, with most off shell least likely.
17709 J=0
17710 300 J=J+1
17711 CTMSUM=CTMSUM-CTM2(J)
17712 IF (CTMSUM.GT.0D0) GOTO 300
17713C...The lucky winner gets its colour (anti-colour) directly from gluino.
17714 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17715 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17716C...The other gluino colour is connected to junction
17717 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17718 & MSTU(5)
17719 K(N+4,4)=K(N+4,4)+ID
17720C...Lastly, connect junction to remaining daughters.
17721 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17722C...Particle counter should be stepped up one extra for junction.
17723 N=N+1
17724 ENDIF
17725
17726C...Update particle counter.
17727 N=N+3
17728
17729C...2) Everything else two-body decay.
17730 ELSE
17731 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17732 MCT(N-1,1)=0
17733 MCT(N-1,2)=0
17734 MCT(N,1)=0
17735 MCT(N,2)=0
17736C...First set colour flow as if mother colour singlet.
17737 IF(KCQ1(JT).NE.0) THEN
17738 K(N-1,1)=3
17739 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17740 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17741 ENDIF
17742 IF(KCQ2(JT).NE.0) THEN
17743 K(N,1)=3
17744 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17745 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17746 ENDIF
17747C...Then redirect colour flow if mother (anti)triplet.
17748 IF(KCQM(JT).EQ.0) THEN
17749 ELSEIF(KCQM(JT).NE.2) THEN
17750 ISID=4
17751 IF(KCQM(JT).EQ.-1) ISID=5
17752 IDAU=N-1
17753 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17754 K(ID,ISID)=K(ID,ISID)+IDAU
17755 K(IDAU,ISID)=MSTU(5)*ID
17756C...Then redirect colour flow if mother octet.
17757 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17758 IDAU=N-1
17759 IF(KCQ1(JT).EQ.0) IDAU=N
17760 K(ID,4)=K(ID,4)+IDAU
17761 K(ID,5)=K(ID,5)+IDAU
17762 K(IDAU,4)=MSTU(5)*ID
17763 K(IDAU,5)=MSTU(5)*ID
17764 ELSE
17765 ISID=4
17766 IF(KCQ1(JT).EQ.-1) ISID=5
17767 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17768 K(ID,ISID)=K(ID,ISID)+(N-1)
17769 K(ID,9-ISID)=K(ID,9-ISID)+N
17770 K(N-1,ISID)=MSTU(5)*ID
17771 K(N,9-ISID)=MSTU(5)*ID
17772 ENDIF
17773
17774C...Insert junction
17775 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17776 N=N+1
17777C...~q* mother: type 3 junction. ~q mother: type 4.
17778 ITJUNC(JT)=(7+KCQM(JT))/2
17779C...Specify junction KF and set colour flow from junction
17780 K(N,1)=42
17781 K(N,2)=88
17782 K(N,3)=ID
17783C...Junction type encoded together with mother:
17784 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17785 K(N,5)=N-1+MSTU(5)*(N-2)
17786C...Zero P and V for junction (V filled later)
17787 DO 310 J=1,5
17788 P(N,J)=0D0
17789 V(N,J)=0D0
17790 310 CONTINUE
17791C...Set colour flow from mother to junction
17792 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17793C...Set colour flow from daughters to junction
17794 DO 320 II=N-2,N-1
17795 K(II,4) = 0
17796 K(II,5) = 0
17797C...(Anti-)colour mother is junction.
17798 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17799 320 CONTINUE
17800 ENDIF
17801 ENDIF
17802
17803C...End loop over resonances for daughter flavour and mass selection.
17804 MSTU(10)=MSTU10
17805 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17806 & NINH=NINH+1
17807 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17808 & KFL1(JT).EQ.0) THEN
17809 WRITE(CODE,'(I9)') K(ID,2)
17810 WRITE(MASS,'(F9.3)') P(ID,5)
17811 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17812 & CODE//' with mass'//MASS)
17813 MINT(51)=1
17814 GOTO 720
17815 ENDIF
17816 340 CONTINUE
17817
17818C...Check for allowed combinations. Skip if no decays.
17819 IF(JTMAX.EQ.1) THEN
17820 IF(KDCY(1).EQ.0) GOTO 710
17821 ELSEIF(JTMAX.EQ.2) THEN
17822 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17823 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17824 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17825 ELSEIF(JTMAX.EQ.3) THEN
17826 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17827 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17828 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17829 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17830 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17831 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17832 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17833 ENDIF
17834
17835C...Special case: matrix element option for Z0 decay to quarks.
17836 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17837 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17838
17839C...Check consistency of MSTJ options set.
17840 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17841 CALL PYERRM(6,
17842 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17843 MSTJ(110)=1
17844 ENDIF
17845 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17846 CALL PYERRM(6,
17847 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17848
17849 MSTJ(111)=0
17850 ENDIF
17851
17852C...Select alpha_strong behaviour.
17853 MST111=MSTU(111)
17854 PAR112=PARU(112)
17855 MSTU(111)=MSTJ(108)
17856 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17857 & MSTU(111)=1
17858 PARU(112)=PARJ(121)
17859 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17860
17861C...Find axial fraction in total cross section for scalar gluon model.
17862 PARJ(171)=0D0
17863 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17864 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17865 POLL=1D0-PARJ(131)*PARJ(132)
17866 SFF=1D0/(16D0*XW*XW1)
17867 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17868 & (PARJ(123)*PARJ(124))**2)
17869 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17870 VE=4D0*XW-1D0
17871 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17872 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17873 & (PARJ(132)-PARJ(131)))
17874 KFLC=IABS(KFL1(1))
17875 PMQ=PYMASS(KFLC)
17876 QF=KCHG(KFLC,1)/3D0
17877 VQ=1D0
17878 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17879 & 1D0-(2D0*PMQ/P(ID,5))**2))
17880 VF=SIGN(1D0,QF)-4D0*QF*XW
17881 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17882 & VF**2*HF1W)+VQ**3*HF1W
17883 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17884 ENDIF
17885
17886C...Choice of jet configuration.
17887 CALL PYXJET(P(ID,5),NJET,CUT)
17888 KFLC=IABS(KFL1(1))
17889 KFLN=21
17890 IF(NJET.EQ.4) THEN
17891 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17892 ELSEIF(NJET.EQ.3) THEN
17893 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17894 ELSE
17895 MSTJ(120)=1
17896 ENDIF
17897
17898C...Fill jet configuration; return if incorrect kinematics.
17899 NC=N-2
17900 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17901 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17902 ELSEIF(NJET.EQ.2) THEN
17903 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17904 ELSEIF(NJET.EQ.3) THEN
17905 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17906 ELSEIF(KFLN.EQ.21) THEN
17907 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17908 & X12,X14)
17909 ELSE
17910 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17911 & X12,X14)
17912 ENDIF
17913 IF(MSTU(24).NE.0) THEN
17914 MINT(51)=1
17915 MSTU(111)=MST111
17916 PARU(112)=PAR112
17917 GOTO 720
17918 ENDIF
17919
17920C...Angular orientation according to matrix element.
17921 IF(MSTJ(106).EQ.1) THEN
17922 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17923 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17924 CTHE(1)=COS(THEZ)
17925 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17926 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17927 ENDIF
17928
17929C...Boost partons to Z0 rest frame.
17930 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17931 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17932
17933C...Mark decayed resonance and add documentation lines,
17934 K(ID,1)=K(ID,1)+10
17935 IDOC=MINT(83)+MINT(4)
17936 DO 360 I=NC+1,N
17937 I1=MINT(83)+MINT(4)+1
17938 K(I,3)=I1
17939 IF(MSTP(128).GE.1) K(I,3)=ID
17940 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17941 MINT(4)=MINT(4)+1
17942 K(I1,1)=21
17943 K(I1,2)=K(I,2)
17944 K(I1,3)=IREF(IP,4)
17945 DO 350 J=1,5
17946 P(I1,J)=P(I,J)
17947 350 CONTINUE
17948 ENDIF
17949 360 CONTINUE
17950
17951C...Generate parton shower.
17952 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17953 CALL PYSHOW(N-1,N,P(ID,5))
17954 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17955 NPART=2
17956 IPART(1)=N-1
17957 IPART(2)=N
17958 PTPART(1)=0.5D0*P(ID,5)
17959 PTPART(2)=PTPART(1)
17960 NCT=NCT+1
17961 IF(K(N-1,2).GT.0) THEN
17962 MCT(N-1,1)=NCT
17963 MCT(N,2)=NCT
17964 ELSE
17965 MCT(N-1,2)=NCT
17966 MCT(N,1)=NCT
17967 ENDIF
17968 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17969 ENDIF
17970
17971C... End special case for Z0: skip ahead.
17972 MSTU(111)=MST111
17973 PARU(112)=PAR112
17974 GOTO 700
17975 ENDIF
17976
17977C...Order incoming partons and outgoing resonances.
17978 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17979 &NINH.EQ.0) THEN
17980 ILIN(1)=MINT(84)+1
17981 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17982 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17983 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17984 ILIN(2)=2*MINT(84)+3-ILIN(1)
17985 IMIN=1
17986 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17987 & .EQ.36) IMIN=3
17988 IMAX=2
17989 IORD=1
17990 IF(K(IREF(IP,1),2).EQ.23) IORD=2
17991 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
17992 IAKIPD=IABS(K(IREF(IP,IORD),2))
17993 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
17994 IF(KDCY(IORD).EQ.0) IORD=3-IORD
17995
17996C...Order decay products of resonances.
17997 DO 370 JT=IORD,3-IORD,3-2*IORD
17998 IF(KDCY(JT).EQ.0) THEN
17999 ILIN(IMAX+1)=NSD(JT)
18000 IMAX=IMAX+1
18001 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18002 ILIN(IMAX+1)=N+2*JT-1
18003 ILIN(IMAX+2)=N+2*JT
18004 IMAX=IMAX+2
18005 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18006 K(N+2*JT,2)=K(NSD(JT)+2,2)
18007 ELSE
18008 ILIN(IMAX+1)=N+2*JT
18009
18010 ILIN(IMAX+2)=N+2*JT-1
18011 IMAX=IMAX+2
18012 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18013 K(N+2*JT,2)=K(NSD(JT)+2,2)
18014 ENDIF
18015 370 CONTINUE
18016
18017C...Find charge, isospin, left- and righthanded couplings.
18018 DO 390 I=IMIN,IMAX
18019 DO 380 J=1,4
18020 COUP(I,J)=0D0
18021 380 CONTINUE
18022 KFA=IABS(K(ILIN(I),2))
18023 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18024 COUP(I,1)=KCHG(KFA,1)/3D0
18025 COUP(I,2)=(-1)**MOD(KFA,2)
18026 COUP(I,4)=-2D0*COUP(I,1)*XWV
18027 COUP(I,3)=COUP(I,2)+COUP(I,4)
18028 390 CONTINUE
18029
18030C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18031 IF(ISUB.EQ.22) THEN
18032 DO 420 I=3,5,2
18033 I1=IORD
18034 IF(I.EQ.5) I1=3-IORD
18035 DO 410 J1=1,2
18036 DO 400 J2=1,2
18037 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18038 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18039 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18040 & COUP(I,J2+2)**2
18041 400 CONTINUE
18042 410 CONTINUE
18043 420 CONTINUE
18044 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18045 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18046 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18047 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18048
18049 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18050 ENDIF
18051 ENDIF
18052
18053C...Select angular orientation type - Z'/W' only.
18054 MZPWP=0
18055 IF(ISUB.EQ.141) THEN
18056 IF(PYR(0).LT.PARU(130)) MZPWP=1
18057 IF(IP.EQ.2) THEN
18058 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18059 IAKIR=IABS(K(IREF(2,2),2))
18060 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18061 IF(IAKIR.LE.20) MZPWP=2
18062 ENDIF
18063 IF(IP.GE.3) MZPWP=2
18064 ELSEIF(ISUB.EQ.142) THEN
18065 IF(PYR(0).LT.PARU(136)) MZPWP=1
18066 IF(IP.EQ.2) THEN
18067 IAKIR=IABS(K(IREF(2,2),2))
18068 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18069 IF(IAKIR.LE.20) MZPWP=2
18070 ENDIF
18071 IF(IP.GE.3) MZPWP=2
18072 ENDIF
18073
18074C...Select random angles (begin of weighting procedure).
18075 430 DO 440 JT=1,JTMAX
18076 IF(KDCY(JT).EQ.0) GOTO 440
18077 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18078 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18079 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18080 PHI(JT)=VINT(24)
18081 ELSE
18082 CTHE(JT)=2D0*PYR(0)-1D0
18083 PHI(JT)=PARU(2)*PYR(0)
18084 ENDIF
18085 440 CONTINUE
18086
18087 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18088C...Construct massless four-vectors.
18089 DO 460 I=N+1,N+4
18090 K(I,1)=1
18091 DO 450 J=1,5
18092 P(I,J)=0D0
18093 V(I,J)=0D0
18094 450 CONTINUE
18095 460 CONTINUE
18096 DO 470 JT=1,JTMAX
18097 IF(KDCY(JT).EQ.0) GOTO 470
18098 ID=IREF(IP,JT)
18099 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18100 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18101 P(N+2*JT,3)=-0.5D0*P(ID,5)
18102 P(N+2*JT,4)=0.5D0*P(ID,5)
18103 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18104 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18105 470 CONTINUE
18106
18107C...Store incoming and outgoing momenta, with random rotation to
18108C...avoid accidental zeroes in HA expressions.
18109 IF(ISUB.NE.0) THEN
18110 DO 490 I=IMIN,IMAX
18111 K(N+4+I,1)=1
18112 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18113 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18114 P(N+4+I,5)=P(ILIN(I),5)
18115 DO 480 J=1,3
18116 P(N+4+I,J)=P(ILIN(I),J)
18117 480 CONTINUE
18118 490 CONTINUE
18119 500 THERR=ACOS(2D0*PYR(0)-1D0)
18120 PHIRR=PARU(2)*PYR(0)
18121 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18122 DO 520 I=IMIN,IMAX
18123 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18124 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18125 DO 510 J=1,4
18126 PK(I,J)=P(N+4+I,J)
18127 510 CONTINUE
18128 520 CONTINUE
18129 ENDIF
18130
18131C...Calculate internal products.
18132 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18133 & ISUB.EQ.142) THEN
18134 DO 540 I1=IMIN,IMAX-1
18135 DO 530 I2=I1+1,IMAX
18136 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18137 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18138 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18139 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18140 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18141 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18142 HC(I1,I2)=CONJG(HA(I1,I2))
18143 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18144 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18145 HA(I2,I1)=-HA(I1,I2)
18146 HC(I2,I1)=-HC(I1,I2)
18147 530 CONTINUE
18148 540 CONTINUE
18149 ENDIF
18150
18151C...Calculate four-products.
18152 IF(ISUB.NE.0) THEN
18153 DO 560 I=1,2
18154 DO 550 J=1,4
18155 PK(I,J)=-PK(I,J)
18156 550 CONTINUE
18157 560 CONTINUE
18158 DO 580 I1=IMIN,IMAX-1
18159 DO 570 I2=I1+1,IMAX
18160 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18161 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18162 PKK(I2,I1)=PKK(I1,I2)
18163 570 CONTINUE
18164 580 CONTINUE
18165 ENDIF
18166 ENDIF
18167
18168 KFAGM=IABS(IREF(IP,7))
18169 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18170C...Isotropic decay selected by user.
18171 WT=1D0
18172 WTMAX=1D0
18173
18174 ELSEIF(JTMAX.EQ.3) THEN
18175C...Isotropic decay when three mother particles.
18176 WT=1D0
18177 WTMAX=1D0
18178
18179 ELSEIF(IT4.GE.1) THEN
18180C... Isotropic decay t -> b + W etc for 4th generation q and l.
18181 WT=1D0
18182 WTMAX=1D0
18183
18184 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18185 & IREF(IP,7).EQ.36) THEN
18186C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18187C...CP-odd case added by Kari Ertresvag Myklevoll.
18188C...Now also with mixed Higgs CP-states
18189 ETA=PARP(25)
18190 IF(IP.EQ.1) WTMAX=SH**2
18191 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18192 KFA=IABS(K(IREF(IP,1),2))
18193 KFT=IABS(K(IREF(IP,2),2))
18194
18195 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18196 & MSTP(25).GE.3) THEN
18197C...For mixed CP states need epsilon product.
18198 P10=PK(3,4)
18199 P20=PK(4,4)
18200 P30=PK(5,4)
18201 P40=PK(6,4)
18202 P11=PK(3,1)
18203 P21=PK(4,1)
18204 P31=PK(5,1)
18205 P41=PK(6,1)
18206 P12=PK(3,2)
18207 P22=PK(4,2)
18208 P32=PK(5,2)
18209 P42=PK(6,2)
18210 P13=PK(3,3)
18211 P23=PK(4,3)
18212 P33=PK(5,3)
18213 P43=PK(6,3)
18214 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18215 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18216 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18217 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18218 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18219 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18220 & P22*P30*P41+P13*P22*P31*P40
18221C...For mixed CP states need gauge boson masses.
18222 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18223 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18224 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18225 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18226 XMV=PMAS(KFA,1)
18227 ENDIF
18228
18229C...Z decay
18230 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18231 KFLF1A=IABS(KFL1(1))
18232 EF1=KCHG(KFLF1A,1)/3D0
18233 AF1=SIGN(1D0,EF1+0.1D0)
18234 VF1=AF1-4D0*EF1*XWV
18235 KFLF2A=IABS(KFL1(2))
18236 EF2=KCHG(KFLF2A,1)/3D0
18237 AF2=SIGN(1D0,EF2+0.1D0)
18238 VF2=AF2-4D0*EF2*XWV
18239 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18240 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18241 & THEN
18242C...CP-even decay
18243 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18244 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18245 ELSEIF(MSTP(25).LE.2) THEN
18246C...CP-odd decay
18247 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18248 & -2*PKK(3,4)*PKK(5,6)
18249 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18250 & (PKK(3,4)*PKK(5,6))
18251 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18252 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18253 ELSE
18254C...Mixed CP states.
18255 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18256 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18257 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18258 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18259 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18260 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18261 & +PKK(3,4)*PKK(5,6)
18262 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18263 & +VA12AS*PKK(3,4)*PKK(5,6)
18264 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18265 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18266 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18267 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18268 ENDIF
18269
18270C...W decay
18271 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18272 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18273 & THEN
18274C...CP-even decay
18275 WT=16D0*PKK(3,5)*PKK(4,6)
18276 ELSEIF(MSTP(25).LE.2) THEN
18277C...CP-odd decay
18278 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18279 & -2*PKK(3,4)*PKK(5,6)
18280 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18281 & (PKK(3,4)*PKK(5,6))
18282 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18283 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18284 ELSE
18285C...Mixed CP states.
18286 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18287 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18288 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18289 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18290 & +PKK(3,4)*PKK(5,6)
18291 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18292 & +PKK(3,4)*PKK(5,6)
18293 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18294 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18295 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18296 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18297 ENDIF
18298
18299C...No angular correlations in other Higgs decays.
18300 ELSE
18301 WT=WTMAX
18302 ENDIF
18303
18304 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18305 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18306 & THEN
18307C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18308 I1=IREF(IP,8)
18309 IF(MOD(KFAGM,2).EQ.0) THEN
18310 I2=N+1
18311 I3=N+2
18312 ELSE
18313 I2=N+2
18314 I3=N+1
18315 ENDIF
18316 I4=IREF(IP,2)
18317 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18318 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18319 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18320 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18321
18322 ELSEIF(ISUB.EQ.1) THEN
18323C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18324 EI=KCHG(IABS(MINT(15)),1)/3D0
18325 AI=SIGN(1D0,EI+0.1D0)
18326 VI=AI-4D0*EI*XWV
18327 EF=KCHG(IABS(KFL1(1)),1)/3D0
18328 AF=SIGN(1D0,EF+0.1D0)
18329
18330 VF=AF-4D0*EF*XWV
18331 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18332 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18333 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18334 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18335 & (VI**2+AI**2)*VINT(114)*VF**2)
18336 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18337 & 4D0*VI*AI*VINT(114)*VF*AF)
18338 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18339 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18340 WTMAX=2D0*(WT1+ABS(WT3))
18341
18342 ELSEIF(ISUB.EQ.2) THEN
18343C...Angular weight for W+/- -> 2 quarks/leptons.
18344 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18345 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18346 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18347 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18348 WTMAX=4D0
18349
18350 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18351C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18352C...-> gluon/gamma + 2 quarks/leptons.
18353 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18354 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18355 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18356 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18357 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18358 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18359 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18360 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18361 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18362 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18363 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18364 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18365 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18366 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18367 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18368 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18369
18370 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18371C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18372C...-> gluon/gamma + 2 quarks/leptons.
18373 WT=PKK(1,3)**2+PKK(2,4)**2
18374 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18375
18376 ELSEIF(ISUB.EQ.22) THEN
18377C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18378 S34=P(IREF(IP,IORD),5)**2
18379 S56=P(IREF(IP,3-IORD),5)**2
18380 TI=PKK(1,3)+PKK(1,4)+S34
18381 UI=PKK(1,5)+PKK(1,6)+S56
18382 TIR=REAL(TI)
18383 UIR=REAL(UI)
18384 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18385 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18386 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18387 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18388 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18389 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18390 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18391 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18392
18393 WT=
18394 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18395 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18396 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18397 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18398 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18399 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18400 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18401 & 1D0/UI**2))
18402
18403 ELSEIF(ISUB.EQ.23) THEN
18404C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18405 D34=P(IREF(IP,IORD),5)**2
18406 D56=P(IREF(IP,3-IORD),5)**2
18407 DT=PKK(1,3)+PKK(1,4)+D34
18408 DU=PKK(1,5)+PKK(1,6)+D56
18409 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18410 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18411 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18412 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18413
18414 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18415 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18416 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18417 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18418 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18419 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18420
18421 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18422C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18423C...(or H0, or A0).
18424 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18425 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18426 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18427 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18428 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18429
18430 ELSEIF(ISUB.EQ.25) THEN
18431C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18432 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18433 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18434 D34=P(IREF(IP,IORD),5)**2
18435 D56=P(IREF(IP,3-IORD),5)**2
18436 DT=PKK(1,3)+PKK(1,4)+D34
18437 DU=PKK(1,5)+PKK(1,6)+D56
18438 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18439 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18440 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18441 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18442 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18443 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18444 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18445 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18446 IF(MSTP(50).LE.0) THEN
18447 WT=FGK135**2+(CCWW*FGK253)**2
18448 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18449 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18450 & DJGK(DT,DU)))
18451 ELSE
18452 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18453 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18454 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18455 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18456 ENDIF
18457
18458 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18459C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18460C...(or H0, or A0).
18461 WT=PKK(1,3)*PKK(2,4)
18462 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18463
18464 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18465C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18466C...-> f + 2 quarks/leptons.
18467 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18468 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18469 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18470 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18471 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18472 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18473 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18474 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18475 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18476 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18477 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18478 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18479 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18480 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18481 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18482 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18483 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18484 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18485
18486 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18487C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18488 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18489 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18490 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18491
18492 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18493 & ISUB.EQ.77) THEN
18494C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18495 WT=16D0*PKK(3,5)*PKK(4,6)
18496 WTMAX=SH**2
18497
18498 ELSEIF(ISUB.EQ.110) THEN
18499C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18500 WT=1D0
18501 WTMAX=1D0
18502
18503 ELSEIF(ISUB.EQ.141) THEN
18504C...Special case: if only branching ratios known then isotropic decay.
18505 IF(MWID(32).EQ.2) THEN
18506 WT=1D0
18507 WTMAX=1D0
18508 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18509C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18510C...Couplings of incoming flavour.
18511 KFAI=IABS(MINT(15))
18512 EI=KCHG(KFAI,1)/3D0
18513 AI=SIGN(1D0,EI+0.1D0)
18514 VI=AI-4D0*EI*XWV
18515 KFAIC=1
18516 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18517 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18518 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18519 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18520 VPI=PARU(119+2*KFAIC)
18521 API=PARU(120+2*KFAIC)
18522 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18523 VPI=PARJ(178+2*KFAIC)
18524 API=PARJ(179+2*KFAIC)
18525 ELSE
18526 VPI=PARJ(186+2*KFAIC)
18527 API=PARJ(187+2*KFAIC)
18528 ENDIF
18529C...Couplings of final flavour.
18530 KFAF=IABS(KFL1(1))
18531 EF=KCHG(KFAF,1)/3D0
18532 AF=SIGN(1D0,EF+0.1D0)
18533 VF=AF-4D0*EF*XWV
18534 KFAFC=1
18535 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18536 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18537 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18538 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18539 VPF=PARU(119+2*KFAFC)
18540 APF=PARU(120+2*KFAFC)
18541 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18542 VPF=PARJ(178+2*KFAFC)
18543 APF=PARJ(179+2*KFAFC)
18544 ELSE
18545 VPF=PARJ(186+2*KFAFC)
18546 APF=PARJ(187+2*KFAFC)
18547 ENDIF
18548C...Asymmetry and weight.
18549 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18550 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18551 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18552 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18553 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18554 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18555 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18556 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18557 WTMAX=2D0+ABS(ASYM)
18558 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18559C...Angular weight for f + fbar -> Z' -> W+ + W-.
18560 RM1=P(NSD(1)+1,5)**2/SH
18561 RM2=P(NSD(1)+2,5)**2/SH
18562 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18563 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18564 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18565 & (RM2-RM1)**2)
18566 WT=CFLAT+CCOS2*CTHE(1)**2
18567 WTMAX=CFLAT+MAX(0D0,CCOS2)
18568 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18569 & IABS(KFL1(1)).EQ.37)) THEN
18570C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18571 WT=1D0-CTHE(1)**2
18572 WTMAX=1D0
18573 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18574C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18575 RM1=P(NSD(1)+1,5)**2/SH
18576 RM2=P(NSD(1)+2,5)**2/SH
18577 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18578 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18579 WTMAX=1D0+FLAM2/(8D0*RM1)
18580 ELSEIF(MZPWP.EQ.0) THEN
18581C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18582C...(W:s like if intermediate Z).
18583 D34=P(IREF(IP,IORD),5)**2
18584 D56=P(IREF(IP,3-IORD),5)**2
18585 DT=PKK(1,3)+PKK(1,4)+D34
18586 DU=PKK(1,5)+PKK(1,6)+D56
18587 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18588 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18589 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18590 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18591 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18592 ELSEIF(MZPWP.EQ.1) THEN
18593C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18594C...(W:s approximately longitudinal, like if intermediate H).
18595 WT=16D0*PKK(3,5)*PKK(4,6)
18596 WTMAX=SH**2
18597 ELSE
18598C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18599C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18600 WT=1D0
18601 WTMAX=1D0
18602 ENDIF
18603
18604 ELSEIF(ISUB.EQ.142) THEN
18605C...Special case: if only branching ratios known then isotropic decay.
18606 IF(MWID(34).EQ.2) THEN
18607 WT=1D0
18608 WTMAX=1D0
18609 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18610C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18611 KFAI=IABS(MINT(15))
18612 KFAIC=1
18613 IF(KFAI.GT.10) KFAIC=2
18614 VI=PARU(129+2*KFAIC)
18615 AI=PARU(130+2*KFAIC)
18616 KFAF=IABS(KFL1(1))
18617 KFAFC=1
18618 IF(KFAF.GT.10) KFAFC=2
18619 VF=PARU(129+2*KFAFC)
18620 AF=PARU(130+2*KFAFC)
18621 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18622 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18623 WTMAX=2D0+ABS(ASYM)
18624 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18625C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18626 RM1=P(NSD(1)+1,5)**2/SH
18627 RM2=P(NSD(1)+2,5)**2/SH
18628 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18629 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18630 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18631 & (RM2-RM1)**2)
18632 WT=CFLAT+CCOS2*CTHE(1)**2
18633 WTMAX=CFLAT+MAX(0D0,CCOS2)
18634 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18635C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18636 RM1=P(NSD(1)+1,5)**2/SH
18637 RM2=P(NSD(1)+2,5)**2/SH
18638 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18639 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18640 WTMAX=1D0+FLAM2/(8D0*RM1)
18641 ELSEIF(MZPWP.EQ.0) THEN
18642C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18643C...(W/Z like if intermediate W).
18644 D34=P(IREF(IP,IORD),5)**2
18645 D56=P(IREF(IP,3-IORD),5)**2
18646 DT=PKK(1,3)+PKK(1,4)+D34
18647 DU=PKK(1,5)+PKK(1,6)+D56
18648 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18649 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18650 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18651 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18652 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18653 ELSEIF(MZPWP.EQ.1) THEN
18654C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18655C...(W/Z approximately longitudinal, like if intermediate H).
18656 WT=16D0*PKK(3,5)*PKK(4,6)
18657 WTMAX=SH**2
18658 ELSE
18659C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18660C...t + bbar -> t + W + bbar.
18661 WT=1D0
18662 WTMAX=1D0
18663 ENDIF
18664
18665 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18666 & THEN
18667C...Isotropic decay of leptoquarks (assumed spin 0).
18668 WT=1D0
18669 WTMAX=1D0
18670
18671 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18672C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18673 SIDE=1D0
18674 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18675 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18676 WT=1D0+SIDE*CTHE(1)
18677 WTMAX=2D0
18678 ELSEIF(IP.EQ.1) THEN
18679
18680 RM1=P(NSD(1)+1,5)**2/SH
18681 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18682 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18683 ELSE
18684C...W/Z decay assumed isotropic, since not known.
18685 WT=1D0
18686 WTMAX=1D0
18687 ENDIF
18688
18689 ELSEIF(ISUB.EQ.149) THEN
18690C...Isotropic decay of techni-eta.
18691 WT=1D0
18692 WTMAX=1D0
18693
18694 ELSEIF(ISUB.EQ.191) THEN
18695 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18696C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18697C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18698 WT=1D0-CTHE(1)**2
18699 WTMAX=1D0
18700 ELSEIF(IP.EQ.1) THEN
18701C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18702 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18703 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18704 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18705 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18706 KFAI=IABS(MINT(15))
18707 EI=KCHG(KFAI,1)/3D0
18708 AI=SIGN(1D0,EI+0.1D0)
18709 VI=AI-4D0*EI*XWV
18710 VALI=0.5D0*(VI+AI)
18711 VARI=0.5D0*(VI-AI)
18712 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18713 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18714 KFAF=IABS(KFL1(1))
18715 EF=KCHG(KFAF,1)/3D0
18716 AF=SIGN(1D0,EF+0.1D0)
18717 VF=AF-4D0*EF*XWV
18718 VALF=0.5D0*(VF+AF)
18719 VARF=0.5D0*(VF-AF)
18720 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18721 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18722 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18723 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18724 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18725 WTMAX=4D0*MAX(ASAME,AFLIP)
18726 ELSE
18727C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18728 WT=1D0
18729 WTMAX=1D0
18730 ENDIF
18731
18732 ELSEIF(ISUB.EQ.192) THEN
18733 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18734C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18735C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18736 WT=1D0-CTHE(1)**2
18737 WTMAX=1D0
18738 ELSEIF(IP.EQ.1) THEN
18739C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18740 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18741 WT=(1D0+CTHESG)**2
18742 WTMAX=4D0
18743 ELSE
18744C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18745 WT=1D0
18746 WTMAX=1D0
18747 ENDIF
18748
18749 ELSEIF(ISUB.EQ.193) THEN
18750 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18751C...Angular weight for f + fbar -> omega_tc0 ->
18752C...gamma pi_tc0 or Z0 pi_tc0.
18753 WT=1D0+CTHE(1)**2
18754 WTMAX=2D0
18755 ELSEIF(IP.EQ.1) THEN
18756C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18757 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18758 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18759 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18760 KFAI=IABS(MINT(15))
18761 EI=KCHG(KFAI,1)/3D0
18762 AI=SIGN(1D0,EI+0.1D0)
18763 VI=AI-4D0*EI*XWV
18764 VALI=0.5D0*(VI+AI)
18765 VARI=0.5D0*(VI-AI)
18766 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18767 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18768 KFAF=IABS(KFL1(1))
18769 EF=KCHG(KFAF,1)/3D0
18770 AF=SIGN(1D0,EF+0.1D0)
18771 VF=AF-4D0*EF*XWV
18772 VALF=0.5D0*(VF+AF)
18773 VARF=0.5D0*(VF-AF)
18774 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18775 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18776 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18777 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18778 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18779 WTMAX=4D0*MAX(BSAME,BFLIP)
18780 ELSE
18781C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18782 WT=1D0
18783 WTMAX=1D0
18784 ENDIF
18785
18786 ELSEIF(ISUB.EQ.353) THEN
18787C...Angular weight for Z_R0 -> 2 quarks/leptons.
18788 EI=KCHG(IABS(MINT(15)),1)/3D0
18789 AI=SIGN(1D0,EI+0.1D0)
18790 VI=AI-4D0*EI*XWV
18791 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18792 AF=SIGN(1D0,EF+0.1D0)
18793 VF=AF-4D0*EF*XWV
18794 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18795 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18796 WT2=RMF*(VI**2+AI**2)*VF**2
18797 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18798 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18799 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18800 WTMAX=2D0*(WT1+ABS(WT3))
18801
18802 ELSEIF(ISUB.EQ.354) THEN
18803C...Angular weight for W_R+/- -> 2 quarks/leptons.
18804 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18805 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18806 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18807 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18808 WTMAX=4D0
18809
18810 ELSEIF(ISUB.EQ.391) THEN
18811C...Angular weight for f + fbar -> G* -> f + fbar
18812 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18813 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18814 WTMAX=2D0
18815C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18816C...implemented by M.-C. Lemaire
18817 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18818 & IABS(KFL1(1)).EQ.22)) THEN
18819 WT=1D0-CTHE(1)**4
18820 WTMAX=1D0
18821C...Other G* decays not yet implemented angular distributions.
18822 ELSE
18823 WT=1D0
18824 WTMAX=1D0
18825 ENDIF
18826
18827 ELSEIF(ISUB.EQ.392) THEN
18828C...Angular weight for g + g -> G* -> f + fbar
18829 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18830 WT=1D0-CTHE(1)**4
18831 WTMAX=1D0
18832C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18833C...implemented by M.-C. Lemaire
18834 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18835 & IABS(KFL1(1)).EQ.22)) THEN
18836 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18837 WTMAX=8D0
18838C...Other G* decays not yet implemented angular distributions.
18839 ELSE
18840 WT=1D0
18841 WTMAX=1D0
18842 ENDIF
18843
18844C...Obtain correct angular distribution by rejection techniques.
18845 ELSE
18846 WT=1D0
18847 WTMAX=1D0
18848 ENDIF
18849 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18850
18851C...Construct massive four-vectors using angles chosen.
18852 590 DO 690 JT=1,JTMAX
18853 IF(KDCY(JT).EQ.0) GOTO 690
18854 ID=IREF(IP,JT)
18855 DO 600 J=1,5
18856 DPMO(J)=P(ID,J)
18857 600 CONTINUE
18858 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18859CMRENNA++
18860 IF(KFL3(JT).EQ.0) THEN
18861 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18862 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18863 N0=NSD(JT)+2
18864 ELSE
18865 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18866 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18867 N0=NSD(JT)+3
18868 ENDIF
18869
18870 DO 610 J=1,4
18871 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18872 610 CONTINUE
18873C...Fill in position of decay vertex.
18874 DO 630 I=NSD(JT)+1,N0
18875 DO 620 J=1,4
18876 V(I,J)=VDCY(J)
18877 620 CONTINUE
18878 V(I,5)=0D0
18879
18880 630 CONTINUE
18881CMRENNA--
18882
18883C...Mark decayed resonances; trace history.
18884 K(ID,1)=K(ID,1)+10
18885 KFA=IABS(K(ID,2))
18886 KCA=PYCOMP(KFA)
18887 IF(KCQM(JT).NE.0) THEN
18888C...Do not kill colour flow through coloured resonance!
18889 ELSE
18890 K(ID,4)=NSD(JT)+1
18891 K(ID,5)=NSD(JT)+2
18892C...If 3-body or 2-body with junction:
18893 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18894C...If 3-body with junction:
18895 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18896 ENDIF
18897
18898C...Add documentation lines.
18899 ISUBRG=MAX(1,MIN(500,MINT(1)))
18900 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18901 IDOC=MINT(83)+MINT(4)
18902CMRENNA+++
18903 IHI=NSD(JT)+2
18904 IF(KFL3(JT).NE.0) IHI=IHI+1
18905 DO 650 I=NSD(JT)+1,IHI
18906CMRENNA---
18907 I1=MINT(83)+MINT(4)+1
18908 K(I,3)=I1
18909 IF(MSTP(128).GE.1) K(I,3)=ID
18910 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18911 MINT(4)=MINT(4)+1
18912 K(I1,1)=21
18913 K(I1,2)=K(I,2)
18914 K(I1,3)=IREF(IP,JT+3)
18915 DO 640 J=1,5
18916 P(I1,J)=P(I,J)
18917 640 CONTINUE
18918 ENDIF
18919 650 CONTINUE
18920 ELSE
18921 K(NSD(JT)+1,3)=ID
18922 K(NSD(JT)+2,3)=ID
18923C...If 3-body or 2-body with junction:
18924 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18925C...If 3-body with junction:
18926 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18927 ENDIF
18928
18929C...Do showering of two or three objects.
18930 NSHBEF=N
18931 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18932 IF(KFL3(JT).EQ.0) THEN
18933 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18934 ELSE
18935 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18936 ENDIF
18937
18938c...For pT-ordered shower need set up first, especially colour tags.
18939C...(Need to set up colour tags even if MSTP(71) = 0)
18940 ELSEIF(MINT(35).GE.2) THEN
18941 NPART=2
18942 IF(KFL3(JT).NE.0) NPART=3
18943 IPART(1)=NSD(JT)+1
18944 IPART(2)=NSD(JT)+2
18945 IPART(3)=NSD(JT)+3
18946 PTPART(1)=0.5D0*P(ID,5)
18947 PTPART(2)=PTPART(1)
18948 PTPART(3)=PTPART(1)
18949 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18950 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18951 IF(MOTHER.LE.NSD(JT)) THEN
18952 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18953 ELSE
18954 NCT=NCT+1
18955 MCT(NSD(JT)+1,1)=NCT
18956 MCT(MOTHER,2)=NCT
18957 ENDIF
18958 ENDIF
18959 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18960 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18961 IF(MOTHER.LE.NSD(JT)) THEN
18962 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18963 ELSE
18964 NCT=NCT+1
18965 MCT(NSD(JT)+1,2)=NCT
18966 MCT(MOTHER,1)=NCT
18967 ENDIF
18968 ENDIF
18969 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18970 & KCQ2(JT).EQ.2)) THEN
18971 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18972 IF(MOTHER.LE.NSD(JT)) THEN
18973 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18974 ELSE
18975 NCT=NCT+1
18976 MCT(NSD(JT)+2,1)=NCT
18977 MCT(MOTHER,2)=NCT
18978 ENDIF
18979 ENDIF
18980 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18981 & KCQ2(JT).EQ.2)) THEN
18982 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18983 IF(MOTHER.LE.NSD(JT)) THEN
18984 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18985 ELSE
18986 NCT=NCT+1
18987 MCT(NSD(JT)+2,2)=NCT
18988 MCT(MOTHER,1)=NCT
18989 ENDIF
18990 ENDIF
18991 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
18992 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
18993 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
18994 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
18995 ENDIF
18996 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
18997 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
18998 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
18999 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19000 ENDIF
19001 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19002 ENDIF
19003 NSHAFT=N
19004 IF(JT.EQ.1) NAFT1=N
19005
19006C...Check if decay products moved by shower.
19007 NSD1=NSD(JT)+1
19008 NSD2=NSD(JT)+2
19009 NSD3=NSD(JT)+3
19010 IF(NSHAFT.GT.NSHBEF) THEN
19011 IF(K(NSD1,1).GT.10) THEN
19012 DO 660 I=NSHBEF+1,NSHAFT
19013 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19014 660 CONTINUE
19015 ENDIF
19016 IF(K(NSD2,1).GT.10) THEN
19017 DO 670 I=NSHBEF+1,NSHAFT
19018 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19019 & I.NE.NSD1) NSD2=I
19020 670 CONTINUE
19021 ENDIF
19022 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19023 DO 680 I=NSHBEF+1,NSHAFT
19024 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19025 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19026 680 CONTINUE
19027 ENDIF
19028 ENDIF
19029
19030C...Store decay products for further treatment.
19031 NP=NP+1
19032 IREF(NP,1)=NSD1
19033 IREF(NP,2)=NSD2
19034 IREF(NP,3)=0
19035 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19036 IREF(NP,4)=IDOC+1
19037 IREF(NP,5)=IDOC+2
19038 IREF(NP,6)=0
19039 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19040 IREF(NP,7)=K(IREF(IP,JT),2)
19041 IREF(NP,8)=IREF(IP,JT)
19042 690 CONTINUE
19043
19044
19045C...Fill information for 2 -> 1 -> 2.
19046 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19047 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19048 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19049 MINT(25)=KFL1(1)
19050 MINT(26)=KFL2(1)
19051 VINT(23)=CTHE(1)
19052 RM3=P(N-1,5)**2/SH
19053 RM4=P(N,5)**2/SH
19054 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19055 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19056 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19057 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19058 VINT(47)=SQRT(VINT(48))
19059 ENDIF
19060
19061C...Possibility of colour rearrangement in W+W- events.
19062 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19063 IAKF1=IABS(KFL1(1))
19064 IAKF2=IABS(KFL1(2))
19065 IAKF3=IABS(KFL2(1))
19066 IAKF4=IABS(KFL2(2))
19067 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19068 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19069 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19070 IF(MINT(51).NE.0) RETURN
19071 ENDIF
19072
19073C...Loop back if needed.
19074 710 IF(IP.LT.NP) GOTO 170
19075
19076C...Boost back to standard frame.
19077 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19078 &BEZIN)
19079
19080 RETURN
19081 END
19082
19083C*********************************************************************
19084
19085C...PYMULT
19086C...Initializes treatment of multiple interactions, selects kinematics
19087C...of hardest interaction if low-pT physics included in run, and
19088C...generates all non-hardest interactions.
19089
19090 SUBROUTINE PYMULT(MMUL)
19091
19092C...Double precision and integer declarations.
19093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19094 IMPLICIT INTEGER(I-N)
19095 INTEGER PYK,PYCHGE,PYCOMP
19096C...Commonblocks.
19097 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19098 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19099 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19100 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19101 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19102 COMMON/PYINT1/MINT(400),VINT(400)
19103 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19104 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19105 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19106 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19107 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19108 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19109C...Local arrays and saved variables.
19110 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19111 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19112 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19113 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19114
19115C...Initialization of multiple interaction treatment.
19116 IF(MMUL.EQ.1) THEN
19117 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19118 ISUB=96
19119 MINT(1)=96
19120 VINT(63)=0D0
19121 VINT(64)=0D0
19122 VINT(143)=1D0
19123 VINT(144)=1D0
19124
19125C...Loop over phase space points: xT2 choice in 20 bins.
19126 100 SIGSUM=0D0
19127 DO 120 IXT2=1,20
19128 NMUL(IXT2)=MSTP(83)
19129 SIGM(IXT2)=0D0
19130 DO 110 ITRY=1,MSTP(83)
19131 RSCA=0.05D0*((21-IXT2)-PYR(0))
19132 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19133 XT2=MAX(0.01D0*VINT(149),XT2)
19134 VINT(25)=XT2
19135
19136C...Choose tau and y*. Calculate cos(theta-hat).
19137 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19138 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19139 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19140 ELSE
19141 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19142 ENDIF
19143 VINT(21)=TAU
19144 CALL PYKLIM(2)
19145 RYST=PYR(0)
19146 MYST=1
19147 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19148 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19149 CALL PYKMAP(2,MYST,PYR(0))
19150 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19151
19152C...Calculate differential cross-section.
19153 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19154 CALL PYSIGH(NCHN,SIGS)
19155 SIGM(IXT2)=SIGM(IXT2)+SIGS
19156 110 CONTINUE
19157 SIGSUM=SIGSUM+SIGM(IXT2)
19158 120 CONTINUE
19159 SIGSUM=SIGSUM/(20D0*MSTP(83))
19160
19161C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19162 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19163 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19164 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19165 PARP(82)=0.9D0*PARP(82)
19166 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19167 & VINT(2)
19168 GOTO 100
19169 ENDIF
19170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19171 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19172
19173C...Start iteration to find k factor.
19174 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19175 P83A=(1D0-PARP(83))**2
19176 P83B=2D0*PARP(83)*(1D0-PARP(83))
19177 P83C=PARP(83)**2
19178 CQ2I=1D0/PARP(84)**2
19179 CQ2R=2D0/(1D0+PARP(84)**2)
19180 SO=0.5D0
19181 XI=0D0
19182 YI=0D0
19183 XF=0D0
19184 YF=0D0
19185 XK=0.5D0
19186 IIT=0
19187 130 IF(IIT.EQ.0) THEN
19188 XK=2D0*XK
19189 ELSEIF(IIT.EQ.1) THEN
19190 XK=0.5D0*XK
19191 ELSE
19192 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19193 ENDIF
19194
19195C...Evaluate overlap integrals. Find where to divide the b range.
19196 IF(MSTP(82).EQ.2) THEN
19197 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19198 SOP=SP/PARU(1)
19199 ELSE
19200 IF(MSTP(82).EQ.3) THEN
19201 DELTAB=0.02D0
19202 ELSEIF(MSTP(82).EQ.4) THEN
19203 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19204 ELSE
19205 POWIP=MAX(0.4D0,PARP(83))
19206 RPWIP=2D0/POWIP-1D0
19207 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19208 SO=0D0
19209 ENDIF
19210 SP=0D0
19211 SOP=0D0
19212 BSP=0D0
19213 SOHIGH=0D0
19214 IBDIV=0
19215 B=-0.5D0*DELTAB
19216 140 B=B+DELTAB
19217 IF(MSTP(82).EQ.3) THEN
19218 OV=EXP(-B**2)/PARU(2)
19219 ELSEIF(MSTP(82).EQ.4) THEN
19220 OV=(P83A*EXP(-MIN(50D0,B**2))+
19221 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19222 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19223 ELSE
19224 OV=EXP(-B**POWIP)/PARU(2)
19225 SO=SO+PARU(2)*B*DELTAB*OV
19226 ENDIF
19227 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19228 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19229 SP=SP+PARU(2)*B*DELTAB*PACC
19230 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19231 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19232 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19233 IBDIV=1
19234 BDIV=B+0.5D0*DELTAB
19235 ENDIF
19236 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19237 ENDIF
19238 YK=PARU(1)*XK*SO/SP
19239
19240C...Continue iteration until convergence.
19241 IF(YK.LT.YKE) THEN
19242 XI=XK
19243 YI=YK
19244 IF(IIT.EQ.1) IIT=2
19245 ELSE
19246 XF=XK
19247 YF=YK
19248 IF(IIT.EQ.0) IIT=1
19249 ENDIF
19250 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19251
19252C...Store some results for subsequent use.
19253 BAVG=BSP/SP
19254 VINT(145)=SIGSUM
19255 VINT(146)=SOP/SO
19256 VINT(147)=SOP/SP
19257 VNT145=VINT(145)
19258 VNT146=VINT(146)
19259 VNT147=VINT(147)
19260C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19261 PIK=(VNT146/VNT147)*YKE
19262
19263C...Find relative weight for low and high impact parameter.
19264 PLOWB=PARU(1)*BDIV**2
19265 IF(MSTP(82).EQ.3) THEN
19266 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19267 ELSEIF(MSTP(82).EQ.4) THEN
19268 S4A=P83A*EXP(-BDIV**2)
19269 S4B=P83B*EXP(-BDIV**2*CQ2R)
19270 S4C=P83C*EXP(-BDIV**2*CQ2I)
19271 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19272 ELSEIF(PARP(83).GE.1.999D0) THEN
19273 PHIGHB=PIK*SOHIGH
19274 B2RPDV=BDIV**POWIP
19275 ELSE
19276 PHIGHB=PIK*SOHIGH
19277 B2RPDV=BDIV**POWIP
19278 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19279 ENDIF
19280 PALLB=PLOWB+PHIGHB
19281
19282C...Initialize iteration in xT2 for hardest interaction.
19283 ELSEIF(MMUL.EQ.2) THEN
19284 VINT(145)=VNT145
19285 VINT(146)=VNT146
19286 VINT(147)=VNT147
19287 IF(MSTP(82).LE.0) THEN
19288 ELSEIF(MSTP(82).EQ.1) THEN
19289 XT2=1D0
19290 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19291 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19292 & VINT(317)/(VINT(318)*VINT(320))
19293 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19294 ELSEIF(MSTP(82).EQ.2) THEN
19295 XT2=1D0
19296 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19297 & VINT(149)*(1D0+VINT(149))
19298 ELSE
19299 XC2=4D0*CKIN(3)**2/VINT(2)
19300 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19301 ENDIF
19302
19303C...Select impact parameter for hardest interaction.
19304 IF(MSTP(82).LE.2) RETURN
19305 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19306C...Treatment in low b region.
19307 MINT(39)=1
19308 B=BDIV*SQRT(PYR(0))
19309 IF(MSTP(82).EQ.3) THEN
19310 OV=EXP(-B**2)/PARU(2)
19311 ELSEIF(MSTP(82).EQ.4) THEN
19312 OV=(P83A*EXP(-MIN(50D0,B**2))+
19313 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19314 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19315 ELSE
19316 OV=EXP(-B**POWIP)/PARU(2)
19317 ENDIF
19318 VINT(148)=OV/VNT147
19319 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19320 XT2=1D0
19321 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19322 & VINT(149)*(1D0+VINT(149))
19323 ELSE
19324C...Treatment in high b region.
19325 MINT(39)=2
19326 IF(MSTP(82).EQ.3) THEN
19327 B=SQRT(BDIV**2-LOG(PYR(0)))
19328 OV=EXP(-B**2)/PARU(2)
19329 ELSEIF(MSTP(82).EQ.4) THEN
19330 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19331 IF(S4RNDM.LT.S4A) THEN
19332 B=SQRT(BDIV**2-LOG(PYR(0)))
19333 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19334 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19335 ELSE
19336 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19337 ENDIF
19338 OV=(P83A*EXP(-MIN(50D0,B**2))+
19339 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19340 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19341 ELSEIF(PARP(83).GE.1.999D0) THEN
19342 144 B2RPW=B2RPDV-LOG(PYR(0))
19343 ACCIP=(B2RPW/B2RPDV)**RPWIP
19344 IF(ACCIP.LT.PYR(0)) GOTO 144
19345 OV=EXP(-B2RPW)/PARU(2)
19346 B=B2RPW**(1D0/POWIP)
19347 ELSE
19348 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19349 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19350 IF(ACCIP.LT.PYR(0)) GOTO 146
19351 OV=EXP(-B2RPW)/PARU(2)
19352 B=B2RPW**(1D0/POWIP)
19353 ENDIF
19354 VINT(148)=OV/VNT147
19355 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19356 ENDIF
19357 IF(PACC.LT.PYR(0)) GOTO 142
19358 VINT(139)=B/BAVG
19359
19360 ELSEIF(MMUL.EQ.3) THEN
19361C...Low-pT or multiple interactions (first semihard interaction):
19362C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19363C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19364 ISUB=MINT(1)
19365 VINT(145)=VNT145
19366 VINT(146)=VNT146
19367 VINT(147)=VNT147
19368 IF(MSTP(82).LE.0) THEN
19369 XT2=0D0
19370 ELSEIF(MSTP(82).EQ.1) THEN
19371 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19372C...Use with "Sudakov" for low b values when impact parameter dependence.
19373 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19374 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19375 & VINT(149)))).GT.PYR(0)) XT2=1D0
19376 IF(XT2.GE.1D0) THEN
19377 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19378 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19379 & VINT(149)
19380 ELSE
19381 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19382 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19383 & VINT(149)
19384 ENDIF
19385 XT2=MAX(0.01D0*VINT(149),XT2)
19386C...Use without "Sudakov" for high b values when impact parameter dep.
19387 ELSE
19388 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19389 & PYR(0)*(1D0-XC2))-VINT(149)
19390 XT2=MAX(0.01D0*VINT(149),XT2)
19391 ENDIF
19392 VINT(25)=XT2
19393
19394C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19395 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19396 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19397 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19398 ISUB=95
19399 MINT(1)=ISUB
19400 VINT(21)=0.01D0*VINT(149)
19401 VINT(22)=0D0
19402 VINT(23)=0D0
19403 VINT(25)=0.01D0*VINT(149)
19404
19405 ELSE
19406C...Multiple interactions (first semihard interaction).
19407C...Choose tau and y*. Calculate cos(theta-hat).
19408 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19409 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19410 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19411 ELSE
19412 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19413 ENDIF
19414 VINT(21)=TAU
19415 CALL PYKLIM(2)
19416 RYST=PYR(0)
19417 MYST=1
19418 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19419 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19420 CALL PYKMAP(2,MYST,PYR(0))
19421 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19422 ENDIF
19423 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19424
19425C...Store results of cross-section calculation.
19426 ELSEIF(MMUL.EQ.4) THEN
19427 ISUB=MINT(1)
19428 VINT(145)=VNT145
19429 VINT(146)=VNT146
19430 VINT(147)=VNT147
19431 XTS=VINT(25)
19432 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19433 IF(ISET(ISUB).EQ.2)
19434 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19435 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19436 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19437 & (XTS+VINT(149))))
19438 IRBIN=INT(1D0+20D0*RBIN)
19439 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19440 NMUL(IRBIN)=NMUL(IRBIN)+1
19441 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19442 ENDIF
19443
19444C...Choose impact parameter if not already done.
19445 ELSEIF(MMUL.EQ.5) THEN
19446 ISUB=MINT(1)
19447 VINT(145)=VNT145
19448 VINT(146)=VNT146
19449 VINT(147)=VNT147
19450 150 IF(MINT(39).GT.0) THEN
19451 ELSEIF(MSTP(82).EQ.3) THEN
19452 EXPB2=PYR(0)
19453 B2=-LOG(PYR(0))
19454 VINT(148)=EXPB2/(PARU(2)*VNT147)
19455 VINT(139)=SQRT(B2)/BAVG
19456 ELSEIF(MSTP(82).EQ.4) THEN
19457 RTYPE=PYR(0)
19458 IF(RTYPE.LT.P83A) THEN
19459 B2=-LOG(PYR(0))
19460 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19461 B2=-LOG(PYR(0))/CQ2R
19462 ELSE
19463 B2=-LOG(PYR(0))/CQ2I
19464 ENDIF
19465 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19466 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19467 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19468 VINT(139)=SQRT(B2)/BAVG
19469 ELSEIF(PARP(83).GE.1.999D0) THEN
19470 POWIP=MAX(2D0,PARP(83))
19471 RPWIP=2D0/POWIP-1D0
19472 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19473 160 IF(PYR(0).LT.PROB1) THEN
19474 B2RPW=PYR(0)**(0.5D0*POWIP)
19475 ACCIP=EXP(-B2RPW)
19476 ELSE
19477 B2RPW=1D0-LOG(PYR(0))
19478 ACCIP=B2RPW**RPWIP
19479 ENDIF
19480 IF(ACCIP.LT.PYR(0)) GOTO 160
19481 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19482 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19483 ELSE
19484 POWIP=MAX(0.4D0,PARP(83))
19485 RPWIP=2D0/POWIP-1D0
19486 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19487 170 IF(PYR(0).LT.PROB1) THEN
19488 B2RPW=2D0*RPWIP*PYR(0)
19489 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19490 ELSE
19491 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19492 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19493 ENDIF
19494 IF(ACCIP.LT .PYR(0)) GOTO 170
19495 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19496 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19497 ENDIF
19498
19499C...Multiple interactions (variable impact parameter) : reject with
19500C...probability exp(-overlap*cross-section above pT/normalization).
19501C...Does not apply to low-b region, where "Sudakov" already included.
19502 VINT(150)=1D0
19503 IF(MINT(39).NE.1) THEN
19504 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19505 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19506 DO 180 IBIN=IRBIN+1,20
19507 RNCOR=RNCOR+NMUL(IBIN)
19508 SIGCOR=SIGCOR+SIGM(IBIN)
19509 180 CONTINUE
19510 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19511 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19512 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19513 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19514 ENDIF
19515 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19516 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19517 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19518 IF(VINT(150).LT.PYR(0)) GOTO 150
19519 VINT(150)=1D0
19520 ENDIF
19521
19522C...Generate additional multiple semihard interactions.
19523 ELSEIF(MMUL.EQ.6) THEN
19524 ISUBSV=MINT(1)
19525 VINT(145)=VNT145
19526 VINT(146)=VNT146
19527 VINT(147)=VNT147
19528 DO 190 J=11,80
19529 VINTSV(J)=VINT(J)
19530 190 CONTINUE
19531 ISUB=96
19532 MINT(1)=96
19533 VINT(151)=0D0
19534 VINT(152)=0D0
19535
19536C...Reconstruct strings in hard scattering.
19537 NMAX=MINT(84)+4
19538 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19539 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19540 NSTR=0
19541 DO 210 I=MINT(84)+1,NMAX
19542 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19543 IF(KCS.EQ.0) GOTO 210
19544 DO 200 J=1,4
19545 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19546 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19547 IF(J.LE.2) THEN
19548 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19549 ELSE
19550 IST=MOD(K(I,J+1),MSTU(5))
19551 ENDIF
19552 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19553 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19554 NSTR=NSTR+1
19555 IF(J.EQ.1.OR.J.EQ.4) THEN
19556 KSTR(NSTR,1)=I
19557 KSTR(NSTR,2)=IST
19558 ELSE
19559 KSTR(NSTR,1)=IST
19560 KSTR(NSTR,2)=I
19561 ENDIF
19562 200 CONTINUE
19563 210 CONTINUE
19564
19565C...Set up starting values for iteration in xT2.
19566 XT2=4D0*VINT(62)/VINT(2)
19567 IF(MSTP(82).LE.1) THEN
19568 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19569 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19570 & VINT(317)/(VINT(318)*VINT(320))
19571 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19572 ELSE
19573 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19574 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19575 ENDIF
19576 VINT(63)=0D0
19577 VINT(64)=0D0
19578 VINT(143)=1D0-VINT(141)
19579 VINT(144)=1D0-VINT(142)
19580
19581C...Iterate downwards in xT2.
19582 220 IF(MSTP(82).LE.1) THEN
19583 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19584 IF(XT2.LT.VINT(149)) GOTO 270
19585 ELSE
19586 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19587 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19588 & LOG(PYR(0)))-VINT(149)
19589 IF(XT2.LE.0D0) GOTO 270
19590 XT2=MAX(0.01D0*VINT(149),XT2)
19591 ENDIF
19592 VINT(25)=XT2
19593
19594C...Choose tau and y*. Calculate cos(theta-hat).
19595 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19596 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19597 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19598 ELSE
19599 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19600 ENDIF
19601 VINT(21)=TAU
19602 CALL PYKLIM(2)
19603 RYST=PYR(0)
19604 MYST=1
19605 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19606 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19607 CALL PYKMAP(2,MYST,PYR(0))
19608 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19609
19610C...Check that x not used up. Accept or reject kinematical variables.
19611 X1M=SQRT(TAU)*EXP(VINT(22))
19612 X2M=SQRT(TAU)*EXP(-VINT(22))
19613 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19614 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19615 CALL PYSIGH(NCHN,SIGS)
19616 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19617 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19618
19619C...Reset K, P and V vectors. Select some variables.
19620 DO 240 I=N+1,N+2
19621 DO 230 J=1,5
19622 K(I,J)=0
19623 P(I,J)=0D0
19624 V(I,J)=0D0
19625 230 CONTINUE
19626 240 CONTINUE
19627 RFLAV=PYR(0)
19628 PT=0.5D0*VINT(1)*SQRT(XT2)
19629 PHI=PARU(2)*PYR(0)
19630 CTH=VINT(23)
19631
19632C...Add first parton to event record.
19633 K(N+1,1)=3
19634 K(N+1,2)=21
19635 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19636 & 1+INT((2D0+PARJ(2))*PYR(0))
19637 P(N+1,1)=PT*COS(PHI)
19638 P(N+1,2)=PT*SIN(PHI)
19639 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19640 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19641 P(N+1,5)=0D0
19642
19643C...Add second parton to event record.
19644 K(N+2,1)=3
19645 K(N+2,2)=21
19646 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19647 P(N+2,1)=-P(N+1,1)
19648 P(N+2,2)=-P(N+1,2)
19649 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19650 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19651 P(N+2,5)=0D0
19652
19653 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19654C....Choose relevant string pieces to place gluons on.
19655 DO 260 I=N+1,N+2
19656 DMIN=1D8
19657 DO 250 ISTR=1,NSTR
19658 I1=KSTR(ISTR,1)
19659 I2=KSTR(ISTR,2)
19660 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19661 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19662 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19663 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19664 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19665 DMIN=DIST
19666 IST1=I1
19667 IST2=I2
19668 ISTM=ISTR
19669 ENDIF
19670 250 CONTINUE
19671
19672C....Colour flow adjustments, new string pieces.
19673 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19674 & MOD(K(IST1,4),MSTU(5))
19675 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19676 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19677 K(I,5)=MSTU(5)*IST1
19678 K(I,4)=MSTU(5)*IST2
19679 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19680 & MOD(K(IST2,5),MSTU(5))
19681 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19682 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19683 KSTR(ISTM,2)=I
19684 KSTR(NSTR+1,1)=I
19685 KSTR(NSTR+1,2)=IST2
19686 NSTR=NSTR+1
19687 260 CONTINUE
19688
19689C...String drawing and colour flow for gluon loop.
19690 ELSEIF(K(N+1,2).EQ.21) THEN
19691 K(N+1,4)=MSTU(5)*(N+2)
19692 K(N+1,5)=MSTU(5)*(N+2)
19693 K(N+2,4)=MSTU(5)*(N+1)
19694 K(N+2,5)=MSTU(5)*(N+1)
19695 KSTR(NSTR+1,1)=N+1
19696 KSTR(NSTR+1,2)=N+2
19697 KSTR(NSTR+2,1)=N+2
19698 KSTR(NSTR+2,2)=N+1
19699 NSTR=NSTR+2
19700
19701C...String drawing and colour flow for qqbar pair.
19702 ELSE
19703 K(N+1,4)=MSTU(5)*(N+2)
19704 K(N+2,5)=MSTU(5)*(N+1)
19705 KSTR(NSTR+1,1)=N+1
19706 KSTR(NSTR+1,2)=N+2
19707 NSTR=NSTR+1
19708 ENDIF
19709
19710C...Global statistics.
19711 MINT(351)=MINT(351)+1
19712 VINT(351)=VINT(351)+PT
19713 IF (MINT(351).EQ.1) VINT(356)=PT
19714
19715C...Update remaining energy; iterate.
19716 N=N+2
19717 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19718 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19719 MINT(51)=1
19720 RETURN
19721 ENDIF
19722 MINT(31)=MINT(31)+1
19723 VINT(151)=VINT(151)+VINT(41)
19724 VINT(152)=VINT(152)+VINT(42)
19725 VINT(143)=VINT(143)-VINT(41)
19726 VINT(144)=VINT(144)-VINT(42)
19727C...Allow FSR for UE (always handle with old showers)
19728 IF(MSTP(152).EQ.1) THEN
19729 M41SAV=MSTJ(41)
19730 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19731 MSTJ(41)=MOD(MSTJ(41),10)
19732 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19733 MSTJ(41)=M41SAV
19734 ENDIF
19735 IF(MINT(31).LT.240) GOTO 220
19736 270 CONTINUE
19737 MINT(1)=ISUBSV
19738 DO 280 J=11,80
19739 VINT(J)=VINTSV(J)
19740 280 CONTINUE
19741 ENDIF
19742
19743C...Format statements for printout.
19744 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19745 &'actions for MSTP(82) =',I2,' ******')
19746 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19747 &D9.2,' mb: rejected')
19748 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19749 &D9.2,' mb: accepted')
19750
19751 RETURN
19752 END
19753
19754C*********************************************************************
19755
19756C...PYREMN
19757C...Adds on target remnants (one or two from each side) and
19758C...includes primordial kT for hadron beams.
19759
19760 SUBROUTINE PYREMN(IPU1,IPU2)
19761
19762C...Double precision and integer declarations.
19763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19764 IMPLICIT INTEGER(I-N)
19765 INTEGER PYK,PYCHGE,PYCOMP
19766C...Commonblocks.
19767 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19770 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19771 COMMON/PYINT1/MINT(400),VINT(400)
19772 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19773C...Local arrays.
19774 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19775 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19776
19777C...Find event type and remaining energy.
19778 ISUB=MINT(1)
19779 NS=N
19780 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19781 VINT(143)=1D0-VINT(141)
19782 VINT(144)=1D0-VINT(142)
19783 ENDIF
19784
19785C...Define initial partons.
19786 NTRY=0
19787 100 NTRY=NTRY+1
19788 DO 130 JT=1,2
19789 I=MINT(83)+JT+2
19790 IF(JT.EQ.1) IPU=IPU1
19791 IF(JT.EQ.2) IPU=IPU2
19792 K(I,1)=21
19793 K(I,2)=K(IPU,2)
19794 K(I,3)=I-2
19795 PMS(JT)=0D0
19796 VINT(156+JT)=0D0
19797 VINT(158+JT)=0D0
19798 IF(MINT(47).EQ.1) THEN
19799 DO 110 J=1,5
19800 P(I,J)=P(I-2,J)
19801 110 CONTINUE
19802 ELSEIF(ISUB.EQ.95) THEN
19803 K(I,2)=21
19804 ELSE
19805 P(I,5)=P(IPU,5)
19806
19807C...No primordial kT, or chosen according to truncated Gaussian or
19808C...exponential, or (for photon) predetermined or power law.
19809 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19810 IF(MSTP(91).LE.0) THEN
19811 PT=0D0
19812 ELSEIF(MSTP(91).EQ.1) THEN
19813 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19814 ELSE
19815 RPT1=PYR(0)
19816 RPT2=PYR(0)
19817 PT=-PARP(92)*LOG(RPT1*RPT2)
19818 ENDIF
19819 IF(PT.GT.PARP(93)) GOTO 120
19820 ELSEIF(MINT(106+JT).EQ.3) THEN
19821 PTA=SQRT(VINT(282+JT))
19822 PTB=0D0
19823 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19824 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19825 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19826 RPT1=PYR(0)
19827 RPT2=PYR(0)
19828 PTB=-PARP(99)*LOG(RPT1*RPT2)
19829 ENDIF
19830 IF(PTB.GT.PARP(100)) GOTO 120
19831 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19832 PT=PT*0.8D0**MINT(57)
19833 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19834 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19835 IF(MSTP(93).LE.0) THEN
19836 PT=0D0
19837 ELSEIF(MSTP(93).EQ.1) THEN
19838 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19839 ELSEIF(MSTP(93).EQ.2) THEN
19840 RPT1=PYR(0)
19841 RPT2=PYR(0)
19842 PT=-PARP(99)*LOG(RPT1*RPT2)
19843 ELSEIF(MSTP(93).EQ.3) THEN
19844 HA=PARP(99)**2
19845 HB=PARP(100)**2
19846 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19847 ELSE
19848 HA=PARP(99)**2
19849 HB=PARP(100)**2
19850 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19851 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19852 ENDIF
19853 IF(PT.GT.PARP(100)) GOTO 120
19854 ELSE
19855 PT=0D0
19856 ENDIF
19857 VINT(156+JT)=PT
19858 PHI=PARU(2)*PYR(0)
19859 P(I,1)=PT*COS(PHI)
19860 P(I,2)=PT*SIN(PHI)
19861 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19862 ENDIF
19863 130 CONTINUE
19864 IF(MINT(47).EQ.1) RETURN
19865
19866C...Kinematics construction for initial partons.
19867 I1=MINT(83)+3
19868 I2=MINT(83)+4
19869 IF(ISUB.EQ.95) THEN
19870 SHS=0D0
19871 SHR=0D0
19872 ELSE
19873 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19874 & (P(I1,2)+P(I2,2))**2
19875 SHR=SQRT(MAX(0D0,SHS))
19876 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19877 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19878 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19879 P(I2,4)=SHR-P(I1,4)
19880 P(I2,3)=-P(I1,3)
19881
19882C...Transform partons to overall CM-frame.
19883 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19884 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19885 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19886 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19887 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19888 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19889 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19890 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19891 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19892 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19893 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19894 ENDIF
19895
19896C...Optionally fix up x and Q2 definitions for leptoproduction.
19897 IDISXQ=0
19898 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19899 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19900 IF(IDISXQ.EQ.1) THEN
19901
19902C...Find where incoming and outgoing leptons/partons are sitting.
19903 LESD=1
19904 IF(MINT(42).EQ.1) LESD=2
19905 LPIN=MINT(83)+3-LESD
19906 LEIN=MINT(84)+LESD
19907 LQIN=MINT(84)+3-LESD
19908 LEOUT=MINT(84)+2+LESD
19909 LQOUT=MINT(84)+5-LESD
19910 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19911 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19912 LSCMS=0
19913 DO 140 I=MINT(84)+5,N
19914 IF(K(I,2).EQ.94) THEN
19915 LSCMS=I
19916 LEOUT=I+LESD
19917 LQOUT=I+3-LESD
19918 ENDIF
19919 140 CONTINUE
19920 LQBG=IPU1
19921 IF(LESD.EQ.1) LQBG=IPU2
19922
19923C...Calculate actual and wanted momentum transfer.
19924 XNOM=VINT(43-LESD)
19925 Q2NOM=-VINT(45)
19926 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19927 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19928 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19929 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19930 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19931 P(N+1,1)=FAC*P(LEOUT,1)
19932 P(N+1,2)=FAC*P(LEOUT,2)
19933 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19934 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19935 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19936 & P(N+1,3)**2)
19937 DO 150 J=1,4
19938 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19939 QNEW(J)=P(LEIN,J)-P(N+1,J)
19940 150 CONTINUE
19941
19942C...Boost outgoing electron and daughters.
19943 IF(LSCMS.EQ.0) THEN
19944 DO 160 J=1,4
19945 P(LEOUT,J)=P(N+1,J)
19946 160 CONTINUE
19947 ELSE
19948 DO 170 J=1,3
19949 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19950 170 CONTINUE
19951 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19952 DO 180 J=1,3
19953 DBE(J)=PINV*P(N+2,J)
19954 180 CONTINUE
19955 DO 200 I=LSCMS+1,N
19956 IORIG=I
19957 190 IORIG=K(IORIG,3)
19958 IF(IORIG.GT.LEOUT) GOTO 190
19959 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19960 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19961 200 CONTINUE
19962 ENDIF
19963
19964C...Copy shower initiator and all outgoing partons.
19965 NCOP=N+1
19966 K(NCOP,3)=LQBG
19967 DO 210 J=1,5
19968 P(NCOP,J)=P(LQBG,J)
19969 210 CONTINUE
19970 DO 240 I=MINT(84)+1,N
19971 ICOP=0
19972 IF(K(I,1).GT.10) GOTO 240
19973 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19974 ICOP=I
19975 ELSE
19976 IORIG=I
19977 220 IORIG=K(IORIG,3)
19978 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19979 ICOP=IORIG
19980 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19981 GOTO 220
19982 ENDIF
19983 ENDIF
19984 IF(ICOP.NE.0) THEN
19985 NCOP=NCOP+1
19986 K(NCOP,3)=I
19987 DO 230 J=1,5
19988 P(NCOP,J)=P(I,J)
19989 230 CONTINUE
19990 ENDIF
19991 240 CONTINUE
19992
19993C...Calculate relative rescaling factors.
19994 SLC=3-2*LESD
19995 PLCSUM=0D0
19996 DO 250 I=N+2,NCOP
19997 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
19998 250 CONTINUE
19999 DO 260 I=N+2,NCOP
20000 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20001 260 CONTINUE
20002
20003C...Transfer extra three-momentum of current.
20004 DO 280 I=N+2,NCOP
20005 DO 270 J=1,3
20006 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20007 270 CONTINUE
20008 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20009 280 CONTINUE
20010
20011C...Iterate change of initiator momentum to get energy right.
20012 ITER=0
20013 290 ITER=ITER+1
20014 PEEX=-P(N+1,4)-QNEW(4)
20015 PEMV=-P(N+1,3)/P(N+1,4)
20016 DO 300 I=N+2,NCOP
20017 PEEX=PEEX+P(I,4)
20018 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20019 300 CONTINUE
20020 IF(ABS(PEMV).LT.1D-10) THEN
20021 MINT(51)=1
20022 MINT(57)=MINT(57)+1
20023 RETURN
20024 ENDIF
20025 PZCH=-PEEX/PEMV
20026 P(N+1,3)=P(N+1,3)+PZCH
20027 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)
20028 DO 310 I=N+2,NCOP
20029 P(I,3)=P(I,3)+V(I,1)*PZCH
20030 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20031 310 CONTINUE
20032 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20033
20034C...Modify momenta in event record.
20035 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20036 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20037 IF(ABS(HBE).GE.1D0) THEN
20038 MINT(51)=1
20039 MINT(57)=MINT(57)+1
20040 RETURN
20041 ENDIF
20042 I=MINT(83)+5-LESD
20043 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20044 DO 330 I=N+1,NCOP
20045 ICOP=K(I,3)
20046 DO 320 J=1,4
20047 P(ICOP,J)=P(I,J)
20048 320 CONTINUE
20049 330 CONTINUE
20050 ENDIF
20051
20052C...Check minimum invariant mass of remnant system(s).
20053 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20054 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20055 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20056 PMIN(0)=SQRT(PMS(0))
20057 DO 340 JT=1,2
20058 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20059 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20060 PMIN(JT)=0D0
20061 IF(MINT(44+JT).EQ.1) GOTO 340
20062 MINT(105)=MINT(102+JT)
20063 MINT(109)=MINT(106+JT)
20064 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20065 IF(MINT(51).NE.0) THEN
20066 MINT(57)=MINT(57)+1
20067 RETURN
20068 ENDIF
20069 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20070 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20071 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20072 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20073 & P(MINT(83)+JT+2,2)**2)
20074 340 CONTINUE
20075 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20076 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20077 &PSYS(2,4))) THEN
20078 MINT(51)=1
20079 MINT(57)=MINT(57)+1
20080 RETURN
20081 ENDIF
20082
20083C...Loop over two remnants; skip if none there.
20084 I=NS
20085 DO 410 JT=1,2
20086 ISN(JT)=0
20087 IF(MINT(44+JT).EQ.1) GOTO 410
20088 IF(JT.EQ.1) IPU=IPU1
20089 IF(JT.EQ.2) IPU=IPU2
20090
20091C...Store first remnant parton.
20092 I=I+1
20093 IS(JT)=I
20094 ISN(JT)=1
20095 DO 350 J=1,5
20096 K(I,J)=0
20097 P(I,J)=0D0
20098 V(I,J)=0D0
20099 350 CONTINUE
20100 K(I,1)=1
20101 K(I,2)=KFLSP(JT)
20102 K(I,3)=MINT(83)+JT
20103 P(I,5)=PYMASS(K(I,2))
20104
20105C...First parton colour connections and kinematics.
20106 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20107 IF(KCOL.EQ.2) THEN
20108 K(I,1)=3
20109 K(I,4)=MSTU(5)*IPU+IPU
20110 K(I,5)=MSTU(5)*IPU+IPU
20111 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20112 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20113 ELSEIF(KCOL.NE.0) THEN
20114 K(I,1)=3
20115 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20116 K(I,KFLS+3)=IPU
20117 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20118 ENDIF
20119 IF(KFLCH(JT).EQ.0) THEN
20120 P(I,1)=-P(MINT(83)+JT+2,1)
20121 P(I,2)=-P(MINT(83)+JT+2,2)
20122 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20123 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20124 P(I,3)=PSYS(JT,3)
20125 P(I,4)=PSYS(JT,4)
20126
20127C...When extra remnant parton or hadron: store extra remnant.
20128 ELSE
20129 I=I+1
20130 ISN(JT)=2
20131 DO 360 J=1,5
20132 K(I,J)=0
20133 P(I,J)=0D0
20134 V(I,J)=0D0
20135 360 CONTINUE
20136 K(I,1)=1
20137 K(I,2)=KFLCH(JT)
20138 K(I,3)=MINT(83)+JT
20139 P(I,5)=PYMASS(K(I,2))
20140
20141C...Find parton colour connections of extra remnant.
20142 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20143 IF(KCOL.EQ.2) THEN
20144 K(I,1)=3
20145 K(I,4)=MSTU(5)*IPU+IPU
20146 K(I,5)=MSTU(5)*IPU+IPU
20147 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20148 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20149 ELSEIF(KCOL.NE.0) THEN
20150 K(I,1)=3
20151 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20152 K(I,KFLS+3)=IPU
20153 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20154 ENDIF
20155
20156C...Relative transverse momentum when two remnants.
20157 LOOP=0
20158 370 LOOP=LOOP+1
20159 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20160 IF(IABS(MINT(10+JT)).LT.20) THEN
20161 P(I-1,1)=0D0
20162 P(I-1,2)=0D0
20163 ELSE
20164 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20165 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20166 ENDIF
20167 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20168 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20169 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20170 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20171
20172C...Meson or baryon; photon as meson. For splitup below.
20173 IMB=1
20174 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20175
20176C***Relative distribution for electron into two electrons. Temporary!
20177 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20178 & THEN
20179 CHI(JT)=PYR(0)
20180
20181C...Relative distribution of electron energy into electron plus parton.
20182 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20183 XHRD=VINT(140+JT)
20184 XE=VINT(154+JT)
20185 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20186
20187C...Relative distribution of energy for particle into two jets.
20188 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20189 CHIK=PARP(92+2*IMB)
20190 IF(MSTP(92).LE.1) THEN
20191 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20192 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20193 ELSEIF(MSTP(92).EQ.2) THEN
20194 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20195 ELSEIF(MSTP(92).EQ.3) THEN
20196 CUT=2D0*0.3D0/VINT(1)
20197 380 CHI(JT)=PYR(0)**2
20198 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20199 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20200 ELSEIF(MSTP(92).EQ.4) THEN
20201 CUT=2D0*0.3D0/VINT(1)
20202 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20203 390 CHIR=CUT*CUTR**PYR(0)
20204 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20205 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20206 ELSE
20207 CUT=2D0*0.3D0/VINT(1)
20208 CUTA=CUT**(1D0-PARP(98))
20209 CUTB=(1D0+CUT)**(1D0-PARP(98))
20210 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20211 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20212 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20213 ENDIF
20214
20215C...Relative distribution of energy for particle into jet plus particle.
20216 ELSE
20217 IF(MSTP(94).LE.1) THEN
20218 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20219 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20220 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20221 ELSEIF(MSTP(94).EQ.2) THEN
20222 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20223 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20224 ELSEIF(MSTP(94).EQ.3) THEN
20225 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20226 CHI(JT)=ZZ
20227 ELSE
20228 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20229 CHI(JT)=ZZ
20230 ENDIF
20231 ENDIF
20232
20233C...Construct total transverse mass; reject if too large.
20234 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20235 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20236 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20237 IF(LOOP.LT.100) THEN
20238 GOTO 370
20239 ELSE
20240 MINT(51)=1
20241 MINT(57)=MINT(57)+1
20242 RETURN
20243 ENDIF
20244 ENDIF
20245 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20246 VINT(158+JT)=CHI(JT)
20247
20248C...Subdivide longitudinal momentum according to value selected above.
20249 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20250 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20251 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20252 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20253 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20254 ENDIF
20255 410 CONTINUE
20256 N=I
20257
20258C...Check if longitudinal boosts needed - if so pick two systems.
20259 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20260 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20261 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20262 IF(ISN(1).EQ.0) THEN
20263 IR=0
20264 IL=2
20265 ELSEIF(ISN(2).EQ.0) THEN
20266 IR=1
20267 IL=0
20268 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20269 IR=1
20270 IL=2
20271 ELSEIF(VINT(143).GT.0.2D0) THEN
20272 IR=1
20273 IL=0
20274 ELSEIF(VINT(144).GT.0.2D0) THEN
20275 IR=0
20276 IL=2
20277 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20278 IR=1
20279 IL=0
20280 ELSE
20281 IR=0
20282 IL=2
20283 ENDIF
20284 IG=3-IR-IL
20285
20286C...E+-pL wanted for system to be modified.
20287 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20288 PPB=VINT(1)
20289 PNB=VINT(1)
20290 ELSE
20291 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20292 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20293 ENDIF
20294
20295C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20296 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20297 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20298 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20299 DO 420 J=1,4
20300 PSYS(0,J)=0D0
20301 420 CONTINUE
20302 DO 450 I=MINT(84)+1,NS
20303 IF(K(I,1).GT.10) GOTO 450
20304 INCL=0
20305 IORIG=I
20306 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20307 IORIG=K(IORIG,3)
20308 IF(IORIG.GT.LPIN) GOTO 430
20309 IF(INCL.EQ.0) GOTO 450
20310 DO 440 J=1,4
20311 PSYS(0,J)=PSYS(0,J)+P(I,J)
20312 440 CONTINUE
20313 450 CONTINUE
20314 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20315 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20316 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20317 ENDIF
20318
20319C...Construct longitudinal boosts.
20320 DPMTB=PPB*PNB
20321 DPMTR=PMS(IR)
20322 DPMTL=PMS(IL)
20323 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20324 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20325 MINT(51)=1
20326 MINT(57)=MINT(57)+1
20327 RETURN
20328 ENDIF
20329 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20330 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20331 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20332 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20333 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20334 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20335 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20336
20337C...Perform longitudinal boosts.
20338 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20339 P(IS(1),3)=0D0
20340 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20341 ELSEIF(IR.EQ.1) THEN
20342 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20343 ELSEIF(IDISXQ.EQ.1) THEN
20344 DO 470 I=I1,NS
20345 INCL=0
20346 IORIG=I
20347 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20348 IORIG=K(IORIG,3)
20349 IF(IORIG.GT.LPIN) GOTO 460
20350 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20351 470 CONTINUE
20352 ELSE
20353 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20354 ENDIF
20355 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20356 P(IS(2),3)=0D0
20357 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20358 ELSEIF(IL.EQ.2) THEN
20359 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20360 ELSEIF(IDISXQ.EQ.1) THEN
20361 DO 490 I=I1,NS
20362 INCL=0
20363 IORIG=I
20364 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20365 IORIG=K(IORIG,3)
20366 IF(IORIG.GT.LPIN) GOTO 480
20367 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20368 490 CONTINUE
20369 ELSE
20370 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20371 ENDIF
20372
20373C...Final check that energy-momentum conservation worked.
20374 PESUM=0D0
20375 PZSUM=0D0
20376 DO 500 I=MINT(84)+1,N
20377 IF(K(I,1).GT.10) GOTO 500
20378 PESUM=PESUM+P(I,4)
20379 PZSUM=PZSUM+P(I,3)
20380 500 CONTINUE
20381 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20382 IF(PDEV.GT.1D-4*VINT(1)) THEN
20383 MINT(51)=1
20384 MINT(57)=MINT(57)+1
20385 RETURN
20386 ENDIF
20387
20388C...Calculate rotation and boost from overall CM frame to
20389C...hadronic CM frame in leptoproduction.
20390 MINT(91)=0
20391 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20392 MINT(91)=1
20393 LESD=1
20394 IF(MINT(42).EQ.1) LESD=2
20395 LPIN=MINT(83)+3-LESD
20396
20397C...Sum upp momenta of everything not lepton or photon to define boost.
20398 DO 510 J=1,4
20399 PSUM(J)=0D0
20400 510 CONTINUE
20401 DO 530 I=1,N
20402 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20403 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20404 IF(K(I,2).EQ.22) GOTO 530
20405 DO 520 J=1,4
20406 PSUM(J)=PSUM(J)+P(I,J)
20407 520 CONTINUE
20408 530 CONTINUE
20409 VINT(223)=-PSUM(1)/PSUM(4)
20410 VINT(224)=-PSUM(2)/PSUM(4)
20411 VINT(225)=-PSUM(3)/PSUM(4)
20412
20413C...Boost incoming hadron to hadronic CM frame to determine rotations.
20414 K(N+1,1)=1
20415 DO 540 J=1,5
20416 P(N+1,J)=P(LPIN,J)
20417 V(N+1,J)=V(LPIN,J)
20418 540 CONTINUE
20419 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20420 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20421 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20422 IF(LESD.EQ.2) THEN
20423 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20424 ELSE
20425 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20426 ENDIF
20427 ENDIF
20428
20429 RETURN
20430 END
20431
20432C*********************************************************************
20433
20434C...PYMIGN
20435C...Initializes treatment of new multiple interactions scenario,
20436C...selects kinematics of hardest interaction if low-pT physics
20437C...included in run, and generates all non-hardest interactions.
20438
20439 SUBROUTINE PYMIGN(MMUL)
20440
20441C...Double precision and integer declarations.
20442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20443 IMPLICIT INTEGER(I-N)
20444 INTEGER PYK,PYCHGE,PYCOMP
20445 EXTERNAL PYALPS
20446 DOUBLE PRECISION PYALPS
20447C...Commonblocks.
20448 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20449 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20450 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20451 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20452 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20454 COMMON/PYINT1/MINT(400),VINT(400)
20455 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20456 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20457 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20458 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20459 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20460 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20461 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20462 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20463 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20464C...Local arrays and saved variables.
20465 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20466 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20467 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20468 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20469 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20470
20471C...Initialization of multiple interaction treatment.
20472 IF(MMUL.EQ.1) THEN
20473 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20474 ISUB=96
20475 MINT(1)=96
20476 VINT(63)=0D0
20477 VINT(64)=0D0
20478 VINT(143)=1D0
20479 VINT(144)=1D0
20480
20481C...Loop over phase space points: xT2 choice in 20 bins.
20482 100 SIGSUM=0D0
20483 DO 120 IXT2=1,20
20484 NMUL(IXT2)=MSTP(83)
20485 SIGM(IXT2)=0D0
20486 DO 110 ITRY=1,MSTP(83)
20487 RSCA=0.05D0*((21-IXT2)-PYR(0))
20488 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20489 XT2=MAX(0.01D0*VINT(149),XT2)
20490 VINT(25)=XT2
20491
20492C...Choose tau and y*. Calculate cos(theta-hat).
20493 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20494 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20495 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20496 ELSE
20497 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20498 ENDIF
20499 VINT(21)=TAU
20500 CALL PYKLIM(2)
20501 RYST=PYR(0)
20502 MYST=1
20503 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20504 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20505 CALL PYKMAP(2,MYST,PYR(0))
20506 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20507
20508C...Calculate differential cross-section.
20509 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20510 CALL PYSIGH(NCHN,SIGS)
20511 SIGM(IXT2)=SIGM(IXT2)+SIGS
20512 110 CONTINUE
20513 SIGSUM=SIGSUM+SIGM(IXT2)
20514 120 CONTINUE
20515 SIGSUM=SIGSUM/(20D0*MSTP(83))
20516
20517C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20518 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20519 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20520 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20521 PARP(82)=0.9D0*PARP(82)
20522 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20523 & VINT(2)
20524 GOTO 100
20525 ENDIF
20526 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20527 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20528
20529C...Start iteration to find k factor.
20530 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20531 P83A=(1D0-PARP(83))**2
20532 P83B=2D0*PARP(83)*(1D0-PARP(83))
20533 P83C=PARP(83)**2
20534 CQ2I=1D0/PARP(84)**2
20535 CQ2R=2D0/(1D0+PARP(84)**2)
20536 SO=0.5D0
20537 XI=0D0
20538 YI=0D0
20539 XF=0D0
20540 YF=0D0
20541 XK=0.5D0
20542 IIT=0
20543 130 IF(IIT.EQ.0) THEN
20544 XK=2D0*XK
20545 ELSEIF(IIT.EQ.1) THEN
20546 XK=0.5D0*XK
20547 ELSE
20548 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20549 ENDIF
20550
20551C...Evaluate overlap integrals. Find where to divide the b range.
20552 IF(MSTP(82).EQ.2) THEN
20553 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20554 SOP=SP/PARU(1)
20555 ELSE
20556 IF(MSTP(82).EQ.3) THEN
20557 DELTAB=0.02D0
20558 ELSEIF(MSTP(82).EQ.4) THEN
20559 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20560 ELSE
20561 POWIP=MAX(0.4D0,PARP(83))
20562 RPWIP=2D0/POWIP-1D0
20563 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20564 SO=0D0
20565 ENDIF
20566 SP=0D0
20567 SOP=0D0
20568 BSP=0D0
20569 SOHIGH=0D0
20570 IBDIV=0
20571 B=-0.5D0*DELTAB
20572 140 B=B+DELTAB
20573 IF(MSTP(82).EQ.3) THEN
20574 OV=EXP(-B**2)/PARU(2)
20575 ELSEIF(MSTP(82).EQ.4) THEN
20576 OV=(P83A*EXP(-MIN(50D0,B**2))+
20577 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20578 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20579 ELSE
20580 OV=EXP(-B**POWIP)/PARU(2)
20581 SO=SO+PARU(2)*B*DELTAB*OV
20582 ENDIF
20583 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20584 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20585 SP=SP+PARU(2)*B*DELTAB*PACC
20586 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20587 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20588 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20589 IBDIV=1
20590 BDIV=B+0.5D0*DELTAB
20591 ENDIF
20592 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20593 ENDIF
20594 YK=PARU(1)*XK*SO/SP
20595
20596C...Continue iteration until convergence.
20597 IF(YK.LT.YKE) THEN
20598 XI=XK
20599 YI=YK
20600 IF(IIT.EQ.1) IIT=2
20601 ELSE
20602 XF=XK
20603 YF=YK
20604 IF(IIT.EQ.0) IIT=1
20605 ENDIF
20606 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20607
20608C...Store some results for subsequent use.
20609 BAVG=BSP/SP
20610 VINT(145)=SIGSUM
20611 VINT(146)=SOP/SO
20612 VINT(147)=SOP/SP
20613 VNT145=VINT(145)
20614 VNT146=VINT(146)
20615 VNT147=VINT(147)
20616C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20617 PIK=(VNT146/VNT147)*YKE
20618
20619C...Find relative weight for low and high impact parameter..
20620 PLOWB=PARU(1)*BDIV**2
20621 IF(MSTP(82).EQ.3) THEN
20622 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20623 ELSEIF(MSTP(82).EQ.4) THEN
20624 S4A=P83A*EXP(-BDIV**2)
20625 S4B=P83B*EXP(-BDIV**2*CQ2R)
20626 S4C=P83C*EXP(-BDIV**2*CQ2I)
20627 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20628 ELSEIF(PARP(83).GE.1.999D0) THEN
20629 PHIGHB=PIK*SOHIGH
20630 B2RPDV=BDIV**POWIP
20631 ELSE
20632 PHIGHB=PIK*SOHIGH
20633 B2RPDV=BDIV**POWIP
20634 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20635 ENDIF
20636 PALLB=PLOWB+PHIGHB
20637
20638C...Initialize iteration in xT2 for hardest interaction.
20639 ELSEIF(MMUL.EQ.2) THEN
20640 VINT(145)=VNT145
20641 VINT(146)=VNT146
20642 VINT(147)=VNT147
20643 IF(MSTP(82).LE.0) THEN
20644 ELSEIF(MSTP(82).EQ.1) THEN
20645 XT2=1D0
20646 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20647 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20648 & VINT(317)/(VINT(318)*VINT(320))
20649 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20650 ELSEIF(MSTP(82).EQ.2) THEN
20651 XT2=1D0
20652 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20653 & VINT(149)*(1D0+VINT(149))
20654 ELSE
20655 XC2=4D0*CKIN(3)**2/VINT(2)
20656 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20657 ENDIF
20658
20659C...Select impact parameter for hardest interaction.
20660 IF(MSTP(82).LE.2) RETURN
20661 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20662C...Treatment in low b region.
20663 MINT(39)=1
20664 B=BDIV*SQRT(PYR(0))
20665 IF(MSTP(82).EQ.3) THEN
20666 OV=EXP(-B**2)/PARU(2)
20667 ELSEIF(MSTP(82).EQ.4) THEN
20668 OV=(P83A*EXP(-MIN(50D0,B**2))+
20669 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20670 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20671 ELSE
20672 OV=EXP(-B**POWIP)/PARU(2)
20673 ENDIF
20674 VINT(148)=OV/VNT147
20675 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20676 XT2=1D0
20677 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20678 & VINT(149)*(1D0+VINT(149))
20679 ELSE
20680C...Treatment in high b region.
20681 MINT(39)=2
20682 IF(MSTP(82).EQ.3) THEN
20683 B=SQRT(BDIV**2-LOG(PYR(0)))
20684 OV=EXP(-B**2)/PARU(2)
20685 ELSEIF(MSTP(82).EQ.4) THEN
20686 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20687 IF(S4RNDM.LT.S4A) THEN
20688 B=SQRT(BDIV**2-LOG(PYR(0)))
20689 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20690 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20691 ELSE
20692 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20693 ENDIF
20694 OV=(P83A*EXP(-MIN(50D0,B**2))+
20695 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20696 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20697 ELSEIF(PARP(83).GE.1.999D0) THEN
20698 144 B2RPW=B2RPDV-LOG(PYR(0))
20699 ACCIP=(B2RPW/B2RPDV)**RPWIP
20700 IF(ACCIP.LT.PYR(0)) GOTO 144
20701 OV=EXP(-B2RPW)/PARU(2)
20702 B=B2RPW**(1D0/POWIP)
20703 ELSE
20704 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20705 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20706 IF(ACCIP.LT.PYR(0)) GOTO 146
20707 OV=EXP(-B2RPW)/PARU(2)
20708 B=B2RPW**(1D0/POWIP)
20709 ENDIF
20710 VINT(148)=OV/VNT147
20711 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20712 ENDIF
20713 IF(PACC.LT.PYR(0)) GOTO 142
20714 VINT(139)=B/BAVG
20715
20716 ELSEIF(MMUL.EQ.3) THEN
20717C...Low-pT or multiple interactions (first semihard interaction):
20718C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20719C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20720 ISUB=MINT(1)
20721 VINT(145)=VNT145
20722 VINT(146)=VNT146
20723 VINT(147)=VNT147
20724 IF(MSTP(82).LE.0) THEN
20725 XT2=0D0
20726 ELSEIF(MSTP(82).EQ.1) THEN
20727 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20728C...Use with "Sudakov" for low b values when impact parameter dependence.
20729 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20730 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20731 & VINT(149)))).GT.PYR(0)) XT2=1D0
20732 IF(XT2.GE.1D0) THEN
20733 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20734 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20735 & VINT(149)
20736 ELSE
20737 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20738 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20739 & VINT(149)
20740 ENDIF
20741 XT2=MAX(0.01D0*VINT(149),XT2)
20742C...Use without "Sudakov" for high b values when impact parameter dep.
20743 ELSE
20744 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20745 & PYR(0)*(1D0-XC2))-VINT(149)
20746 XT2=MAX(0.01D0*VINT(149),XT2)
20747 ENDIF
20748 VINT(25)=XT2
20749
20750C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20751 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20752 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20753 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20754 ISUB=95
20755 MINT(1)=ISUB
20756 VINT(21)=1D-12*VINT(149)
20757 VINT(22)=0D0
20758 VINT(23)=0D0
20759 VINT(25)=1D-12*VINT(149)
20760
20761 ELSE
20762C...Multiple interactions (first semihard interaction).
20763C...Choose tau and y*. Calculate cos(theta-hat).
20764 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20765 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20766 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20767 ELSE
20768 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20769 ENDIF
20770 VINT(21)=TAU
20771 CALL PYKLIM(2)
20772 RYST=PYR(0)
20773 MYST=1
20774 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20775 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20776 CALL PYKMAP(2,MYST,PYR(0))
20777 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20778 ENDIF
20779 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20780
20781C...Store results of cross-section calculation.
20782 ELSEIF(MMUL.EQ.4) THEN
20783 ISUB=MINT(1)
20784 VINT(145)=VNT145
20785 VINT(146)=VNT146
20786 VINT(147)=VNT147
20787 XTS=VINT(25)
20788 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20789 IF(ISET(ISUB).EQ.2)
20790 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20791 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20792 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20793 & (XTS+VINT(149))))
20794 IRBIN=INT(1D0+20D0*RBIN)
20795 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20796 NMUL(IRBIN)=NMUL(IRBIN)+1
20797 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20798 ENDIF
20799
20800C...Choose impact parameter if not already done.
20801 ELSEIF(MMUL.EQ.5) THEN
20802 ISUB=MINT(1)
20803 VINT(145)=VNT145
20804 VINT(146)=VNT146
20805 VINT(147)=VNT147
20806 150 IF(MINT(39).GT.0) THEN
20807 ELSEIF(MSTP(82).EQ.3) THEN
20808 EXPB2=PYR(0)
20809 B2=-LOG(PYR(0))
20810 VINT(148)=EXPB2/(PARU(2)*VNT147)
20811 VINT(139)=SQRT(B2)/BAVG
20812 ELSEIF(MSTP(82).EQ.4) THEN
20813 RTYPE=PYR(0)
20814 IF(RTYPE.LT.P83A) THEN
20815 B2=-LOG(PYR(0))
20816 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20817 B2=-LOG(PYR(0))/CQ2R
20818 ELSE
20819 B2=-LOG(PYR(0))/CQ2I
20820 ENDIF
20821 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20822 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20823 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20824 VINT(139)=SQRT(B2)/BAVG
20825 ELSEIF(PARP(83).GE.1.999D0) THEN
20826 POWIP=MAX(2D0,PARP(83))
20827 RPWIP=2D0/POWIP-1D0
20828 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20829 160 IF(PYR(0).LT.PROB1) THEN
20830 B2RPW=PYR(0)**(0.5D0*POWIP)
20831 ACCIP=EXP(-B2RPW)
20832 ELSE
20833 B2RPW=1D0-LOG(PYR(0))
20834 ACCIP=B2RPW**RPWIP
20835 ENDIF
20836 IF(ACCIP.LT.PYR(0)) GOTO 160
20837 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20838 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20839 ELSE
20840 POWIP=MAX(0.4D0,PARP(83))
20841 RPWIP=2D0/POWIP-1D0
20842 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20843 170 IF(PYR(0).LT.PROB1) THEN
20844 B2RPW=2D0*RPWIP*PYR(0)
20845 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20846 ELSE
20847 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20848 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20849 ENDIF
20850 IF(ACCIP.LT .PYR(0)) GOTO 170
20851 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20852 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20853 ENDIF
20854
20855C...Multiple interactions (variable impact parameter) : reject with
20856C...probability exp(-overlap*cross-section above pT/normalization).
20857C...Does not apply to low-b region, where "Sudakov" already included.
20858 VINT(150)=1D0
20859 IF(MINT(39).NE.1) THEN
20860 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20861 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20862 DO 180 IBIN=IRBIN+1,20
20863 RNCOR=RNCOR+NMUL(IBIN)
20864 SIGCOR=SIGCOR+SIGM(IBIN)
20865 180 CONTINUE
20866 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20867 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20868 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20869 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20870 ENDIF
20871 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20872 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20873 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20874 IF(VINT(150).LT.PYR(0)) GOTO 150
20875 VINT(150)=1D0
20876 ENDIF
20877
20878C...Generate additional multiple semihard interactions.
20879 ELSEIF(MMUL.EQ.6) THEN
20880
20881C...Save data for hardest initeraction, to be restored.
20882 ISUBSV=MINT(1)
20883 VINT(145)=VNT145
20884 VINT(146)=VNT146
20885 VINT(147)=VNT147
20886 M13SV=MINT(13)
20887 M14SV=MINT(14)
20888 M15SV=MINT(15)
20889 M16SV=MINT(16)
20890 M21SV=MINT(21)
20891 M22SV=MINT(22)
20892 DO 190 J=11,80
20893 VINTSV(J)=VINT(J)
20894 190 CONTINUE
20895 V141SV=VINT(141)
20896 V142SV=VINT(142)
20897
20898C...Store data on hardest interaction.
20899 XMI(1,1)=VINT(141)
20900 XMI(2,1)=VINT(142)
20901 PT2MI(1)=VINT(54)
20902 IMISEP(0)=MINT(84)
20903 IMISEP(1)=N
20904
20905C...Change process to generate; sum of x values so far.
20906 ISUB=96
20907 MINT(1)=96
20908 VINT(143)=1D0-VINT(141)
20909 VINT(144)=1D0-VINT(142)
20910 VINT(151)=0D0
20911 VINT(152)=0D0
20912
20913C...Initialize factors for PDF reshaping.
20914 DO 230 JS=1,2
20915 KFBEAM=MINT(10+JS)
20916 KFABM=IABS(KFBEAM)
20917 KFSBM=ISIGN(1,KFBEAM)
20918
20919C...Zero flavour content of incoming beam particle.
20920 KFIVAL(JS,1)=0
20921 KFIVAL(JS,2)=0
20922 KFIVAL(JS,3)=0
20923C...Flavour content of baryon.
20924 IF(KFABM.GT.1000) THEN
20925 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20926 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20927 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20928C...Flavour content of pi+-, K+-.
20929 ELSEIF(KFABM.EQ.211) THEN
20930 KFIVAL(JS,1)=KFSBM*2
20931 KFIVAL(JS,2)=-KFSBM
20932 ELSEIF(KFABM.EQ.321) THEN
20933 KFIVAL(JS,1)=-KFSBM*3
20934 KFIVAL(JS,2)=KFSBM*2
20935C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20936 ENDIF
20937
20938C...Zero initial valence and companion content.
20939 DO 200 IFL=-6,6
20940 NVC(JS,IFL)=0
20941 200 CONTINUE
20942
20943C...Initiate listing of all incoming partons from two sides.
20944 NMI(JS)=0
20945 DO 210 I=MINT(84)+1,N
20946 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20947 IMI(JS,1,1)=I
20948 IMI(JS,1,2)=0
20949 ENDIF
20950 210 CONTINUE
20951
20952C...Decide whether quarks in hard scattering were valence or sea.
20953 IFL=K(IMI(JS,1,1),2)
20954 IF (IABS(IFL).GT.6) GOTO 230
20955
20956C...Get PDFs at X and Q2 of the parton shower initiator for the
20957C...hard scattering.
20958 X=VINT(140+JS)
20959 IF(MSTP(61).GE.1) THEN
20960 Q2=PARP(62)**2
20961 ELSE
20962 Q2=VINT(54)
20963 ENDIF
20964C...Note: XPSVC = x*pdf.
20965 MINT(30)=JS
20966C.... ALICE
20967C.... Store side in MINT(124)
20968 MINT(124) = JS
20969C....
20970 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20971 SEA=XPSVC(IFL,-1)
20972 VAL=XPSVC(IFL,0)
20973
20974C...Decide (Extra factor x cancels in the division).
20975 RVCS=PYR(0)*(SEA+VAL)
20976 IVNOW=1
20977 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20978C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20979 IVNOW=0
20980 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20981 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20982 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20983 IF(KFIVAL(JS,1).EQ.0) THEN
20984 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20985 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20986 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20987 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20988 ENDIF
20989 IF(IVNOW.EQ.0) GOTO 220
20990C...Mark valence.
20991 IMI(JS,1,2)=0
20992C...Sets valence content of gamma, pi0, K0S, K0L if not done.
20993 IF(KFIVAL(JS,1).EQ.0) THEN
20994 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
20995 KFIVAL(JS,1)=IFL
20996 KFIVAL(JS,2)=-IFL
20997 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
20998 KFIVAL(JS,1)=IFL
20999 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21000 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21001 ENDIF
21002 ENDIF
21003
21004C...If sea, add opposite sign companion parton. Store X and I.
21005 ELSE
21006 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21007 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21008C...Set pointer to companion
21009 IMI(JS,1,2)=-NVC(JS,-IFL)
21010 ENDIF
21011 230 CONTINUE
21012
21013C...Update counter number of multiple interactions.
21014 NMI(1)=1
21015 NMI(2)=1
21016
21017C...Set up starting values for iteration in xT2.
21018 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21019 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21020 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21021 & ISUBSV.NE.96)) THEN
21022 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21023 ELSE
21024 XT2=VINT(25)
21025 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21026 IF(ISET(ISUBSV).EQ.2)
21027 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21028 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21029 ENDIF
21030 IF(MSTP(82).LE.1) THEN
21031 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21032 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21033 & VINT(317)/(VINT(318)*VINT(320))
21034 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21035 ELSE
21036 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21037 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21038 ENDIF
21039 VINT(63)=0D0
21040 VINT(64)=0D0
21041
21042C...Iterate downwards in xT2.
21043 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21044 XT2=0D0
21045 GOTO 440
21046 ELSEIF(MSTP(82).LE.1) THEN
21047 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21048 IF(XT2.LT.VINT(149)) GOTO 440
21049 ELSE
21050 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21051 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21052 & LOG(PYR(0)))-VINT(149)
21053 IF(XT2.LE.0D0) GOTO 440
21054 XT2=MAX(0.01D0*VINT(149),XT2)
21055 ENDIF
21056 VINT(25)=XT2
21057
21058C...Choose tau and y*. Calculate cos(theta-hat).
21059 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21060 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21061 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21062 ELSE
21063 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21064 ENDIF
21065 VINT(21)=TAU
21066C...New: require shat > 1.
21067 IF(TAU*VINT(2).LT.1D0) GOTO 240
21068 CALL PYKLIM(2)
21069 RYST=PYR(0)
21070 MYST=1
21071 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21072 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21073 CALL PYKMAP(2,MYST,PYR(0))
21074 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21075
21076C...Check that x not used up. Accept or reject kinematical variables.
21077 X1M=SQRT(TAU)*EXP(VINT(22))
21078 X2M=SQRT(TAU)*EXP(-VINT(22))
21079 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21080 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21081 CALL PYSIGH(NCHN,SIGS)
21082 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21083 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21084 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21085
21086C...Reset K, P and V vectors.
21087 DO 260 I=N+1,N+4
21088 DO 250 J=1,5
21089 K(I,J)=0
21090 P(I,J)=0D0
21091 V(I,J)=0D0
21092 250 CONTINUE
21093 260 CONTINUE
21094 PT=0.5D0*VINT(1)*SQRT(XT2)
21095
21096C...Choose flavour of reacting partons (and subprocess).
21097 RSIGS=SIGS*PYR(0)
21098 DO 270 ICHN=1,NCHN
21099 KFL1=ISIG(ICHN,1)
21100 KFL2=ISIG(ICHN,2)
21101 ICONMI=ISIG(ICHN,3)
21102 RSIGS=RSIGS-SIGH(ICHN)
21103 IF(RSIGS.LE.0D0) GOTO 280
21104 270 CONTINUE
21105
21106C...Reassign to appropriate process codes.
21107 280 ISUBMI=ICONMI/10
21108 ICONMI=MOD(ICONMI,10)
21109
21110C...Choose new quark flavour for annihilation graphs
21111 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21112 SH=TAU*VINT(2)
21113 CALL PYWIDT(21,SH,WDTP,WDTE)
21114 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21115 DO 300 I=1,MDCY(21,3)
21116 KFLF=KFDP(I+MDCY(21,2)-1,1)
21117 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21118 IF(RKFL.LE.0D0) GOTO 310
21119 300 CONTINUE
21120 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21121 IF(KFLF.GE.4) GOTO 290
21122 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21123 KFLF=4
21124 ICONMI=ICONMI-2
21125 ELSEIF(ISUBMI.EQ.53) THEN
21126 KFLF=5
21127 ICONMI=ICONMI-4
21128 ENDIF
21129 ENDIF
21130
21131C...Final state flavours and colour flow: default values
21132 JS=1
21133 KFL3=KFL1
21134 KFL4=KFL2
21135 KCC=20
21136 KCS=ISIGN(1,KFL1)
21137
21138 IF(ISUBMI.EQ.11) THEN
21139C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21140 KCC=ICONMI
21141 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21142
21143 ELSEIF(ISUBMI.EQ.12) THEN
21144C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21145 KFL3=ISIGN(KFLF,KFL1)
21146 KFL4=-KFL3
21147 KCC=4
21148
21149 ELSEIF(ISUBMI.EQ.13) THEN
21150C...f + fbar -> g + g; th arbitrary
21151 KFL3=21
21152 KFL4=21
21153 KCC=ICONMI+4
21154
21155 ELSEIF(ISUBMI.EQ.28) THEN
21156C...f + g -> f + g; th = (p(f)-p(f))**2
21157 IF(KFL1.EQ.21) JS=2
21158 KCC=ICONMI+6
21159 IF(KFL1.EQ.21) KCC=KCC+2
21160 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21161 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21162
21163 ELSEIF(ISUBMI.EQ.53) THEN
21164C...g + g -> f + fbar; th arbitrary
21165 KCS=(-1)**INT(1.5D0+PYR(0))
21166 KFL3=ISIGN(KFLF,KCS)
21167 KFL4=-KFL3
21168 KCC=ICONMI+10
21169
21170 ELSEIF(ISUBMI.EQ.68) THEN
21171C...g + g -> g + g; th arbitrary
21172 KCC=ICONMI+12
21173 KCS=(-1)**INT(1.5D0+PYR(0))
21174 ENDIF
21175
21176C...Store flavours of scattering.
21177 MINT(13)=KFL1
21178 MINT(14)=KFL2
21179 MINT(15)=KFL1
21180 MINT(16)=KFL2
21181 MINT(21)=KFL3
21182 MINT(22)=KFL4
21183
21184C...Set flavours and mothers of scattering partons.
21185 K(N+1,1)=14
21186 K(N+2,1)=14
21187 K(N+3,1)=3
21188 K(N+4,1)=3
21189 K(N+1,2)=KFL1
21190 K(N+2,2)=KFL2
21191 K(N+3,2)=KFL3
21192 K(N+4,2)=KFL4
21193 K(N+1,3)=MINT(83)+1
21194 K(N+2,3)=MINT(83)+2
21195 K(N+3,3)=N+1
21196 K(N+4,3)=N+2
21197
21198C...Store colour connection indices.
21199 DO 320 J=1,2
21200 JC=J
21201 IF(KCS.EQ.-1) JC=3-J
21202 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21203 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21204 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21205 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21206 320 CONTINUE
21207
21208C...Store incoming and outgoing partons in their CM-frame.
21209 SHR=SQRT(TAU)*VINT(1)
21210 P(N+1,3)=0.5D0*SHR
21211 P(N+1,4)=0.5D0*SHR
21212 P(N+2,3)=-0.5D0*SHR
21213 P(N+2,4)=0.5D0*SHR
21214 P(N+3,5)=PYMASS(K(N+3,2))
21215 P(N+4,5)=PYMASS(K(N+4,2))
21216 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21217 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21218 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21219 P(N+4,4)=SHR-P(N+3,4)
21220 P(N+4,3)=-P(N+3,3)
21221
21222C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21223 PHI=PARU(2)*PYR(0)
21224 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21225
21226C...Set up default values before showers.
21227 MINT(31)=MINT(31)+1
21228 IPU1=N+1
21229 IPU2=N+2
21230 IPU3=N+3
21231 IPU4=N+4
21232 VINT(141)=VINT(41)
21233 VINT(142)=VINT(42)
21234 N=N+4
21235
21236C...Showering of initial state partons (optional).
21237C...Note: no showering of final state partons here; it comes later.
21238 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21239 MINT(51)=0
21240 ALAMSV=PARJ(81)
21241 PARJ(81)=PARP(72)
21242 NSAV=N
21243 DO 340 I=1,4
21244 DO 330 J=1,5
21245 KSAV(I,J)=K(N-4+I,J)
21246 PSAV(I,J)=P(N-4+I,J)
21247 330 CONTINUE
21248 340 CONTINUE
21249 CALL PYSSPA(IPU1,IPU2)
21250 PARJ(81)=ALAMSV
21251C...If shower failed then restore to situation before shower.
21252 IF(MINT(51).GE.1) THEN
21253 N=NSAV
21254 DO 360 I=1,4
21255 DO 350 J=1,5
21256 K(N-4+I,J)=KSAV(I,J)
21257 P(N-4+I,J)=PSAV(I,J)
21258 350 CONTINUE
21259 360 CONTINUE
21260 IPU1=N-3
21261 IPU2=N-2
21262 VINT(141)=VINT(41)
21263 VINT(142)=VINT(42)
21264 ENDIF
21265 ENDIF
21266
21267C...Keep track of loose colour ends and information on scattering.
21268 370 IMI(1,MINT(31),1)=IPU1
21269 IMI(2,MINT(31),1)=IPU2
21270 IMI(1,MINT(31),2)=0
21271 IMI(2,MINT(31),2)=0
21272 XMI(1,MINT(31))=VINT(141)
21273 XMI(2,MINT(31))=VINT(142)
21274 PT2MI(MINT(31))=VINT(54)
21275 IMISEP(MINT(31))=N
21276
21277C...Decide whether quarks in last scattering were valence, companion or
21278C...sea.
21279 DO 430 JS=1,2
21280 KFBEAM=MINT(10+JS)
21281 KFSBM=ISIGN(1,MINT(10+JS))
21282 IFL=K(IMI(JS,MINT(31),1),2)
21283 IMI(JS,MINT(31),2)=0
21284 IF (IABS(IFL).GT.6) GOTO 430
21285
21286C...Get PDFs at X and Q2 of the parton shower initiator for the
21287C...last scattering. At this point VINT(143:144) do not yet
21288C...include the scattered x values VINT(141:142).
21289 X=VINT(140+JS)/VINT(142+JS)
21290 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21291 Q2=PARP(62)**2
21292 ELSE
21293 Q2=VINT(54)
21294 ENDIF
21295C...Note: XPSVC = x*pdf.
21296 MINT(30)=JS
21297C.... ALICE
21298C.... Store side in MINT(124)
21299 MINT(124) = JS
21300C....
21301 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21302 SEA=XPSVC(IFL,-1)
21303 VAL=XPSVC(IFL,0)
21304 CMP=0D0
21305 DO 380 IVC=1,NVC(JS,IFL)
21306 CMP=CMP+XPSVC(IFL,IVC)
21307 380 CONTINUE
21308
21309C...Decide (Extra factor x cancels in the dvision).
21310 RVCS=PYR(0)*(SEA+VAL+CMP)
21311 IVNOW=1
21312 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21313C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21314 IVNOW=0
21315 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21316 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21317 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21318 IF(KFIVAL(JS,1).EQ.0) THEN
21319 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21320 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21321 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21322 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21323 ELSE
21324 DO 400 I1=1,NMI(JS)
21325 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21326 & IVNOW=IVNOW-1
21327 400 CONTINUE
21328 ENDIF
21329 IF(IVNOW.EQ.0) GOTO 390
21330C...Mark valence.
21331 IMI(JS,MINT(31),2)=0
21332C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21333 IF(KFIVAL(JS,1).EQ.0) THEN
21334 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21335 KFIVAL(JS,1)=IFL
21336 KFIVAL(JS,2)=-IFL
21337 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21338 KFIVAL(JS,1)=IFL
21339 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21340 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21341 ENDIF
21342 ENDIF
21343
21344 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21345C...If sea, add opposite sign companion parton. Store X and I.
21346 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21347 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21348C...Set pointer to companion
21349 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21350 ELSE
21351C...If companion, decide which one.
21352 CMPSUM=VAL+SEA
21353 ISEL=0
21354 410 ISEL=ISEL+1
21355 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21356 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21357C...Find original sea (anti-)quark:
21358 IASSOC=0
21359 DO 420 I1=1,NMI(JS)
21360 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21361 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21362 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21363 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21364 ENDIF
21365 420 CONTINUE
21366C...Change X to what associated companion had, so that the correct
21367C...amount of momentum can be subtracted from the companion sum below.
21368 X=XASSOC(JS,IFL,ISEL)
21369C...Mark companion read.
21370 XASSOC(JS,IFL,ISEL)=0D0
21371 ENDIF
21372 430 CONTINUE
21373
21374C...Global statistics.
21375 MINT(351)=MINT(351)+1
21376 VINT(351)=VINT(351)+PT
21377 IF (MINT(351).EQ.1) VINT(356)=PT
21378
21379C...Update remaining energy and other counters.
21380 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21381 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21382 MINT(51)=1
21383 RETURN
21384 ENDIF
21385 NMI(1)=NMI(1)+1
21386 NMI(2)=NMI(2)+1
21387 VINT(151)=VINT(151)+VINT(41)
21388 VINT(152)=VINT(152)+VINT(42)
21389 VINT(143)=VINT(143)-VINT(141)
21390 VINT(144)=VINT(144)-VINT(142)
21391
21392C...Iterate, with more interactions allowed.
21393 IF(MINT(31).LT.240) GOTO 240
21394 440 CONTINUE
21395
21396C...Restore saved quantities for hardest interaction.
21397 MINT(1)=ISUBSV
21398 MINT(13)=M13SV
21399 MINT(14)=M14SV
21400 MINT(15)=M15SV
21401 MINT(16)=M16SV
21402 MINT(21)=M21SV
21403 MINT(22)=M22SV
21404 DO 450 J=11,80
21405 VINT(J)=VINTSV(J)
21406 450 CONTINUE
21407 VINT(141)=V141SV
21408 VINT(142)=V142SV
21409
21410 ENDIF
21411
21412C...Format statements for printout.
21413 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21414 &'actions for MSTP(82) =',I2,' ******')
21415 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21416 &D9.2,' mb: rejected')
21417 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21418 &D9.2,' mb: accepted')
21419
21420 RETURN
21421 END
21422
21423C*********************************************************************
21424
21425C...PYMIHK
21426C...Finds left-behind remnant flavour content and hooks up
21427C...the colour flow between the hard scattering and remnants
21428
21429 SUBROUTINE PYMIHK
21430
21431C...Double precision and integer declarations.
21432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21433 IMPLICIT INTEGER(I-N)
21434 INTEGER PYK,PYCHGE,PYCOMP
21435C...The event record
21436 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21437C...Parameters
21438 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21439 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21440 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21441 COMMON/PYINT1/MINT(400),VINT(400)
21442C...The common block of dangling ends
21443 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21444 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21445 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21446 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21447C...Local variables
21448 PARAMETER (NERSIZ=4000)
21449 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21450 & ,MACCPT
21451 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21452 SAVE /PYCBLS/,/PYCTAG/
21453 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21454 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21455 DATA NERRPR/0/
21456 SAVE NERRPR
21457 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)
21458
21459C...Set up error checkers
21460 IBOOST=0
21461
21462C...Initialize colour arrays: MCO (Original) and MCT (New)
21463 DO 110 I=MINT(84)+1,NERSIZ
21464 DO 100 JC=1,2
21465 MCT(I,JC)=0
21466 MCO(I,JC)=0
21467 100 CONTINUE
21468C...Also zero colour tracing information, if existed.
21469 IF (I.LE.N) THEN
21470 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21471 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21472 ENDIF
21473 110 CONTINUE
21474
21475C...Initialize colour tag collapse arrays:
21476C...JCCO (Original) and JCCN (New).
21477 DO 130 MG=MINT(84)+1,NERSIZ
21478 DO 120 JC=1,2
21479 JCCO(MG,JC)=0
21480 JCCN(MG,JC)=0
21481 120 CONTINUE
21482 130 CONTINUE
21483
21484C...Zero gluon insertion array
21485 DO 150 IM=1,1000
21486 DO 140 J=1,3
21487 INSR(IM,J)=0
21488 140 CONTINUE
21489 150 CONTINUE
21490
21491C...Compute hard scattering system rapidities
21492 IF (MSTP(89).EQ.1) THEN
21493 DO 160 IM=1,240
21494 IF (IM.LE.MINT(31)) THEN
21495 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21496 ELSE
21497C...Set (unsigned) rapidity = 100 for beam remnant systems.
21498 YMI(IM)=100D0
21499 ENDIF
21500 160 CONTINUE
21501 ENDIF
21502
21503C...Treat each side separately
21504 DO 290 JS=1,2
21505
21506C...Initialize side.
21507 NG(JS)=0
21508 JV=0
21509 KFS=ISIGN(1,MINT(10+JS))
21510
21511C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21512 IF(KFIVAL(JS,1).EQ.0) THEN
21513 IF(MINT(10+JS).EQ.111) THEN
21514 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21515 KFIVAL(JS,2)=-KFIVAL(JS,1)
21516 ELSEIF(MINT(10+JS).EQ.22) THEN
21517 PYRKF=PYR(0)
21518 KFIVAL(JS,1)=1
21519 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21520 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21521 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21522 KFIVAL(JS,2)=-KFIVAL(JS,1)
21523 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21524 IF(PYR(0).GT.0.5D0) THEN
21525 KFIVAL(JS,1)=1
21526 KFIVAL(JS,2)=-3
21527 ELSE
21528 KFIVAL(JS,1)=3
21529 KFIVAL(JS,2)=-1
21530 ENDIF
21531 ENDIF
21532 ENDIF
21533
21534C...Initialize beam remnant sea and valence content flavour by flavour.
21535 NVSUM(JS)=0
21536 NBRTOT(JS)=0
21537 DO 210 JFA=1,6
21538C...Count up original number of JFA valence quarks and antiquarks.
21539 NVALQ=0
21540 NVALQB=0
21541 NSEA=0
21542 DO 170 J=1,3
21543 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21544 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21545 170 CONTINUE
21546 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21547C...Subtract kicked out valence and determine sea from flavour cons.
21548 DO 180 IM=1,NMI(JS)
21549 IFL = K(IMI(JS,IM,1),2)
21550 IFA = IABS(IFL)
21551 IFS = ISIGN(1,IFL)
21552 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21553C...Subtract K.O. valence quark from remainder.
21554 NVALQ=NVALQ-1
21555 JV=NVSUM(JS)-NVALQ-NVALQB
21556 IV(JS,JV)=IMI(JS,IM,1)
21557 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21558C...Subtract K.O. valence antiquark from remainder.
21559 NVALQB=NVALQB-1
21560 JV=NVSUM(JS)-NVALQ-NVALQB
21561 IV(JS,JV)=IMI(JS,IM,1)
21562 ELSEIF (IFA.EQ.JFA) THEN
21563C...Outside sea without companion: add opposite sea flavour inside.
21564 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21565 ENDIF
21566 180 CONTINUE
21567C...Check if space left in PYJETS for additional BR flavours
21568 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21569 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21570 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21571 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21572 MINT(51)=1
21573 RETURN
21574 ENDIF
21575C...Add required val+sea content to beam remnant.
21576 IF (NFLSUM.GT.0) THEN
21577 DO 200 IA=1,NFLSUM
21578C...Insert beam remnant quark as p.t. symbolic parton in ER.
21579 N=N+1
21580 DO 190 IX=1,5
21581 K(N,IX)=0
21582 P(N,IX)=0D0
21583 V(N,IX)=0D0
21584 190 CONTINUE
21585 K(N,1)=3
21586 K(N,2)=ISIGN(JFA,NSEA)
21587 IF (IA.LE.NVALQ) K(N,2)=JFA
21588 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21589 K(N,3)=MINT(83)+JS
21590C...Also update NMI, IMI, and IV arrays.
21591 NMI(JS)=NMI(JS)+1
21592 IMI(JS,NMI(JS),1)=N
21593 IMI(JS,NMI(JS),2)=-1
21594 IF (IA.LE.NVALQ+NVALQB) THEN
21595 IMI(JS,NMI(JS),2)=0
21596 JV=JV+1
21597 IV(JS,JV)=IMI(JS,NMI(JS),1)
21598 ENDIF
21599 200 CONTINUE
21600 ENDIF
21601 210 CONTINUE
21602
21603 IM=0
21604 220 IM=IM+1
21605 IF (IM.LE.NMI(JS)) THEN
21606 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21607 NG(JS)=NG(JS)+1
21608C...Add fictitious parent gluons for companion pairs.
21609 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21610C...Randomly assign companions to sea quarks which have none.
21611 IF (IMI(JS,IM,2).LT.0) THEN
21612 IMC=PYR(0)*NMI(JS)
21613 230 IMC=MOD(IMC,NMI(JS))+1
21614 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21615 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21616 IMI(JS, IM,2) = IMI(JS,IMC,1)
21617 IMI(JS,IMC,2) = IMI(JS, IM,1)
21618 ENDIF
21619C...Add fictitious parent gluon
21620 N=N+1
21621 DO 240 IX=1,5
21622 K(N,IX)=0
21623 P(N,IX)=0D0
21624 V(N,IX)=0D0
21625 240 CONTINUE
21626 K(N,1)=14
21627 K(N,2)=21
21628 K(N,3)=MINT(83)+JS
21629C...Set gluon (anti-)colour daughter pointers
21630 K(N,4)=IMI(JS, IM,1)
21631 K(N,5)=IMI(JS, IM,2)
21632C...Set quark (anti-)colour parent pointers
21633 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21634 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21635C...Add gluon to IMI
21636 NMI(JS)=NMI(JS)+1
21637 IMI(JS,NMI(JS),1)=N
21638 IMI(JS,NMI(JS),2)=0
21639 ENDIF
21640 GOTO 220
21641 ENDIF
21642
21643C...If incoming (anti-)baryon, insert inside (anti-)junction.
21644C...Set up initial v-v-j-v configuration. Otherwise set up
21645C...mesonic v-vbar configuration
21646 IF (IABS(MINT(10+JS)).GT.1000) THEN
21647C...Determine junction type (1: B=1 2: B=-1)
21648 ITJUNC(JS) = (3-KFS)/2
21649C...Insert junction.
21650 N=N+1
21651 DO 250 IX=1,5
21652 K(N,IX)=0
21653 P(N,IX)=0D0
21654 V(N,IX)=0D0
21655 250 CONTINUE
21656C...Set special junction codes:
21657 K(N,1)=42
21658 K(N,2)=88
21659C...Set parent to side.
21660 K(N,3)=MINT(83)+JS
21661 K(N,4)=ITJUNC(JS)*MSTU(5)
21662 K(N,5)=0
21663C...Connect valence quarks to junction.
21664 MOUT(JS)=0
21665 MANTI=ITJUNC(JS)-1
21666C...Set (anti)colour mother = junction.
21667 DO 260 JV=1,3
21668 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21669 & +MSTU(5)*N
21670C...Keep track of partons adjacent to junction:
21671 JST(JS,JV)=IV(JS,JV)
21672 260 CONTINUE
21673 ELSE
21674C...Mesons: set up initial q-qbar topology
21675 ITJUNC(JS)=0
21676 IF (K(IV(JS,1),2).GT.0) THEN
21677 IQ=IV(JS,1)
21678 IQBAR=IV(JS,2)
21679 ELSE
21680 IQ=IV(JS,2)
21681 IQBAR=IV(JS,1)
21682 ENDIF
21683 IV(JS,3)=0
21684 JST(JS,1)=IQ
21685 JST(JS,2)=IQBAR
21686 JST(JS,3)=0
21687 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21688 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21689C...Special for mesons. Insert gluon if BR empty.
21690 IF (NBRTOT(JS).EQ.0) THEN
21691 N=N+1
21692 DO 270 IX=1,5
21693 K(N,IX)=0
21694 P(N,IX)=0D0
21695 V(N,IX)=0D0
21696 270 CONTINUE
21697 K(N,1)=3
21698 K(N,2)=21
21699 K(N,3)=MINT(83)+JS
21700 K(N,4)=0
21701 K(N,5)=0
21702 NBRTOT(JS)=1
21703 NG(JS)=NG(JS)+1
21704C...Add gluon to IMI
21705 NMI(JS)=NMI(JS)+1
21706 IMI(JS,NMI(JS),1)=N
21707 IMI(JS,NMI(JS),2)=0
21708 ENDIF
21709 MOUT(JS)=0
21710 ENDIF
21711
21712C...Count up number of valence quarks outside BR.
21713 DO 280 JV=1,3
21714 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21715 & MOUT(JS)=MOUT(JS)+1
21716 280 CONTINUE
21717
21718 290 CONTINUE
21719
21720C...Now both sides have been prepared in an initial vvjv (baryonic) or
21721C...v(g)vbar (mesonic) configuration.
21722
21723C...Create colour line tags starting from initiators.
21724 NCT=0
21725 DO 320 IM=1,MINT(31)
21726C...Consider each side in turn.
21727 DO 310 JS=1,2
21728 I1=IMI(JS,IM,1)
21729 I2=IMI(3-JS,IM,1)
21730 DO 300 JCS=4,5
21731 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21732 & GOTO 300
21733 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21734
21735 KCS=JCS
21736 CALL PYCTTR(I1,KCS,I2)
21737 IF(MINT(51).NE.0) RETURN
21738
21739 300 CONTINUE
21740 310 CONTINUE
21741 320 CONTINUE
21742
21743 DO 340 JS=1,2
21744C...Create colour tags for beam remnant partons.
21745 DO 330 IM=MINT(31)+1,NMI(JS)
21746 IP=IMI(JS,IM,1)
21747 IF (K(IP,2).NE.21) THEN
21748 JC=(3-ISIGN(1,K(IP,2)))/2
21749 IF (MCT(IP,JC).EQ.0) THEN
21750 NCT=NCT+1
21751 MCT(IP,JC)=NCT
21752 ENDIF
21753 ELSE
21754C...Gluons
21755 ICD=K(IP,4)
21756 IAD=K(IP,5)
21757 IF (ICD.NE.0) THEN
21758C...Fictituous gluons just inherit from their quark daughters.
21759 ICC=MCT(ICD,1)
21760 IAC=MCT(IAD,2)
21761 ELSE
21762C...Real beam remnant gluons get their own colours
21763 ICC=NCT+1
21764 IAC=NCT+2
21765 NCT=NCT+2
21766 ENDIF
21767 MCT(IP,1)=ICC
21768 MCT(IP,2)=IAC
21769 ENDIF
21770 330 CONTINUE
21771 340 CONTINUE
21772
21773C...Create colour tags for colour lines which are detached from the
21774C...initial state.
21775
21776 DO 360 MQGST=1,2
21777 DO 350 I=MINT(84)+1,N
21778
21779C...Look for coloured string endpoint, or (later) leftover gluon.
21780 IF (K(I,1).NE.3) GOTO 350
21781 KC=PYCOMP(K(I,2))
21782 IF(KC.EQ.0) GOTO 350
21783 KQ=KCHG(KC,2)
21784 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21785
21786C...Pick up loose string end with no previous tag.
21787 KCS=4
21788 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21789 IF(MCT(I,KCS-3).NE.0) GOTO 350
21790
21791 CALL PYCTTR(I,KCS,I)
21792 IF(MINT(51).NE.0) RETURN
21793
21794 350 CONTINUE
21795 360 CONTINUE
21796
21797C...Store original colour tags
21798 DO 370 I=MINT(84)+1,N
21799 MCO(I,1)=MCT(I,1)
21800 MCO(I,2)=MCT(I,2)
21801 370 CONTINUE
21802
21803C...Iteratively add gluons to already existing string pieces, enforcing
21804C...various possible orderings, and rejecting insertions that would give
21805C...rise to singlet gluons.
21806C...<kappa tau> normalization.
21807 RM0=1.5D0
21808 MRETRY=0
21809 PARP80=PARP(80)
21810
21811C...Set up simplified kinematics.
21812C...Boost hard interaction systems.
21813 IBOOST=IBOOST+1
21814 DO 380 IM=1,MINT(31)
21815 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21816 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21817 380 CONTINUE
21818C...Assign preliminary beam remnant momenta.
21819 DO 390 I=MINT(53)+1,N
21820 JS=K(I,3)
21821 P(I,1)=0D0
21822 P(I,2)=0D0
21823 IF (K(I,2).NE.88) THEN
21824 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21825 P(I,3)=P(I,4)
21826 IF (JS.EQ.2) P(I,3)=-P(I,3)
21827 ELSE
21828C...Junctions are wildcards for the present.
21829 P(I,4)=0D0
21830 P(I,3)=0D0
21831 ENDIF
21832 390 CONTINUE
21833
21834C...Reset colour processing information.
21835 400 DO 410 I=MINT(84)+1,N
21836 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21837 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21838 410 CONTINUE
21839
21840 NCC=0
21841 DO 430 JS=1,2
21842C...If meson, without gluon in BR, collapse q-qbar colour tags:
21843 IF (ITJUNC(JS).EQ.0) THEN
21844 JC1=MCT(JST(JS,1),1)
21845 JC2=MCT(JST(JS,2),2)
21846 NCC=NCC+1
21847 JCCO(NCC,1)=MAX(JC1,JC2)
21848 JCCO(NCC,2)=MIN(JC1,JC2)
21849C...Collapse colour tags in event record
21850 DO 420 I=MINT(84)+1,N
21851 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21852 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21853 420 CONTINUE
21854 ENDIF
21855 430 CONTINUE
21856
21857 440 JS=1
21858 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21859 IF (NG(JS).GT.0) THEN
21860 NOPT=0
21861 RLOPT=1D9
21862C...Start at random gluon (optimizes speed for random attachments)
21863 NMGL=0
21864 IMGL=PYR(0)*NMI(JS)+1
21865 450 IMGL=MOD(IMGL,NMI(JS))+1
21866 NMGL=NMGL+1
21867C...Only loop through NMI once (with upper limit to save time)
21868 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21869 IGL = IMI(JS,IMGL,1)
21870C...If not gluon or if already connected, try next.
21871 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21872 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21873C...Now loop through all possible insertions of this gluon.
21874 NMP1=0
21875 IMP1=PYR(0)*NMI(JS)+1
21876 460 IMP1=MOD(IMP1,NMI(JS))+1
21877 NMP1=NMP1+1
21878 IF (IMP1.EQ.IMGL) GOTO 460
21879C...Only loop through NMI once (with upper limit to save time).
21880 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21881 IP1 = IMI(JS,IMP1,1)
21882C...Try both colour mother and colour anti-mother.
21883C...Randomly select which one to try first.
21884 NANTI=0
21885 MANTI=PYR(0)*2
21886 470 MANTI=MOD(MANTI+1,2)
21887 NANTI=NANTI+1
21888 IF (NANTI.LE.2) THEN
21889 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21890C...Reject if no appropriate mother (or if mother is fictitious
21891C...parent gluon.)
21892 IF (IP2.LE.0) GOTO 470
21893 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21894C...Also reject if this link has already been tried.
21895 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21896 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21897C...Set flag to indicate that this link has now been tried for this
21898C...gluon. IP2 may be junction, which has several mothers.
21899 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21900 IF (K(IP2,2).NE.88) THEN
21901 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21902 ENDIF
21903
21904C...JCG1: Original colour tag of gluon on IP1 side
21905C...JCG2: Original colour tag of gluon on IP2 side
21906C...JCP1: Original colour tag of IP1 on gluon side
21907C...JCP2: Original colour tag of IP2 on gluon side.
21908 JCG1=MCO(IGL,2-MANTI)
21909 JCG2=MCO(IGL,1+MANTI)
21910 JCP1=MCO(IP1,1+MANTI)
21911 JCP2=MCO(IP2,2-MANTI)
21912
21913 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21914C...Reject gluon attachments that give rise to singlet gluons.
21915 IF (MACCPT.EQ.0) GOTO 470
21916
21917C...Update colours
21918 JCG1=MCT(IGL,2-MANTI)
21919 JCG2=MCT(IGL,1+MANTI)
21920 JCP1=MCT(IP1,1+MANTI)
21921 JCP2=MCT(IP2,2-MANTI)
21922
21923C...Select whether to accept this insertion
21924 IF (MSTP(89).EQ.0) THEN
21925C...Random insertions: no measure.
21926 RL=1D0
21927C...For random ordering, we want to suppress beam remnant breakups
21928C...already at this point.
21929 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21930 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21931 NMP1=0
21932 NMGL=0
21933 GOTO 470
21934 ENDIF
21935 ELSEIF (MSTP(89).EQ.1) THEN
21936C...Rapidity ordering:
21937C...YGL = Rapidity of gluon.
21938 YGL=YMI(IMGL)
21939C...If fictitious gluon
21940 IF (YGL.EQ.100D0) THEN
21941 YGL=(3-2*JS)*100D0
21942 IDA1=MOD(K(IGL,4),MSTU(5))
21943 IDA2=MOD(K(IGL,5),MSTU(5))
21944 DO 480 IMT=1,NMI(JS)
21945C...Select (arbitrarily) the most central daughter.
21946 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21947 & THEN
21948 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21949 ENDIF
21950 480 CONTINUE
21951 ENDIF
21952C...YP1 = Rapidity IP1
21953 YP1=YMI(IMP1)
21954C...If fictitious gluon
21955 IF (YP1.EQ.100D0) THEN
21956 YP1=(3-2*JS)*YP1
21957 IDA1=MOD(K(IP1,4),MSTU(5))
21958 IDA2=MOD(K(IP1,5),MSTU(5))
21959 DO 490 IMT=1,NMI(JS)
21960C...Select (arbitrarily) the most central daughter.
21961 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21962 & THEN
21963 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21964 ENDIF
21965 490 CONTINUE
21966 ENDIF
21967C...YP2 = Rapidity of mother system
21968 IF (K(IP2,2).NE.88) THEN
21969 DO 500 IMT=1,NMI(JS)
21970 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21971 500 CONTINUE
21972C...If fictitious gluon
21973 IF (YP2.EQ.100D0) THEN
21974 YP2=(3-2*JS)*YP2
21975 IDA1=MOD(K(IP2,4),MSTU(5))
21976 IDA2=MOD(K(IP2,5),MSTU(5))
21977 DO 510 IMT=1,NMI(JS)
21978C...Select (arbitrarily) the most central daughter.
21979 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21980 & ) THEN
21981 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21982 ENDIF
21983 510 CONTINUE
21984 ENDIF
21985C...Assign (arbitrarily) 100D0 to junction also
21986 ELSE
21987 YP2=(3-2*JS)*100D0
21988 ENDIF
21989 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21990 ELSEIF (MSTP(89).EQ.2) THEN
21991C...Lambda ordering:
21992C...Compute lambda measure for this insertion.
21993 RL=1D0
21994 DO 520 IST=1,6
21995 ISTR(IST)=0
21996 520 CONTINUE
21997C...If IP2 is junction, not caught below.
21998 IF (JCP2.EQ.0) THEN
21999 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22000C...Anti-junction is colour endpoint et vv., always on JCG2.
22001 ISTR(5-ITJU)=IP2
22002 ENDIF
22003 DO 530 I=MINT(84)+1,N
22004 IF (K(I,1).LT.10) THEN
22005C...The new string pieces
22006 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22007 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22008 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22009 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22010 ENDIF
22011 530 CONTINUE
22012C...Also identify junctions as string endpoints.
22013 DO 540 I=MINT(84)+1,N
22014 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22015 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22016C...Find partons adjacent to junctions.
22017 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22018 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22019 & .EQ.0) ISTR(2) = ICMO
22020 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22021 & .EQ.0) ISTR(4) = ICMO
22022 ENDIF
22023 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22024 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22025 & .EQ.0) ISTR(1) = IAMO
22026 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22027 & .EQ.0) ISTR(3) = IAMO
22028 ENDIF
22029 540 CONTINUE
22030C...The old string piece
22031 ISTR(5)=ISTR(1+2*MANTI)
22032 ISTR(6)=ISTR(4-2*MANTI)
22033 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22034 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22035C...If one or more of the colour tags for this connection is/are still
22036C...dangling, skip this attempt for the time being.
22037 RL=1D6
22038 ELSE
22039 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22040 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22041 RL=LOG(RL)
22042 ENDIF
22043 ENDIF
22044C...Allow some breadth to speed things up.
22045 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22046 NOPT=NOPT+1
22047 ELSEIF (RL.GT.RLOPT) THEN
22048 GOTO 470
22049 ELSE
22050 NOPT=1
22051 RLOPT=RL
22052 ENDIF
22053C...INSR(NOPT,1)=Gluon colour mother
22054C...INSR(NOPT,2)=Gluon
22055C...INSR(NOPT,3)=Gluon anticolour mother
22056 IF (NOPT.GT.1000) GOTO 470
22057 INSR(NOPT,1+2*MANTI)=IP2
22058 INSR(NOPT,2)=IGL
22059 INSR(NOPT,3-2*MANTI)=IP1
22060 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22061 ENDIF
22062 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22063 ENDIF
22064C...Reset link test information.
22065 DO 550 I=MINT(84)+1,N
22066 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22067 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22068 550 CONTINUE
22069 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22070 ENDIF
22071C...Now we have a list of best gluon insertions, none of which cause
22072C...singlets to arise. If list is empty, try again a few times. Note:
22073C...this should never happen if we have a meson with a gluon inserted
22074C...in the beam remnant, since that breaks up the colour line.
22075 IF (NOPT.EQ.0) THEN
22076C...Abandon BR-g-BR suppression for retries. This is not serious, it
22077C...just means we happened to start with trying a bad sequence.
22078 PARP80=1D0
22079 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22080 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22081 MRETRY=MRETRY+1
22082 DO 590 JS=1,2
22083 IF (ITJUNC(JS).NE.0) THEN
22084 JST(JS,1)=IV(JS,1)
22085 JST(JS,2)=IV(JS,2)
22086 JST(JS,3)=IV(JS,3)
22087C...Reset valence quark parent pointers
22088 DO 560 I=MINT(53)+1,N
22089 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22090 560 CONTINUE
22091 MANTI=ITJUNC(JS)-1
22092C...Set (anti)colour mother = junction.
22093 DO 570 JV=1,3
22094 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22095 & +MSTU(5)*IJU
22096 570 CONTINUE
22097 ELSE
22098C...Same for mesons. JST unchanged, so needn't be restored.
22099 IQ=JST(JS,1)
22100 IQBAR=JST(JS,2)
22101 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22102 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22103 ENDIF
22104C...Also reset gluon parent pointers.
22105 NG(JS)=0
22106 DO 580 IM=1,NMI(JS)
22107 I=IMI(JS,IM,1)
22108 IF (K(I,2).EQ.21) THEN
22109 K(I,4)=MOD(K(I,4),MSTU(5))
22110 K(I,5)=MOD(K(I,5),MSTU(5))
22111 NG(JS)=NG(JS)+1
22112 ENDIF
22113 580 CONTINUE
22114 590 CONTINUE
22115C...Reset colour tags
22116 DO 600 I=MINT(84)+1,N
22117 MCT(I,1)=MCO(I,1)
22118 MCT(I,2)=MCO(I,2)
22119 600 CONTINUE
22120 GOTO 400
22121 ELSE
22122 IF(NERRPR.LT.5) THEN
22123 NERRPR=NERRPR+1
22124 CALL PYLIST(4)
22125 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22126 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22127 ENDIF
22128C...Kill event and start another.
22129 MINT(51)=1
22130 RETURN
22131 ENDIF
22132 ELSE
22133C...Select between insertions, suppressing insertions wholly in the BR.
22134 IIN=PYR(0)*NOPT+1
22135 610 IIN=MOD(IIN,NOPT)+1
22136 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22137 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22138 ENDIF
22139
22140C...Now we know which gluon to insert where. Colour tags in JCCO and
22141C...colour connection information should be updated, NG(JS) should be
22142C...counted down, and a new loop performed if there are still gluons
22143C...left on any side.
22144 ICM=INSR(IIN,1)
22145 IACM=INSR(IIN,3)
22146 IGL=INSR(IIN,2)
22147C...JCG : Original gluon colour tag
22148C...JCAG: Original gluon anticolour tag.
22149C...JCM : Original anticolour tag of gluon colour mother
22150C...JACM: Original colour tag of gluon anticolour mother
22151 JCG=MCO(IGL,1)
22152 JCM=MCO(ICM,2)
22153 JACG=MCO(IGL,2)
22154 JACM=MCO(IACM,1)
22155
22156 CALL PYMIHG(JACM,JACG,JCM,JCG)
22157 IF (MACCPT.EQ.0) THEN
22158 IF(NERRPR.LT.5) THEN
22159 NERRPR=NERRPR+1
22160 CALL PYLIST(4)
22161 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22162 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22163 ENDIF
22164C...Kill event and start another.
22165 MINT(51)=1
22166 RETURN
22167 ELSE
22168C...If everything went fine, store new JCCN in JCCO.
22169 NCC=NCC+1
22170 DO 620 ICC=1,NCC
22171 JCCO(ICC,1)=JCCN(ICC,1)
22172 JCCO(ICC,2)=JCCN(ICC,2)
22173 620 CONTINUE
22174 ENDIF
22175
22176C...One gluon attached is counted as equivalent to one end outside.
22177 MOUT(JS)=1
22178C...Set IGL colour mother = ICM.
22179 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22180C...Set ICM anticolour mother = IGL colour.
22181 IF (K(ICM,2).NE.88) THEN
22182 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22183 ELSE
22184C...If ICM is junction, just update JST array for now.
22185 DO 630 MSJ=1,3
22186 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22187 630 CONTINUE
22188 ENDIF
22189C...Set IGL anticolour mother = IACM.
22190 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22191C...Set IACM anticolour mother = IGL anticolour.
22192 IF (K(IACM,2).NE.88) THEN
22193 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22194 ELSE
22195C...If IACM is junction, just update JST array for now.
22196 DO 640 MSJ=1,3
22197 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22198 640 CONTINUE
22199 ENDIF
22200C...Count down # unconnected gluons.
22201 NG(JS)=NG(JS)-1
22202 ENDIF
22203 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22204
22205 DO 840 JS=1,2
22206C...Collapse fictitious gluons.
22207 DO 670 IGL=MINT(53)+1,N
22208 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22209 & K(IGL,1).EQ.14) THEN
22210 ICM=K(IGL,4)/MSTU(5)
22211 IAM=K(IGL,5)/MSTU(5)
22212 ICD=MOD(K(IGL,4),MSTU(5))
22213 IAD=MOD(K(IGL,5),MSTU(5))
22214C...Set gluon daughters pointing to gluon mothers
22215 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22216 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22217C...Set gluon mothers pointing to gluon daughters.
22218 IF (K(ICM,2).NE.88) THEN
22219 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22220 ELSE
22221C...Special case: mother=junction. Just update JST array for now.
22222 DO 650 MSJ=1,3
22223 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22224 650 CONTINUE
22225 ENDIF
22226 IF (K(IAM,2).NE.88) THEN
22227 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22228 ELSE
22229 DO 660 MSJ=1,3
22230 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22231 660 CONTINUE
22232 ENDIF
22233 ENDIF
22234 670 CONTINUE
22235
22236C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22237 IM=NMI(JS)+1
22238 680 IM=IM-1
22239 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22240 IF (IM.GT.MINT(31)) THEN
22241 NMI(JS)=NMI(JS)-1
22242 DO 690 IMR=IM,NMI(JS)
22243 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22244 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22245 690 CONTINUE
22246 GOTO 680
22247 ENDIF
22248
22249C...Finally, connect junction.
22250 IF (ITJUNC(JS).NE.0) THEN
22251 DO 700 I=MINT(53)+1,N
22252 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22253 700 CONTINUE
22254C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22255 NBRJQ =0
22256 NBRVQ =0
22257 DO 720 MSJ=1,3
22258 IDQ(MSJ)=0
22259C...Find jq with no glue inbetween inside beam remnant.
22260 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22261 & THEN
22262 NBRJQ=NBRJQ+1
22263C...Set IDQ = -I if q non-valence and = +I if q valence.
22264 IDQ(NBRJQ)=-JST(JS,MSJ)
22265 DO 710 JV=1,3
22266 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22267 IDQ(NBRJQ)=JST(JS,MSJ)
22268 NBRVQ=NBRVQ+1
22269 ENDIF
22270 710 CONTINUE
22271 ENDIF
22272 I12=MOD(MSJ+1,2)
22273 I45=5
22274 IF (MSJ.EQ.3) I45=4
22275 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22276 720 CONTINUE
22277
22278C...Check if diquark can be formed.
22279 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22280 & .GE.1)) THEN
22281C...If there is less than 2 valence quarks connected to junction
22282C...and MSTP(88)>1, use random non-valence quarks to fill up.
22283 IF (NBRVQ.LE.1) THEN
22284 NDIQ=NBRVQ
22285 730 JFLIP=NBRJQ*PYR(0)+1
22286 IF (IDQ(JFLIP).LT.0) THEN
22287 IDQ(JFLIP)=-IDQ(JFLIP)
22288 NDIQ=NDIQ+1
22289 ENDIF
22290 IF (NDIQ.LE.1) GOTO 730
22291 ENDIF
22292C...Place selected quarks first in IDQ, ordered in flavour.
22293 DO 740 JDQ=1,3
22294 IF (IDQ(JDQ).LE.0) THEN
22295 ITEMP1 = IDQ(JDQ)
22296 IDQ(JDQ)= IDQ(3)
22297 IDQ(3) = -ITEMP1
22298 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22299 ITEMP1 = IDQ(1)
22300 IDQ(1) = IDQ(2)
22301 IDQ(2) = ITEMP1
22302 ENDIF
22303 ENDIF
22304 740 CONTINUE
22305C...Choose diquark spin.
22306 IF (NBRVQ.EQ.2) THEN
22307C...If the selected quarks are both valence, we may use SU(6) rules
22308C...to figure out which spin the diquark has, by a subdivision of the
22309C...original beam hadron into the selected diquark system plus a kicked
22310C...out quark, IKO.
22311 JKO=6
22312 DO 760 JDQ=1,2
22313 DO 750 JV=1,3
22314 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22315 750 CONTINUE
22316 760 CONTINUE
22317 IKO=IV(JS,JKO)
22318 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22319 ELSE
22320C...If one or more of the selected quarks are not valence, we cannot use
22321C...SU(6) subdivisions of the original beam hadron. Instead, with the
22322C...flavours of the diquark already selected, we assume for now
22323C...50:50 spin-1:spin-0 (where spin-0 possible).
22324 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22325 IS=3
22326 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22327 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22328 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22329 ENDIF
22330
22331C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22332C...Note: third quark can per definition not also be valence,
22333C...therefore we can only do this if we are allowed to use sea quarks.
22334 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22335 NTRY=0
22336 780 NTRY=NTRY+1
22337 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22338 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22339 GOTO 780
22340 ELSEIF(NTRY.GT.100) THEN
22341C...If no baryon can be found, give up and form diquark.
22342 IDQ(3)=0
22343 GOTO 770
22344 ELSE
22345C...Replace junction by baryon.
22346 K(IJU,1)=1
22347 K(IJU,2)=KFBAR
22348 K(IJU,3)=MINT(83)+JS
22349 K(IJU,4)=0
22350 K(IJU,5)=0
22351 P(IJU,5)=PYMASS(KFBAR)
22352 DO 790 MSJ=1,3
22353C...Prepare removal of participating quarks from ER.
22354 K(JST(JS,MSJ),1)=-1
22355 790 CONTINUE
22356 ENDIF
22357 ELSE
22358C...If collapse to baryon not possible or not allowed, replace junction
22359C...by diquark. This way, collapsed gluons that were pointing at the
22360C...junction will now point (correctly) at diquark.
22361 MANTI=ITJUNC(JS)-1
22362 K(IJU,1)=3
22363 K(IJU,2)=KFDQ
22364 K(IJU,3)=MINT(83)+JS
22365 K(IJU,4)=0
22366 K(IJU,5)=0
22367 DO 800 MSJ=1,3
22368 IP=JST(JS,MSJ)
22369 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22370 K(IJU,4+MANTI)=0
22371 K(IJU,5-MANTI)=IP*MSTU(5)
22372 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22373 & MSTU(5)*IJU
22374 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22375 ELSE
22376C...Prepare removal of participating quarks from ER.
22377 K(IP,1)=-1
22378 ENDIF
22379 800 CONTINUE
22380 ENDIF
22381
22382C...Update so ER pointers to collapsed quarks
22383C...now go to collapsed object.
22384 DO 820 I=MINT(84)+1,N
22385 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22386 & .K(I,1).GT.0) THEN
22387 DO 810 ISID=4,5
22388 IMO=K(I,ISID)/MSTU(5)
22389 IDA=MOD(K(I,ISID),MSTU(5))
22390 IF (IMO.GT.0) THEN
22391 IF (K(IMO,1).EQ.-1) IMO=IJU
22392 ENDIF
22393 IF (IDA.GT.0) THEN
22394 IF (K(IDA,1).EQ.-1) IDA=IJU
22395 ENDIF
22396 K(I,ISID)=IDA+MSTU(5)*IMO
22397 810 CONTINUE
22398 ENDIF
22399 820 CONTINUE
22400 ENDIF
22401 ENDIF
22402
22403C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22404C...(this only happens for baryons, where we want to force the gluon
22405C...to sit next to the junction. Mesons handled above.)
22406 IF (NBRTOT(JS).EQ.0) THEN
22407 N=N+1
22408 DO 830 IX=1,5
22409 K(N,IX)=0
22410 P(N,IX)=0D0
22411 V(N,IX)=0D0
22412 830 CONTINUE
22413 IGL=N
22414 K(IGL,1)=3
22415 K(IGL,2)=21
22416 K(IGL,3)=MINT(83)+JS
22417 IF (ITJUNC(JS).NE.0) THEN
22418C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22419 JLEG=PYR(0)*NVSUM(JS)+1
22420 I1=JST(JS,JLEG)
22421 JST(JS,JLEG)=IGL
22422 JCT=MCT(I1,ITJUNC(JS))
22423 MCT(IGL,3-ITJUNC(JS))=JCT
22424 NCT=NCT+1
22425 MCT(IGL,ITJUNC(JS))=NCT
22426 MANTI=ITJUNC(JS)-1
22427 ELSE
22428C...Meson. Should not happen.
22429 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22430 IF(NERRPR.LT.5) THEN
22431 WRITE(MSTU(11),*) 'This should not have been possible!'
22432 CALL PYLIST(4)
22433 NERRPR=NERRPR+1
22434 ENDIF
22435 MINT(51)=1
22436 RETURN
22437 ENDIF
22438 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22439 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22440 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22441 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22442 IF (K(I2,2).NE.88) THEN
22443 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22444 ELSE
22445 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22446 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22447 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22448 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22449 ELSE
22450 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22451 ENDIF
22452 ENDIF
22453 ENDIF
22454 840 CONTINUE
22455
22456C...Remove collapsed quarks and junctions from ER and update IMI.
22457 CALL PYEDIT(11)
22458
22459C...Also update beam remnant part of IMI.
22460 NMI(1)=MINT(31)
22461 NMI(2)=MINT(31)
22462 DO 850 I=MINT(53)+1,N
22463 IF (K(I,1).LE.0) GOTO 850
22464C...Restore BR quark/diquark/baryon pointers in IMI.
22465 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22466 JS=K(I,3)-MINT(83)
22467 NMI(JS)=NMI(JS)+1
22468 IMI(JS,NMI(JS),1)=I
22469 IMI(JS,NMI(JS),2)=0
22470 ENDIF
22471 850 CONTINUE
22472
22473C...Restore companion information from collapsed gluons.
22474 DO 870 I=MINT(53)+1,N
22475 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22476 JS=K(I,3)-MINT(83)
22477 JCD=MOD(K(I,4),MSTU(5))
22478 JAD=MOD(K(I,5),MSTU(5))
22479 DO 860 IM=1,NMI(JS)
22480 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22481 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22482 860 CONTINUE
22483 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22484 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22485 ENDIF
22486 870 CONTINUE
22487
22488C...Renumber colour lines (since some have disappeared)
22489 JCT=0
22490 JCD=0
22491 880 JCT=JCT+1
22492 MFOUND=0
22493 I=MINT(84)
22494 890 I=I+1
22495 IF (I.EQ.N+1) THEN
22496 IF (MFOUND.EQ.0) JCD=JCD+1
22497 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22498 MCT(I,1)=JCT-JCD
22499 MFOUND=1
22500 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22501 MCT(I,2)=JCT-JCD
22502 MFOUND=1
22503 ENDIF
22504 IF (I.LE.N) GOTO 890
22505 IF (JCT.LT.NCT) GOTO 880
22506 NCT=JCT-JCD
22507
22508C...Reset hard interaction subsystems to their CM frames.
22509 IF (IBOOST.EQ.1) THEN
22510 DO 900 IM=1,MINT(31)
22511 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22512 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22513 900 CONTINUE
22514C...Zero beam remnant longitudinal momenta and energies
22515 DO 910 I=MINT(53)+1,N
22516 P(I,3)=0D0
22517 P(I,4)=0D0
22518 910 CONTINUE
22519 ELSE
22520 CALL PYERRM(9
22521 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22522C...Kill event and start another.
22523 MINT(51)=1
22524 RETURN
22525 ENDIF
22526
22527 9999 RETURN
22528 END
22529C*********************************************************************
22530
22531C...PYCTTR
22532C...Adapted from PYPREP.
22533C...Assigns LHA1 colour tags to coloured partons based on
22534C...K(I,4) and K(I,5) colour connection record.
22535C...KCS negative signifies that a previous tracing should be continued.
22536C...(in case the tag to be continued is empty, the routine exits)
22537C...Starts at I and ends at I or IEND.
22538C...Special considerations for systems with junctions.
22539C...Special: if IEND=-1, means trace this parton to its color partner,
22540C... then exit. If no partner found, exit with 0.
22541
22542 SUBROUTINE PYCTTR(I,KCS,IEND)
22543C...Double precision and integer declarations.
22544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22545 INTEGER PYK,PYCHGE,PYCOMP
22546C...Commonblocks.
22547 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22548 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22549 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22550 COMMON/PYINT1/MINT(400),VINT(400)
22551C...The common block of colour tags.
22552 COMMON/PYCTAG/NCT,MCT(4000,2)
22553 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22554 DATA NERRPR/0/
22555 SAVE NERRPR
22556
22557C...Skip if parton not existing or does not have KCS
22558 IF (K(I,1).LE.0) GOTO 120
22559 KC=PYCOMP(K(I,2))
22560 IF (KC.EQ.0) GOTO 120
22561 KQ=KCHG(KC,2)
22562 IF (KQ.EQ.0) GOTO 120
22563 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22564 & GOTO 120
22565
22566 IF (KCS.GT.0) THEN
22567 NCT=NCT+1
22568C...Set colour tag of first parton.
22569 MCT(I,KCS-3)=NCT
22570 NCS=NCT
22571 ELSE
22572 KCS=-KCS
22573 NCS=MCT(I,KCS-3)
22574 IF (NCS.EQ.0) GOTO 120
22575 ENDIF
22576
22577 IA=I
22578 NSTP=0
22579 100 NSTP=NSTP+1
22580 IF(NSTP.GT.4*N) THEN
22581 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22582 GOTO 120
22583 ENDIF
22584
22585C...Finished if reached final-state triplet.
22586 IF(K(IA,1).EQ.3) THEN
22587 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22588 ENDIF
22589
22590C...Also finished if reached junction.
22591 IF(K(IA,1).EQ.42) THEN
22592 GOTO 120
22593 ENDIF
22594
22595C...GOTO next parton in colour space.
22596 110 IB=IA
22597C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22598 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22599 & .NE.0) THEN
22600 IA=MOD(K(IB,KCS),MSTU(5))
22601 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22602 MREV=0
22603 ELSE
22604C...If KCS mother traced or KCS mother nonexistent, switch colour.
22605 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22606 & MSTU(5)).EQ.0) THEN
22607 KCS=9-KCS
22608 NCT=NCT+1
22609 NCS=NCT
22610C...Assign new colour tag on other side of old parton.
22611 MCT(IB,KCS-3)=NCT
22612 ENDIF
22613C...Goto (new) KCS mother, set mother traced tag
22614 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22615 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22616 MREV=1
22617 ENDIF
22618 IF(IA.LE.0.OR.IA.GT.N) THEN
22619 IF (IEND.EQ.-1) THEN
22620 IEND=0
22621 GOTO 120
22622 ENDIF
22623 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22624 IF(NERRPR.LT.5) THEN
22625 write(*,*) 'began at ',I
22626 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22627 & ' NCS=',NCS,' MREV=',MREV
22628 CALL PYLIST(4)
22629 NERRPR=NERRPR+1
22630 ENDIF
22631 MINT(51)=1
22632 RETURN
22633 ENDIF
22634 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22635 & MSTU(5)).EQ.IB) THEN
22636 IF(MREV.EQ.1) KCS=9-KCS
22637 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22638C...Set KSC mother traced tag for IA
22639 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22640 ELSE
22641 IF(MREV.EQ.0) KCS=9-KCS
22642 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22643C...Set KCS daughter traced tag for IA
22644 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22645 ENDIF
22646C...Assign new colour tag
22647 MCT(IA,KCS-3)=NCS
22648C...Finish if IEND=-1 and found final-state color partner
22649 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22650 IEND=IA
22651 GOTO 120
22652 ENDIF
22653 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22654
22655 120 RETURN
22656 END
22657
22658*********************************************************************
22659
22660C...PYMIHG
22661C...Collapse JCP1 and connecting tags to JCG1.
22662C...Collapse JCP2 and connecting tags to JCG2.
22663
22664 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22665C...Double precision and integer declarations.
22666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22667 IMPLICIT INTEGER(I-N)
22668 INTEGER PYK,PYCHGE,PYCOMP
22669C...The event record
22670 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22671C...Parameters
22672 COMMON/PYINT1/MINT(400),VINT(400)
22673 SAVE /PYJETS/,/PYINT1/
22674C...Local variables
22675 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22676 COMMON /PYCTAG/NCT,MCT(4000,2)
22677 SAVE /PYCBLS/,/PYCTAG/
22678
22679C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22680C...in temporary tag collapse array JCCN. Only break up one connection.
22681 MACCPT=1
22682 MCLPS=0
22683 DO 100 ICC=1,NCC
22684 JCCN(ICC,1)=JCCO(ICC,1)
22685 JCCN(ICC,2)=JCCO(ICC,2)
22686C...If there was a mother, it was previously connected to JCP1.
22687C...Should be changed to JCP2.
22688 IF (MCLPS.EQ.0) THEN
22689 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22690 & ,JCP2)) THEN
22691 JCCN(ICC,1)=MAX(JCG2,JCP2)
22692 JCCN(ICC,2)=MIN(JCG2,JCP2)
22693 MCLPS=1
22694 ENDIF
22695 ENDIF
22696 100 CONTINUE
22697C...Also collapse colours on JCP1 side of JCG1
22698 IF (JCP1.NE.0) THEN
22699 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22700 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22701 ELSE
22702 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22703 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22704 ENDIF
22705
22706C...Initialize event record colour tag array MCT array to MCO.
22707 DO 110 I=MINT(84)+1,N
22708 MCT(I,1)=MCO(I,1)
22709 MCT(I,2)=MCO(I,2)
22710 110 CONTINUE
22711
22712C...Collapse tags:
22713C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22714C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22715C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22716C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22717 DO 160 IS=1,4
22718C...Skip if junction.
22719 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22720C...Define starting point in tag space.
22721C...JCA = previous tag
22722C...JCO = present tag
22723C...JCN = new tag
22724 IF (MOD(IS,2).EQ.1) THEN
22725 JCO=JCP1
22726 JCN=JCG1
22727 JCALL=JCG1
22728 ELSEIF (MOD(IS,2).EQ.0) THEN
22729 JCO=JCP2
22730 JCN=JCG2
22731 JCALL=JCG2
22732 ENDIF
22733 ITRACE=0
22734 120 ITRACE=ITRACE+1
22735 IF (ITRACE.GT.1000) THEN
22736C...NB: Proper error message should be defined here.
22737 CALL PYERRM(14
22738 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22739 MINT(57)=MINT(57)+1
22740 MINT(51)=1
22741 RETURN
22742 ENDIF
22743C...Collapse all JCN tags to JCALL
22744 DO 130 I=MINT(84)+1,N
22745 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22746 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22747 130 CONTINUE
22748C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22749 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22750 JCA=JCN
22751 JCN=JCO
22752 ELSE
22753 JCA=JCO
22754 JCO=JCN
22755 ENDIF
22756C...If possible, step from JCO to new tag JCN not equal to JCA.
22757 DO 140 ICC=1,NCC+1
22758 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22759 & JCCN(ICC,2)
22760 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22761 & JCCN(ICC,1)
22762 140 CONTINUE
22763C...Iterate if new colour was arrived at, but don't go in circles.
22764 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22765C...Change all JCN tags in MCO to JCALL in MCT.
22766 DO 150 I=MINT(84)+1,N
22767 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22768 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22769C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22770 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22771 & .NE.0) MACCPT=0
22772 150 CONTINUE
22773 160 CONTINUE
22774
22775 DO 200 JCL=NCT,1,-1
22776 JCA=0
22777 JCN=JCL
22778 170 JCO=JCN
22779 DO 180 ICC=1,NCC+1
22780 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22781 & =JCCN(ICC,2)
22782 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22783 & =JCCN(ICC,1)
22784 180 CONTINUE
22785C...Overpaint all JCN with JCL
22786 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22787 DO 190 I=MINT(84)+1,N
22788 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22789 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22790C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22791 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22792 & .NE.0) MACCPT=0
22793 190 CONTINUE
22794 JCA=JCO
22795 GOTO 170
22796 ENDIF
22797 200 CONTINUE
22798
22799 RETURN
22800 END
22801
22802C*********************************************************************
22803
22804C...PYMIRM
22805C...Picks primordial kT and shares longitudinal momentum among
22806C...beam remnants.
22807
22808 SUBROUTINE PYMIRM
22809
22810C...Double precision and integer declarations.
22811 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22812 IMPLICIT INTEGER(I-N)
22813 INTEGER PYK,PYCHGE,PYCOMP
22814C...The event record
22815 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22816C...Parameters
22817 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22818 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22819 COMMON/PYINT1/MINT(400),VINT(400)
22820C...The common block of colour tags.
22821 COMMON/PYCTAG/NCT,MCT(4000,2)
22822C...The common block of dangling ends
22823 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22824 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22825 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22826 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22827C...Local variables
22828 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22829C...W(I,J)| J=0 | 1 | 2 |
22830C... I=0 | Wrem**2 | W+ | W- |
22831C... 1 | W1**2 | W1+ | W1- |
22832C... 2 | W2**2 | W2+ | W2- |
22833C...4-product
22834 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)
22835C...Tentative parametrization of <kT> as a function of Q.
22836 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22837C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22838C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22839 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22840C...Lambda kinematic function.
22841 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22842
22843C...Beginning and end of beam remnant partons
22844 NOUT=MINT(53)
22845 ISUB=MINT(1)
22846
22847C...Loopback point if kinematic choices gives impossible configuration.
22848 NTRY=0
22849 100 NTRY=NTRY+1
22850
22851C...Assign kT values on each side separately.
22852 DO 180 JS=1,2
22853
22854C...First zero all kT on this side. Skip if no kT to generate.
22855 DO 110 IM=1,NMI(JS)
22856 P(IMI(JS,IM,1),1)=0D0
22857 P(IMI(JS,IM,1),2)=0D0
22858 110 CONTINUE
22859 IF(MSTP(91).LE.0) GOTO 180
22860
22861C...Now assign kT to each (non-collapsed) parton in IMI.
22862 DO 170 IM=1,NMI(JS)
22863 I=IMI(JS,IM,1)
22864C...Select kT according to truncated gaussian or 1/kt6 tails.
22865C...For first interaction, either use rms width = PARP(91) or fitted.
22866 IF (IM.EQ.1) THEN
22867 SIGMA=PARP(91)
22868 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22869 Q=SQRT(PT2MI(IM))
22870 SIGMA=SIGPT(Q)
22871 ENDIF
22872 ELSE
22873C...For subsequent interactions and BR partons use fragmentation width.
22874 SIGMA=PARJ(21)
22875 ENDIF
22876 PHI=PARU(2)*PYR(0)
22877 PT=0D0
22878 IF(NTRY.LE.100) THEN
22879 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22880 PT=GETPT(Q,SIGMA)
22881 PTX=PT*COS(PHI)
22882 PTY=PT*SIN(PHI)
22883 ELSEIF (MSTP(91).EQ.2) THEN
22884 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22885 & 'available, using MSTP(91)=1.')
22886 CALL PYGIVE('MSTP(91)=1')
22887 GOTO 111
22888 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22889C...Use distribution with kt**6 tails, rms width = PARP(91).
22890 EPS=SQRT(3D0/2D0)*SIGMA
22891C...Generate PTX and PTY separately, each propto 1/KT**6
22892 DO 119 IXY=1,2
22893C...Decide which interval to try
22894 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22895 IF (PYR(0).LT.P12) THEN
22896C...Use flat approx with accept/reject up to EPS.
22897 PT=PYR(0)*EPS
22898 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22899 IF (PYR(0).GT.WT) GOTO 112
22900 ELSE
22901C...Above EPS, use 1/kt**6 approx with accept/reject.
22902 PT=EPS/(PYR(0)**(1D0/5D0))
22903 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22904 IF (PYR(0).GT.WT) GOTO 112
22905 ENDIF
22906 MSIGN=1
22907 IF (PYR(0).GT.0.5D0) MSIGN=-1
22908 IF (IXY.EQ.1) PTX=MSIGN*PT
22909 IF (IXY.EQ.2) PTY=MSIGN*PT
22910 119 CONTINUE
22911 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22912 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22913 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22914 ENDIF
22915C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22916 PT=SQRT(PTX**2+PTY**2)
22917 WT=1D0
22918 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22919 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22920 PTX=PTX*WT
22921 PTY=PTY*WT
22922 PT=SQRT(PTX**2+PTY**2)
22923 ENDIF
22924
22925 P(I,1)=P(I,1)+PTX
22926 P(I,2)=P(I,2)+PTY
22927
22928C...Compensation kicks, with varying degree of local anticorrelations.
22929 MCORR=MSTP(90)
22930 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22931 PTCX=-PTX/(NMI(JS)-1)
22932 PTCY=-PTY/(NMI(JS)-1)
22933 IF(ISUB.EQ.95) THEN
22934 PTCX=-PTX/(NMI(JS)-2)
22935 PTCY=-PTY/(NMI(JS)-2)
22936 ENDIF
22937 DO 120 IMC=1,NMI(JS)
22938 IF (IMC.EQ.IM) GOTO 120
22939 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22940 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22941 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22942 120 CONTINUE
22943 ELSEIF (MCORR.GE.1) THEN
22944 DO 140 MSID=4,5
22945 NNXT(MSID-3)=0
22946C...Count up # of neighbours on either side
22947 IMO=I
22948 130 IMO=K(IMO,MSID)/MSTU(5)
22949 IF (IMO.EQ.0) GOTO 140
22950 NNXT(MSID-3)=NNXT(MSID-3)+1
22951C...Stop at quarks and junctions
22952 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22953 140 CONTINUE
22954C...How should compensation be shared when unequal numbers on the
22955C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22956 NSUM=NNXT(1)+NNXT(2)
22957 T1=0
22958 DO 160 MSID=4,5
22959C...Total momentum to be compensated on this side
22960 IF (NNXT(MSID-3).EQ.0) GOTO 160
22961 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22962 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22963C...RS: compensation supression factor as we go out from parton I.
22964C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22965C...since (for now) MSTP(90) provides enough variability.
22966 RS=0.5D0
22967 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22968 IMO=I
22969 150 IDA=IMO
22970 IMO=K(IMO,MSID)/MSTU(5)
22971 IF (IMO.EQ.0) GOTO 160
22972 FAC=FAC*RS
22973 IF (K(IMO,2).NE.88) THEN
22974 P(IMO,1)=P(IMO,1)+FAC*PTCX
22975 P(IMO,2)=P(IMO,2)+FAC*PTCY
22976 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22977C...If we reach junction, divide out the kT that would have been
22978C...assigned to the junction on each of its other legs.
22979 ELSE
22980 L1=MOD(K(IMO,4),MSTU(5))
22981 L2=K(IMO,5)/MSTU(5)
22982 L3=MOD(K(IMO,5),MSTU(5))
22983 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22984 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22985 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22986 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22987 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22988 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22989 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22990 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
22991 ENDIF
22992
22993 160 CONTINUE
22994 ENDIF
22995 170 CONTINUE
22996C...End assignment of kT values to initiators and remnants.
22997 180 CONTINUE
22998
22999C...Check kinematics constraints for non-BR partons.
23000 DO 190 IM=1,MINT(31)
23001 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23002 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23003 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23004 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23005 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23006 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23007 IF(NTRY.GE.100) THEN
23008C...Kill this event and start another.
23009 CALL PYERRM(1,
23010 & '(PYMIRM:) No consistent (x,kT) sets found')
23011 MINT(51)=1
23012 RETURN
23013 ENDIF
23014 GOTO 100
23015 ENDIF
23016 190 CONTINUE
23017
23018C...Calculate W+ and W- available for combined remnant system.
23019 W(0,1)=VINT(1)
23020 W(0,2)=VINT(1)
23021 DO 200 IM=1,MINT(31)
23022 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23023 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23024 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23025 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23026 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23027 200 CONTINUE
23028C...Also store Wrem**2 = W+ * W-
23029 W(0,0)=W(0,1)*W(0,2)
23030
23031 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23032 IF(NTRY.GE.100) THEN
23033C...Kill this event and start another.
23034 CALL PYERRM(1,
23035 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23036 MINT(51)=1
23037 RETURN
23038 ENDIF
23039 GOTO 100
23040 ENDIF
23041
23042C...Assign unscaled x values to partons/hadrons in each of the
23043C...beam remnants and calculate unscaled W+ and W- from them.
23044 NTRYX=0
23045 210 NTRYX=NTRYX+1
23046 DO 280 JS=1,2
23047 W(JS,1)=0D0
23048 W(JS,2)=0D0
23049 DO 270 IM=MINT(31)+1,NMI(JS)
23050 I=IMI(JS,IM,1)
23051 KF=K(I,2)
23052 KFA=IABS(KF)
23053 ICOMP=IMI(JS,IM,2)
23054
23055C...Skip collapsed gluons and junctions. Reset.
23056 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23057 IF (KFA.EQ.88) GOTO 270
23058 X=0D0
23059 IVALQ(1)=0
23060 IVALQ(2)=0
23061 ICOMQ(1)=0
23062 ICOMQ(2)=0
23063
23064C...If gluon then only beam remnant, so takes all.
23065 IF(KFA.EQ.21) THEN
23066 X=1D0
23067C...If valence quark then use parametrized valence distribution.
23068 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23069 IVALQ(1)=KF
23070C...If companion quark then derive from companion x.
23071 ELSEIF(KFA.LE.6) THEN
23072 ICOMQ(1)=ICOMP
23073C...If valence diquark then use two parametrized valence distributions.
23074 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23075 & ICOMP.EQ.0) THEN
23076 IVALQ(1)=ISIGN(KFA/1000,KF)
23077 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23078C...If valence+sea diquark then combine valence + companion choices.
23079 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23080 & ICOMP.LT.MSTU(5)) THEN
23081 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23082 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23083 ELSE
23084 IVALQ(1)=ISIGN(KFA/1000,KF)
23085 ENDIF
23086 ICOMQ(1)=ICOMP
23087C...Extra code: workaround for diquark made out of two sea
23088C...quarks, but where not (yet) ICOMP > MSTU(5).
23089 DO 220 IM1=1,MINT(31)
23090 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23091 ICOMQ(2)=IMI(JS,IM1,1)
23092 IVALQ(1)=0
23093 ENDIF
23094 220 CONTINUE
23095C...If sea diquark then sum of two derived from companion x.
23096 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23097 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23098 ICOMQ(2)=ICOMP/MSTU(5)
23099C...If meson or baryon then use fragmentation function.
23100C...Somewhat arbitrary split into old and new flavour, but OK normally.
23101 ELSE
23102 KFL3=MOD(KFA/10,10)
23103 IF(MOD(KFA/1000,10).EQ.0) THEN
23104 KFL1=MOD(KFA/100,10)
23105 ELSE
23106 KFL1=MOD(KFA,10000)-10*KFL3-1
23107 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23108 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23109 ENDIF
23110 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23111 CALL PYZDIS(KFL1,KFL3,PR,X)
23112 ENDIF
23113
23114 DO 260 IQ=1,2
23115C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23116C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23117C...In other baryons combine u and d from proton appropriately.
23118 IF(IVALQ(IQ).NE.0) THEN
23119 NVAL=0
23120 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23121 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23122 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23123C...Meson.
23124 IF(KFIVAL(JS,3).EQ.0) THEN
23125 MDU=0
23126C...Baryon with three identical quarks: mix u and d forms.
23127 ELSEIF(NVAL.EQ.3) THEN
23128 MDU=INT(PYR(0)+5D0/3D0)
23129C...Baryon, one of two identical quarks: u form.
23130 ELSEIF(NVAL.EQ.2) THEN
23131 MDU=2
23132C...Baryon with two identical quarks, but not the one picked: d form.
23133 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23134 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23135 MDU=1
23136C...Baryon with three nonidentical quarks: mix u and d forms.
23137 ELSE
23138 MDU=INT(PYR(0)+5D0/3D0)
23139 ENDIF
23140 XPOW=0.8D0
23141 IF(MDU.EQ.1) XPOW=3.5D0
23142 IF(MDU.EQ.2) XPOW=2D0
23143 230 XX=PYR(0)**2
23144 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23145 X=X+XX
23146 ENDIF
23147
23148C...Calculation of x of companion quark.
23149 IF(ICOMQ(IQ).NE.0) THEN
23150 XCOMP=1D-4
23151 DO 240 IM1=1,MINT(31)
23152 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23153 240 CONTINUE
23154 NPOW=MAX(0,MIN(4,MSTP(87)))
23155 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23156 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23157 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23158 IF(CORR.LT.PYR(0)) GOTO 250
23159 X=X+XX
23160 ENDIF
23161 260 CONTINUE
23162
23163C...Optionally enchance x of composite systems (e.g. diquarks)
23164 IF (KFA.GT.100) X=PARP(79)*X
23165
23166C...Store x. Also calculate light cone energies of each system.
23167 XMI(JS,IM)=X
23168 W(JS,JS)=W(JS,JS)+X
23169 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23170 270 CONTINUE
23171 W(JS,JS)=W(JS,JS)*W(0,JS)
23172 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23173 W(JS,0)=W(JS,1)*W(JS,2)
23174 280 CONTINUE
23175
23176C...Check W1 W2 < Wrem (can be done before rescaling, since W
23177C...insensitive to global rescalings of the BR x values).
23178 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23179 & THEN
23180 GOTO 210
23181 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23182 GOTO 100
23183 ELSEIF (NTRYX.GT.100) THEN
23184 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23185 MINT(57)=MINT(57)+1
23186 MINT(51)=1
23187 RETURN
23188 ENDIF
23189
23190C...Compute x rescaling factors
23191 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23192 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23193 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23194
23195 IF (R1.LT.0.OR.R2.LT.0) THEN
23196 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23197 MINT(57)=MINT(57)+1
23198 MINT(51)=1
23199 ENDIF
23200
23201C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23202 W(1,1)=W(1,1)*R1
23203 W(1,2)=W(1,2)/R1
23204 W(2,1)=W(2,1)/R2
23205 W(2,2)=W(2,2)*R2
23206
23207C...Rescale BR x values.
23208 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23209 XMI(1,IM)=XMI(1,IM)*R1
23210 XMI(2,IM)=XMI(2,IM)*R2
23211 290 CONTINUE
23212
23213C...Now we have a consistent set of x and kT values.
23214C...First set up the initiators and their daughters correctly.
23215 DO 300 IM=1,MINT(31)
23216 I1=IMI(1,IM,1)
23217 I2=IMI(2,IM,1)
23218 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23219 & (P(I1,2)+P(I2,2))**2
23220 PT12=P(I1,1)**2+P(I1,2)**2
23221 PT22=P(I2,1)**2+P(I2,2)**2
23222C...p_z
23223 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23224 P(I2,3)=-P(I1,3)
23225C...Energies (masses should be zero at this stage)
23226 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23227 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23228
23229C...Transverse 12 system initiator velocity:
23230 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23231 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23232C...Boost to overall initiator system rest frame
23233 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23234 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23235
23236C...Compute phi,theta coordinates of I1 and rotate z axis.
23237 PHI=PYANGL(P(I1,1),P(I1,2))
23238 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23239 IMIN=IMISEP(IM-1)+1
23240C...(include documentation lines if MI = 1)
23241 IF (IM.EQ.1) IMIN=MINT(83)+5
23242 IMAX=IMISEP(IM)
23243C...Rotate entire system in phi
23244 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23245C...Only rotate 12 system in theta
23246 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23247 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23248
23249C...Now boost entire system back to LAB
23250 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23251 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23252 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23253
23254 300 CONTINUE
23255
23256
23257C...For the beam remnant partons/hadrons, we only need to set pz and E.
23258 DO 320 JS=1,2
23259 DO 310 IM=MINT(31)+1,NMI(JS)
23260 I=IMI(JS,IM,1)
23261C...Skip collapsed gluons and junctions.
23262 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23263 IF (KFA.EQ.88) GOTO 310
23264 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23265 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23266 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23267 IF (JS.EQ.2) P(I,3)=-P(I,3)
23268 310 CONTINUE
23269 320 CONTINUE
23270
23271
23272C...Documentation lines
23273 DO 340 JS=1,2
23274 IN=MINT(83)+JS+2
23275 IO=IMI(JS,1,1)
23276 K(IN,1)=21
23277 K(IN,2)=K(IO,2)
23278 K(IN,3)=MINT(83)+JS
23279 K(IN,4)=0
23280 K(IN,5)=0
23281 DO 330 J=1,5
23282 P(IN,J)=P(IO,J)
23283 V(IN,J)=V(IO,J)
23284 330 CONTINUE
23285 MCT(IN,1)=MCT(IO,1)
23286 MCT(IN,2)=MCT(IO,2)
23287 340 CONTINUE
23288
23289C...Final state colour reconnections.
23290 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23291
23292C...Number of colour tags for which a recoupling will be tried.
23293 NTOT=NCT
23294C...Number of recouplings to try
23295 MINT(34)=0
23296 NRECP=0
23297 NITER=0
23298 350 NRECP=MINT(34)
23299 NITER=NITER+1
23300 IITER=0
23301 360 IITER=IITER+1
23302 IF (IITER.LE.PARP(78)*NTOT) THEN
23303C...Select two colour tags at random
23304C...NB: jj strings do not have colour tags assigned to them,
23305C...thus they are as yet not affected by anything done here.
23306 JCT=PYR(0)*NCT+1
23307 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23308 IJ1=0
23309 IJ2=0
23310 IK1=0
23311 IK2=0
23312C...Find final state partons with this (anti)colour
23313 DO 370 I=MINT(84)+1,N
23314 IF (K(I,1).EQ.3) THEN
23315 IF (MCT(I,1).EQ.JCT) IJ1=I
23316 IF (MCT(I,2).EQ.JCT) IJ2=I
23317 IF (MCT(I,1).EQ.KCT) IK1=I
23318 IF (MCT(I,2).EQ.KCT) IK2=I
23319 ENDIF
23320 370 CONTINUE
23321C...Only consider recouplings not involving junctions for now.
23322 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23323
23324 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23325 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23326 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23327 MCT(IJ2,2)=KCT
23328 MCT(IK2,2)=JCT
23329C...Count up number of reconnections
23330 MINT(34)=MINT(34)+1
23331 ENDIF
23332 IF (MINT(34).LE.1000) THEN
23333 GOTO 360
23334 ELSE
23335 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23336 GOTO 380
23337 ENDIF
23338 ENDIF
23339 IF (NRECP.LT.MINT(34)) GOTO 350
23340
23341C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23342 380 MINT(33)=1
23343
23344 RETURN
23345 END
23346
23347C*********************************************************************
23348
23349C...PYFSCR
23350C...Performs colour annealing.
23351C...MSTP(95) : CR Type
23352C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23353C... = 2 : Type I(no gg loops); hadron-hadron only
23354C... = 3 : Type I(no gg loops); all beams
23355C... = 4 : Type II(gg loops) ; hadron-hadron only
23356C... = 5 : Type II(gg loops) ; all beams
23357C... = 6 : Type S ; hadron-hadron only
23358C... = 7 : Type S ; all beams
23359C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23360C...Type S is driven by starting only from free triplets, not octets.
23361C...A string piece remains unchanged with probability
23362C... PKEEP = (1-PARP(78))**N
23363C...This scaling corresponds to each string piece having to go through
23364C...N other ones, each with probability PARP(78) for reconnection, where
23365C...N is here chosen simply as the number of multiple interactions,
23366C...for a rough scaling with the general level of activity.
23367
23368 SUBROUTINE PYFSCR(IP)
23369C...Double precision and integer declarations.
23370 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23371 INTEGER PYK,PYCHGE,PYCOMP
23372C...Commonblocks.
23373 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23374 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23375 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23376 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23377 COMMON/PYINT1/MINT(400),VINT(400)
23378C...The common block of colour tags.
23379 COMMON/PYCTAG/NCT,MCT(4000,2)
23380 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23381 &/PYPARS/
23382C...MCN: Temporary storage of new colour tags
23383 INTEGER MCN(4000,2)
23384C...Arrays for storing color string lengths
23385 INTEGER ICR(4000),MSCR(4000)
23386 INTEGER IOPT(4000)
23387 DOUBLE PRECISION RLOPTC(4000)
23388
23389C...Function to give four-product.
23390 FOUR(I,J)=P(I,4)*P(J,4)
23391 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23392
23393C...Check valid range of MSTP(95), local copy
23394 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23395 MSTP95=MOD(MSTP(95),10)
23396C...Set whether CR allowed inside resonance systems or not
23397C...(not implemented yet)
23398C MRESCR=1
23399C IF (MSTP(95).GE.10) MRESCR=0
23400
23401C...Check whether colour tags already defined
23402 IF (MINT(33).EQ.0) THEN
23403C...Erase any existing colour tags for this event
23404 DO 100 I=1,N
23405 MCT(I,1)=0
23406 MCT(I,2)=0
23407 100 CONTINUE
23408C...Create colour tags for this event
23409 DO 120 I=1,N
23410 IF (K(I,1).EQ.3) THEN
23411 DO 110 KCS=4,5
23412 KCSIN=KCS
23413 IF (MCT(I,KCSIN-3).EQ.0) THEN
23414 CALL PYCTTR(I,KCSIN,I)
23415 ENDIF
23416 110 CONTINUE
23417 ENDIF
23418 120 CONTINUE
23419C...Instruct PYPREP to use colour tags
23420 MINT(33)=1
23421 ENDIF
23422
23423C...For MSTP(95) even, only apply to hadron-hadron
23424 KA1=IABS(MINT(11))
23425 KA2=IABS(MINT(12))
23426 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23427
23428C...Initialize new tag array (but do not delete old yet)
23429 LCT=NCT
23430 DO 130 I=MAX(1,IP),N
23431 MCN(I,1)=0
23432 MCN(I,2)=0
23433 130 CONTINUE
23434
23435C...For each final-state dipole, check whether string should be
23436C...preserved.
23437 NCR=0
23438 IA=0
23439 IC=0
23440
23441 DO 150 ICT=1,NCT
23442 IA=0
23443 IC=0
23444 DO 140 I=MAX(1,IP),N
23445 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23446 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23447 140 CONTINUE
23448 IF (IC.NE.0.AND.IA.NE.0) THEN
23449 CRMODF=1D0
23450C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23451C...(so far ignores the possibility that the whole "muck" may be moving.)
23452 IF (PARP(77).GT.0D0) THEN
23453 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23454C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23455 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23456 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23457 ELSE
23458 P2STR = 3D0/2D0 * PT2STR
23459 ENDIF
23460 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23461 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23462C...Estimate number of particles ~ log(M2), cut off at 1.
23463 RLOGM2=MAX(1D0,LOG(RM2STR))
23464 P2AVG=P2STR/RLOGM2
23465C...Supress reconnection probability by 1/(1+P77*P2AVG)
23466 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23467 ENDIF
23468 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23469 IF (PYR(0).LE.PKEEP) THEN
23470 LCT=LCT+1
23471 MCN(IC,1)=LCT
23472 MCN(IA,2)=LCT
23473 ELSE
23474C...Add coloured parton
23475 NCR=NCR+1
23476 ICR(NCR)=IC
23477 MSCR(NCR)=1
23478 IOPT(NCR)=0
23479 RLOPTC(NCR)=1D19
23480C...Add anti-coloured parton
23481 NCR=NCR+1
23482 ICR(NCR)=IA
23483 MSCR(NCR)=2
23484 IOPT(NCR)=0
23485 RLOPTC(NCR)=1D19
23486 ENDIF
23487 ENDIF
23488 150 CONTINUE
23489
23490C...Skip if there is only one possibility
23491 IF (NCR.LE.2) THEN
23492 GOTO 9999
23493 ENDIF
23494
23495C...Reorder, so ordered in I (in order to correspond to old algorithm)
23496 NLOOP=0
23497 151 NLOOP=NLOOP+1
23498 MORD=1
23499 DO 155 IC1=1,NCR-1
23500 I1=ICR(IC1)
23501 I2=ICR(IC1+1)
23502 IF (I1.GT.I2) THEN
23503 IT=I1
23504 MST=MSCR(IC1)
23505 ICR(IC1)=I2
23506 MSCR(IC1)=MSCR(IC1+1)
23507 ICR(IC1+1)=IT
23508 MSCR(IC1+1)=MST
23509 MORD=0
23510 ENDIF
23511 155 CONTINUE
23512C...Max do 1000 reordering loops
23513 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23514
23515C...Loop over CR partons
23516C...(Ignore junctions for now.)
23517 NLOOP=0
23518 160 NLOOP=NLOOP+1
23519 RLMAX=0D0
23520 ICRMAX=0
23521C...Loop over coloured partons
23522 DO 230 IC1=1,NCR
23523C...Retrieve parton Event Record index and Colour Side
23524 I=ICR(IC1)
23525 MSI=MSCR(IC1)
23526C...Skip already connected partons
23527 IF (MCN(I,MSI).NE.0) GOTO 230
23528C...Shorthand for colour charge
23529 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23530C...For Seattle algorithm, only start from partons with one dangling
23531C...colour tag
23532 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23533 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23534 ENDIF
23535C...Retrieve saved optimal partner
23536 IO=IOPT(IC1)
23537 IF (IO.NE.0) THEN
23538C...Reject saved optimal partner if latter is now connected
23539C...(Also reject if using model S1, since saved partner may
23540C...now give rise to gg loop.)
23541 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23542 IOPT(IC1)=0
23543 RLOPTC(IC1)=1D19
23544 ENDIF
23545 ENDIF
23546 RLOPT=RLOPTC(IC1)
23547C...Search for new optimal partner if necessary
23548 IF (IOPT(IC1).EQ.0) THEN
23549 MBROPT=0
23550 MGGOPT=0
23551 RLOPT=1D19
23552C...Loop over partons you can connect to
23553 DO 210 IC2=1,NCR
23554 J=ICR(IC2)
23555 MSJ=MSCR(IC2)
23556C...Skip if already connected
23557 IF (MCN(J,MSJ).NE.0) GOTO 210
23558C...Skip if this not colour-anticolour pair
23559 IF (MSI.EQ.MSJ) GOTO 210
23560C...And do not let gluons connect to themselves
23561 IF (I.EQ.J) GOTO 210
23562C...Suppress direct connections between partons in same Beam Remnant
23563 MBRSTR=0
23564 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23565 & MBRSTR=1
23566C...Shorthand for colour charge
23567 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23568C...Check for gluon loops
23569 MGGSTR=0
23570 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23571 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23572 & MCN(I,2).NE.0) MGGSTR=1
23573 ENDIF
23574C...Save connection with smallest lambda measure
23575 RL=FOUR(I,J)
23576C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23577 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23578 IF (K(I,2).EQ.21) RL=0.5D0*RL
23579 IF (K(J,2).EQ.21) RL=0.5D0*RL
23580 ENDIF
23581C...If best so far was a BR string and this is not, also save.
23582C...If best so far was a gg string and this is not, also save.
23583C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23584C...string with a small Lambda measure as the last step, this connection
23585C...will be saved regardless of whether other possibilities existed.
23586C...I.e., there should really be a check whether another possibility has
23587C...already been found, but since these models are now actively in use
23588C...and uncertainties are anyway large, the algorithm is left as it is.
23589C...(correction --> Pythia 8 ?)
23590 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23591 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23592 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23593 RLOPT=RL
23594 RLOPTC(IC1)=RLOPT
23595 IOPT(IC1)=J
23596 MBROPT=MBRSTR
23597 MGGOPT=MGGSTR
23598 ENDIF
23599 210 CONTINUE
23600 ENDIF
23601 IF (IOPT(IC1).NE.0) THEN
23602C...Save pair with largest RLOPT so far
23603 IF (RLOPT.GE.RLMAX) THEN
23604 ICRMAX=IC1
23605 RLMAX=RLOPT
23606 ENDIF
23607 ENDIF
23608 230 CONTINUE
23609C...Save and iterate
23610 IF (ICRMAX.GT.0) THEN
23611 LCT=LCT+1
23612 ILMAX=ICR(ICRMAX)
23613 JLMAX=IOPT(ICRMAX)
23614 ICMAX=MSCR(ICRMAX)
23615 JCMAX=3-ICMAX
23616 MCN(ILMAX,ICMAX)=LCT
23617 MCN(JLMAX,JCMAX)=LCT
23618 IF (NLOOP.LE.2*(N-IP)) THEN
23619 GOTO 160
23620 ELSE
23621 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23622 CALL PYSTOP(11)
23623 ENDIF
23624 ELSE
23625C...Save and exit. First check for leftover gluon(s)
23626 DO 260 I=MAX(1,IP),N
23627C...Check colour charge
23628 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23629 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23630 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23631C...Decide where to put left-over gluon (minimal insertion)
23632 ILMAX=0
23633 RLMAX=1D19
23634 DO 250 KCT=NCT+1,LCT
23635 DO 240 IT=MAX(1,IP),N
23636 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23637 IF (MCN(IT,1).EQ.KCT) IC=IT
23638 IF (MCN(IT,2).EQ.KCT) IA=IT
23639 240 CONTINUE
23640 RL=FOUR(IC,I)*FOUR(IA,I)
23641 IF (RL.LT.RLMAX) THEN
23642 RLMAX=RL
23643 ICMAX=IC
23644 IAMAX=IA
23645 ENDIF
23646 250 CONTINUE
23647 LCT=LCT+1
23648 MCN(I,1)=MCN(ICMAX,1)
23649 MCN(I,2)=LCT
23650 MCN(ICMAX,1)=LCT
23651 ENDIF
23652 260 CONTINUE
23653C...Here we need to loop over entire event.
23654 DO 270 IZ=MAX(1,IP),N
23655C...Do not erase parton shower colour history
23656 IF (K(IZ,1).NE.3) GOTO 270
23657C...Check colour charge
23658 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23659 IF (MCI.EQ.0) GOTO 270
23660 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23661 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23662 270 CONTINUE
23663 ENDIF
23664
23665 9999 RETURN
23666 END
23667
23668C*********************************************************************
23669
23670C...PYDIFF
23671C...Handles diffractive and elastic scattering.
23672
23673 SUBROUTINE PYDIFF
23674
23675C...Double precision and integer declarations.
23676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23677 IMPLICIT INTEGER(I-N)
23678 INTEGER PYK,PYCHGE,PYCOMP
23679C...Commonblocks.
23680 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23682 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23683 COMMON/PYINT1/MINT(400),VINT(400)
23684 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23685
23686C...Reset K, P and V vectors. Store incoming particles.
23687 DO 110 JT=1,MSTP(126)+10
23688 I=MINT(83)+JT
23689 DO 100 J=1,5
23690 K(I,J)=0
23691 P(I,J)=0D0
23692 V(I,J)=0D0
23693 100 CONTINUE
23694 110 CONTINUE
23695 N=MINT(84)
23696 MINT(3)=0
23697 MINT(21)=0
23698 MINT(22)=0
23699 MINT(23)=0
23700 MINT(24)=0
23701 MINT(4)=4
23702 DO 130 JT=1,2
23703 I=MINT(83)+JT
23704 K(I,1)=21
23705 K(I,2)=MINT(10+JT)
23706 DO 120 J=1,5
23707 P(I,J)=VINT(285+5*JT+J)
23708 120 CONTINUE
23709 130 CONTINUE
23710 MINT(6)=2
23711
23712C...Subprocess; kinematics.
23713 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23714 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23715 DO 200 JT=1,2
23716 I=MINT(83)+JT
23717 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23718 KFH=MINT(102+JT)
23719
23720C...Elastically scattered particle. (Except elastic GVMD states.)
23721 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23722 & MINT(106+JT).NE.3)) THEN
23723 N=N+1
23724 K(N,1)=1
23725 K(N,2)=KFH
23726 K(N,3)=I+2
23727 P(N,3)=PZ*(-1)**(JT+1)
23728 P(N,4)=PE
23729 P(N,5)=SQRT(VINT(62+JT))
23730
23731C...Decay rho from elastic scattering of gamma with sin**2(theta)
23732C...distribution of decay products (in rho rest frame).
23733 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23734 NSAV=N
23735 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23736 P(N,3)=0D0
23737 P(N,4)=P(N,5)
23738 CALL PYDECY(NSAV)
23739 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23740 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23741 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23742 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23743 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23744 140 CTHE=2D0*PYR(0)-1D0
23745 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23746 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23747 ENDIF
23748 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23749 ENDIF
23750
23751C...Diffracted particle: low-mass system to two particles.
23752 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23753 N=N+2
23754 K(N-1,1)=1
23755 K(N,1)=1
23756 K(N-1,3)=I+2
23757 K(N,3)=I+2
23758 PMMAS=SQRT(VINT(62+JT))
23759 NTRY=0
23760 150 NTRY=NTRY+1
23761 IF(NTRY.LT.20) THEN
23762 MINT(105)=MINT(102+JT)
23763 MINT(109)=MINT(106+JT)
23764 CALL PYSPLI(KFH,21,KFL1,KFL2)
23765 CALL PYKFDI(KFL1,0,KFL3,KF1)
23766 IF(KF1.EQ.0) GOTO 150
23767 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23768 IF(KF2.EQ.0) GOTO 150
23769 ELSE
23770 KF1=KFH
23771 KF2=111
23772 ENDIF
23773 PM1=PYMASS(KF1)
23774 PM2=PYMASS(KF2)
23775 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23776 K(N-1,2)=KF1
23777 K(N,2)=KF2
23778 P(N-1,5)=PM1
23779 P(N,5)=PM2
23780 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23781 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23782 P(N-1,3)=PZP
23783 P(N,3)=-PZP
23784 P(N-1,4)=SQRT(PM1**2+PZP**2)
23785 P(N,4)=SQRT(PM2**2+PZP**2)
23786 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23787 & 0D0,0D0,0D0)
23788 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23789 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23790
23791C...Diffracted particle: valence quark kicked out.
23792 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23793 & PARP(101))) THEN
23794 N=N+2
23795 K(N-1,1)=2
23796 K(N,1)=1
23797 K(N-1,3)=I+2
23798 K(N,3)=I+2
23799 MINT(105)=MINT(102+JT)
23800 MINT(109)=MINT(106+JT)
23801 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23802 P(N-1,5)=PYMASS(K(N-1,2))
23803 P(N,5)=PYMASS(K(N,2))
23804 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23805 & 4D0*P(N-1,5)**2*P(N,5)**2
23806 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23807 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23808 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23809 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23810 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23811
23812C...Diffracted particle: gluon kicked out.
23813 ELSE
23814 N=N+3
23815 K(N-2,1)=2
23816 K(N-1,1)=2
23817 K(N,1)=1
23818 K(N-2,3)=I+2
23819 K(N-1,3)=I+2
23820 K(N,3)=I+2
23821 MINT(105)=MINT(102+JT)
23822 MINT(109)=MINT(106+JT)
23823 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23824 K(N-1,2)=21
23825 P(N-2,5)=PYMASS(K(N-2,2))
23826 P(N-1,5)=0D0
23827 P(N,5)=PYMASS(K(N,2))
23828C...Energy distribution for particle into two jets.
23829 160 IMB=1
23830 IF(MOD(KFH/1000,10).NE.0) IMB=2
23831 CHIK=PARP(92+2*IMB)
23832 IF(MSTP(92).LE.1) THEN
23833 IF(IMB.EQ.1) CHI=PYR(0)
23834 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23835 ELSEIF(MSTP(92).EQ.2) THEN
23836 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23837 ELSEIF(MSTP(92).EQ.3) THEN
23838 CUT=2D0*0.3D0/VINT(1)
23839 170 CHI=PYR(0)**2
23840 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23841 & PYR(0)) GOTO 170
23842 ELSEIF(MSTP(92).EQ.4) THEN
23843 CUT=2D0*0.3D0/VINT(1)
23844 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23845 180 CHIR=CUT*CUTR**PYR(0)
23846 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23847 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23848 ELSE
23849 CUT=2D0*0.3D0/VINT(1)
23850 CUTA=CUT**(1D0-PARP(98))
23851 CUTB=(1D0+CUT)**(1D0-PARP(98))
23852 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23853 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23854 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23855 ENDIF
23856 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23857 & VINT(62+JT)) GOTO 160
23858 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23859 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23860 & (2D0*VINT(62+JT))
23861 PEI=SQRT(PZI**2+SQM)
23862 PQQP=(1D0-CHI)*(PEI+PZI)
23863 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23864 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23865 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23866 P(N-1,3)=P(N-1,4)*(-1)**JT
23867 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23868 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23869 ENDIF
23870
23871C...Documentation lines.
23872 K(I+2,1)=21
23873 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23874 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23875 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23876 K(I+2,3)=I
23877 P(I+2,3)=PZ*(-1)**(JT+1)
23878 P(I+2,4)=PE
23879 P(I+2,5)=SQRT(VINT(62+JT))
23880 200 CONTINUE
23881
23882C...Rotate outgoing partons/particles using cos(theta).
23883 IF(VINT(23).LT.0.9D0) THEN
23884 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23885 ELSE
23886 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23887 ENDIF
23888
23889 RETURN
23890 END
23891
23892C*********************************************************************
23893
23894C...PYDISG
23895C...Set up a DIS process as gamma* + f -> f, with beam remnant
23896C...and showering added consecutively. Photon flux by the PYGAGA
23897C...routine (if at all).
23898
23899 SUBROUTINE PYDISG
23900
23901C...Double precision and integer declarations.
23902 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23903 IMPLICIT INTEGER(I-N)
23904 INTEGER PYK,PYCHGE,PYCOMP
23905C...Parameter statement to help give large particle numbers.
23906 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23907 &KEXCIT=4000000,KDIMEN=5000000)
23908C...Commonblocks.
23909 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23910 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23911 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23912 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23913 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23914 COMMON/PYINT1/MINT(400),VINT(400)
23915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23916C...Local arrays.
23917 DIMENSION PMS(4)
23918
23919C...Choice of subprocess, number of documentation lines
23920 IDOC=7
23921 MINT(3)=IDOC-6
23922 MINT(4)=IDOC
23923 IPU1=MINT(84)+1
23924 IPU2=MINT(84)+2
23925 IPU3=MINT(84)+3
23926 ISIDE=1
23927 IF(MINT(107).EQ.4) ISIDE=2
23928
23929C...Reset K, P and V vectors. Store incoming particles
23930 DO 110 JT=1,MSTP(126)+20
23931 I=MINT(83)+JT
23932 DO 100 J=1,5
23933 K(I,J)=0
23934 P(I,J)=0D0
23935 V(I,J)=0D0
23936 100 CONTINUE
23937 110 CONTINUE
23938 DO 130 JT=1,2
23939 I=MINT(83)+JT
23940 K(I,1)=21
23941 K(I,2)=MINT(10+JT)
23942 DO 120 J=1,5
23943 P(I,J)=VINT(285+5*JT+J)
23944 120 CONTINUE
23945 130 CONTINUE
23946 MINT(6)=2
23947
23948C...Store incoming partons in hadronic CM-frame
23949 DO 140 JT=1,2
23950 I=MINT(84)+JT
23951 K(I,1)=14
23952 K(I,2)=MINT(14+JT)
23953 K(I,3)=MINT(83)+2+JT
23954 140 CONTINUE
23955 IF(MINT(15).EQ.22) THEN
23956 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23957 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23958 P(MINT(84)+1,5)=-SQRT(VINT(307))
23959 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23960 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23961 KFRES=MINT(16)
23962 ISIDE=2
23963 ELSE
23964 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23965 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23966 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23967 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23968 P(MINT(84)+1,5)=-SQRT(VINT(308))
23969 KFRES=MINT(15)
23970 ISIDE=1
23971 ENDIF
23972 SIDESG=(-1D0)**(ISIDE-1)
23973
23974C...Copy incoming partons to documentation lines.
23975 DO 170 JT=1,2
23976 I1=MINT(83)+4+JT
23977 I2=MINT(84)+JT
23978 K(I1,1)=21
23979 K(I1,2)=K(I2,2)
23980 K(I1,3)=I1-2
23981 DO 150 J=1,5
23982 P(I1,J)=P(I2,J)
23983 150 CONTINUE
23984
23985C...Second copy for partons before ISR shower, since no such.
23986 I1=MINT(83)+2+JT
23987 K(I1,1)=21
23988 K(I1,2)=K(I2,2)
23989 K(I1,3)=I1-2
23990 DO 160 J=1,5
23991 P(I1,J)=P(I2,J)
23992 160 CONTINUE
23993 170 CONTINUE
23994
23995C...Define initial partons.
23996 NTRY=0
23997 180 NTRY=NTRY+1
23998 IF(NTRY.GT.100) THEN
23999 MINT(51)=1
24000 RETURN
24001 ENDIF
24002
24003C...Scattered quark in hadronic CM frame.
24004 I=MINT(83)+7
24005 K(IPU3,1)=3
24006 K(IPU3,2)=KFRES
24007 K(IPU3,3)=I
24008 P(IPU3,5)=PYMASS(KFRES)
24009 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24010 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24011 P(IPU3,5)=0D0
24012 K(I,1)=21
24013 K(I,2)=KFRES
24014 K(I,3)=MINT(83)+4+ISIDE
24015 P(I,3)=P(IPU3,3)
24016 P(I,4)=P(IPU3,4)
24017 P(I,5)=P(IPU3,5)
24018 N=IPU3
24019 MINT(21)=KFRES
24020 MINT(22)=0
24021
24022C...No primordial kT, or chosen according to truncated Gaussian or
24023C...exponential, or (for photon) predetermined or power law.
24024 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24025 IF(MSTP(91).LE.0) THEN
24026 PT=0D0
24027 ELSEIF(MSTP(91).EQ.1) THEN
24028 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24029 ELSE
24030 RPT1=PYR(0)
24031 RPT2=PYR(0)
24032 PT=-PARP(92)*LOG(RPT1*RPT2)
24033 ENDIF
24034 IF(PT.GT.PARP(93)) GOTO 190
24035 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24036 PTA=SQRT(VINT(282+ISIDE))
24037 PTB=0D0
24038 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24039 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24040 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24041 RPT1=PYR(0)
24042 RPT2=PYR(0)
24043 PTB=-PARP(99)*LOG(RPT1*RPT2)
24044 ENDIF
24045 IF(PTB.GT.PARP(100)) GOTO 190
24046 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24047 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24048 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24049 IF(MSTP(93).LE.0) THEN
24050 PT=0D0
24051 ELSEIF(MSTP(93).EQ.1) THEN
24052 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24053 ELSEIF(MSTP(93).EQ.2) THEN
24054 RPT1=PYR(0)
24055 RPT2=PYR(0)
24056 PT=-PARP(99)*LOG(RPT1*RPT2)
24057 ELSEIF(MSTP(93).EQ.3) THEN
24058 HA=PARP(99)**2
24059 HB=PARP(100)**2
24060 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24061 ELSE
24062 HA=PARP(99)**2
24063 HB=PARP(100)**2
24064 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24065 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24066 ENDIF
24067 IF(PT.GT.PARP(100)) GOTO 190
24068 ELSE
24069 PT=0D0
24070 ENDIF
24071 VINT(156+ISIDE)=PT
24072 PHI=PARU(2)*PYR(0)
24073 P(IPU3,1)=PT*COS(PHI)
24074 P(IPU3,2)=PT*SIN(PHI)
24075 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24076 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24077 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24078
24079C...Find one or two beam remnants.
24080 MINT(105)=MINT(102+ISIDE)
24081 MINT(109)=MINT(106+ISIDE)
24082 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24083 IF(MINT(51).NE.0) THEN
24084 MINT(51)=0
24085 GOTO 180
24086 ENDIF
24087
24088C...Store first remnant parton, with colour info and kinematics.
24089 I=N+1
24090 K(I,1)=1
24091 K(I,2)=KFLSP
24092 K(I,3)=MINT(83)+ISIDE
24093 P(I,5)=PYMASS(K(I,2))
24094 KCOL=KCHG(PYCOMP(KFLSP),2)
24095 IF(KCOL.NE.0) THEN
24096 K(I,1)=3
24097 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24098 K(I,KFLS+3)=MSTU(5)*IPU3
24099 K(IPU3,6-KFLS)=MSTU(5)*I
24100 ICOLR=I
24101 ENDIF
24102 IF(KFLCH.EQ.0) THEN
24103 P(I,1)=-P(IPU3,1)
24104 P(I,2)=-P(IPU3,2)
24105 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24106 P(I,3)=-P(IPU3,3)
24107 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24108 PRP=P(I,4)+ABS(P(I,3))
24109
24110C...When extra remnant parton or hadron: store extra remnant.
24111 ELSE
24112 I=I+1
24113 K(I,1)=1
24114 K(I,2)=KFLCH
24115 K(I,3)=MINT(83)+ISIDE
24116 P(I,5)=PYMASS(K(I,2))
24117 KCOL=KCHG(PYCOMP(KFLCH),2)
24118 IF(KCOL.NE.0) THEN
24119 K(I,1)=3
24120 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24121 K(I,KFLS+3)=MSTU(5)*IPU3
24122 K(IPU3,6-KFLS)=MSTU(5)*I
24123 ICOLR=I
24124 ENDIF
24125
24126C...Relative transverse momentum when two remnants.
24127 LOOP=0
24128 200 LOOP=LOOP+1
24129 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24130 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24131 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24132 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24133 P(I,1)=-P(IPU3,1)-P(I-1,1)
24134 P(I,2)=-P(IPU3,2)-P(I-1,2)
24135 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24136
24137C...Relative distribution of energy for particle into jet plus particle.
24138 IMB=1
24139 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24140 IF(MSTP(94).LE.1) THEN
24141 IF(IMB.EQ.1) CHI=PYR(0)
24142 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24143 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24144 ELSEIF(MSTP(94).EQ.2) THEN
24145 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24146 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24147 ELSEIF(MSTP(94).EQ.3) THEN
24148 CALL PYZDIS(1,0,PMS(4),ZZ)
24149 CHI=ZZ
24150 ELSE
24151 CALL PYZDIS(1000,0,PMS(4),ZZ)
24152 CHI=ZZ
24153 ENDIF
24154
24155C...Construct total transverse mass; reject if too large.
24156 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24157 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24158 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24159 IF(LOOP.LT.10) GOTO 200
24160 GOTO 180
24161 ENDIF
24162 VINT(158+ISIDE)=CHI
24163
24164C...Subdivide longitudinal momentum according to value selected above.
24165 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24166 PW1=(1D0-CHI)*PRP
24167 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24168 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24169 PW2=CHI*PRP
24170 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24171 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24172 ENDIF
24173 N=I
24174
24175C...Boost current and remnant systems to correct frame.
24176 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24177 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24178 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24179 &(2D0*VINT(1)*PCP)
24180 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24181 &(2D0*VINT(1)*PRP)
24182 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24183 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24184 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24185 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24186
24187C...Let current quark shower; recoil but no showering by colour partner.
24188 QMAX=2D0*SQRT(VINT(309-ISIDE))
24189 MSTJ48=MSTJ(48)
24190 MSTJ(48)=1
24191 PARJ86=PARJ(86)
24192 PARJ(86)=0D0
24193 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24194 MSTJ(48)=MSTJ48
24195 PARJ(86)=PARJ86
24196
24197 RETURN
24198 END
24199
24200C*********************************************************************
24201
24202C...PYDOCU
24203C...Handles the documentation of the process in MSTI and PARI,
24204C...and also computes cross-sections based on accumulated statistics.
24205
24206 SUBROUTINE PYDOCU
24207
24208C...Double precision and integer declarations.
24209 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24210 IMPLICIT INTEGER(I-N)
24211 INTEGER PYK,PYCHGE,PYCOMP
24212C...Commonblocks.
24213 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24214 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24215 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24217 COMMON/PYINT1/MINT(400),VINT(400)
24218 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24219 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24220 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24221 &/PYINT5/
24222
24223C...Calculate Monte Carlo estimates of cross-sections.
24224 ISUB=MINT(1)
24225 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24226 NGEN(0,3)=NGEN(0,3)+1
24227 XSEC(0,3)=0D0
24228 DO 100 I=1,500
24229 IF(I.EQ.96.OR.I.EQ.97) THEN
24230 XSEC(I,3)=0D0
24231 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24232 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24233 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24234 & DBLE(NGEN(96,2)))
24235 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24236 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24237 & DBLE(NGEN(96,2)))
24238 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24239 XSEC(I,3)=0D0
24240 ELSEIF(NGEN(I,2).EQ.0) THEN
24241 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24242 & DBLE(NGEN(0,2)))
24243 ELSE
24244 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24245 & DBLE(NGEN(I,2)))
24246 ENDIF
24247 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24248 100 CONTINUE
24249
24250C...Rescale to known low-pT cross-section for standard QCD processes.
24251 IF(MSUB(95).EQ.1) THEN
24252 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24253 & XSEC(68,3)+XSEC(95,3)
24254 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24255 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24256 FAC=XSECW/XSECH
24257 XSEC(11,3)=FAC*XSEC(11,3)
24258 XSEC(12,3)=FAC*XSEC(12,3)
24259 XSEC(13,3)=FAC*XSEC(13,3)
24260 XSEC(28,3)=FAC*XSEC(28,3)
24261 XSEC(53,3)=FAC*XSEC(53,3)
24262 XSEC(68,3)=FAC*XSEC(68,3)
24263 XSEC(95,3)=FAC*XSEC(95,3)
24264 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24265 ENDIF
24266 ENDIF
24267
24268C...Save information for gamma-p and gamma-gamma.
24269 IF(MINT(121).GT.1) THEN
24270 IGA=MINT(122)
24271 CALL PYSAVE(2,IGA)
24272 CALL PYSAVE(5,0)
24273 ENDIF
24274
24275C...Reset information on hard interaction.
24276 DO 110 J=1,200
24277 MSTI(J)=0
24278 PARI(J)=0D0
24279 110 CONTINUE
24280
24281C...Copy integer valued information from MINT into MSTI.
24282 DO 120 J=1,32
24283 MSTI(J)=MINT(J)
24284 120 CONTINUE
24285 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24286
24287C...Store cross-section variables in PARI.
24288 PARI(1)=XSEC(0,3)
24289 PARI(2)=XSEC(0,3)/MINT(5)
24290 PARI(7)=VINT(97)
24291 PARI(9)=VINT(99)
24292 PARI(10)=VINT(100)
24293 VINT(98)=VINT(98)+VINT(100)
24294 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24295
24296C...Store kinematics variables in PARI.
24297 PARI(11)=VINT(1)
24298 PARI(12)=VINT(2)
24299 IF(ISUB.NE.95) THEN
24300 DO 130 J=13,26
24301 PARI(J)=VINT(30+J)
24302 130 CONTINUE
24303 PARI(29)=VINT(39)
24304 PARI(30)=VINT(40)
24305 PARI(31)=VINT(141)
24306 PARI(32)=VINT(142)
24307 PARI(33)=VINT(41)
24308 PARI(34)=VINT(42)
24309 PARI(35)=PARI(33)-PARI(34)
24310 PARI(36)=VINT(21)
24311 PARI(37)=VINT(22)
24312 PARI(38)=VINT(26)
24313 PARI(39)=VINT(157)
24314 PARI(40)=VINT(158)
24315 PARI(41)=VINT(23)
24316 PARI(42)=2D0*VINT(47)/VINT(1)
24317 ENDIF
24318
24319C...Store information on scattered partons in PARI.
24320 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24321 DO 140 IS=7,8
24322 I=MINT(IS)
24323 PARI(36+IS)=P(I,3)/VINT(1)
24324 PARI(38+IS)=P(I,4)/VINT(1)
24325 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24326 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24327 & SQRT(PR),1D20)),P(I,3))
24328 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24329 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24330 & SQRT(PR),1D20)),P(I,3))
24331 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24332 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24333 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24334 140 CONTINUE
24335 ENDIF
24336
24337C...Store sum up transverse and longitudinal momenta.
24338 PARI(65)=2D0*PARI(17)
24339 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24340 DO 150 I=MSTP(126)+1,N
24341 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24342 PT=SQRT(P(I,1)**2+P(I,2)**2)
24343 PARI(69)=PARI(69)+PT
24344 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24345 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24346 150 CONTINUE
24347 PARI(67)=PARI(68)
24348 PARI(71)=VINT(151)
24349 PARI(72)=VINT(152)
24350 PARI(73)=VINT(151)
24351 PARI(74)=VINT(152)
24352 ELSE
24353 PARI(66)=PARI(65)
24354 PARI(69)=PARI(65)
24355 ENDIF
24356
24357C...Store various other pieces of information into PARI.
24358 PARI(61)=VINT(148)
24359 PARI(75)=VINT(155)
24360 PARI(76)=VINT(156)
24361 PARI(77)=VINT(159)
24362 PARI(78)=VINT(160)
24363 PARI(81)=VINT(138)
24364
24365C...Store information on lepton -> lepton + gamma in PYGAGA.
24366 MSTI(71)=MINT(141)
24367 MSTI(72)=MINT(142)
24368 PARI(101)=VINT(301)
24369 PARI(102)=VINT(302)
24370 DO 160 I=103,114
24371 PARI(I)=VINT(I+202)
24372 160 CONTINUE
24373
24374C...Set information for PYTABU.
24375 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24376 MSTU(161)=MINT(21)
24377 MSTU(162)=0
24378 ELSEIF(ISET(ISUB).EQ.5) THEN
24379 MSTU(161)=MINT(23)
24380 MSTU(162)=0
24381 ELSE
24382 MSTU(161)=MINT(21)
24383 MSTU(162)=MINT(22)
24384 ENDIF
24385
24386 RETURN
24387 END
24388
24389C*********************************************************************
24390
24391C...PYFRAM
24392C...Performs transformations between different coordinate frames.
24393
24394 SUBROUTINE PYFRAM(IFRAME)
24395
24396C...Double precision and integer declarations.
24397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24398 IMPLICIT INTEGER(I-N)
24399 INTEGER PYK,PYCHGE,PYCOMP
24400C...Commonblocks.
24401 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24402 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24403 COMMON/PYINT1/MINT(400),VINT(400)
24404 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24405
24406C...Check that transformation can and should be done.
24407 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24408 &MINT(91).EQ.1)) THEN
24409 IF(IFRAME.EQ.MINT(6)) RETURN
24410 ELSE
24411 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24412 RETURN
24413 ENDIF
24414
24415 IF(MINT(6).EQ.1) THEN
24416C...Transform from fixed target or user specified frame to
24417C...overall CM frame.
24418 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24419 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24420 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24421 ELSEIF(MINT(6).EQ.3) THEN
24422C...Transform from hadronic CM frame in DIS to overall CM frame.
24423 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24424 & -VINT(225))
24425 ENDIF
24426
24427 IF(IFRAME.EQ.1) THEN
24428C...Transform from overall CM frame to fixed target or user specified
24429C...frame.
24430 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24431 ELSEIF(IFRAME.EQ.3) THEN
24432C...Transform from overall CM frame to hadronic CM frame in DIS.
24433 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24434 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24435 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24436 ENDIF
24437
24438C...Set information about new frame.
24439 MINT(6)=IFRAME
24440 MSTI(6)=IFRAME
24441
24442 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24443 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24444 &1X,I5)
24445
24446 RETURN
24447 END
24448
24449C*********************************************************************
24450
24451C...PYWIDT
24452C...Calculates full and partial widths of resonances.
24453
24454 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24455
24456C...Double precision and integer declarations.
24457 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24458 IMPLICIT INTEGER(I-N)
24459 INTEGER PYK,PYCHGE,PYCOMP
24460C...Parameter statement to help give large particle numbers.
24461 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24462 &KEXCIT=4000000,KDIMEN=5000000)
24463C...Commonblocks.
24464 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24465 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24466 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24467 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24468 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24469 COMMON/PYINT1/MINT(400),VINT(400)
24470 COMMON/PYINT4/MWID(500),WIDS(500,5)
24471 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24472 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24473 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24474 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24475 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24476 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24477 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24478C...Local arrays and saved variables.
24479 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24480 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24481 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24482C...UED: equivalences between ordered particles (451->475)
24483C...and UED particle code (5 000 000 + id)
24484 PARAMETER(KKFLMI=451,KKFLMA=475)
24485 DIMENSION CHIDEL(3), IUEDPR(25)
24486 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24487 COMMON/SW1/SW21,CW21
24488 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24489 & 6100001,6100002,6100003,6100004,6100005,6100006,
24490 & 5100001,5100002,5100003,5100004,5100005,5100006,
24491 & 6100011,6100013,6100015,
24492 & 5100012,5100011,5100014,5100013,5100016,5100015,
24493 & 5100021,5100022,5100023,5100024/
24494C...Save local variables
24495 SAVE MOFSV,WIDWSV,WID2SV
24496C...Initial values
24497 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24498 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24499 DATA IUEDPR/25*0/
24500C...UED: inline functions used in kk width calculus
24501 FKAC1(X,Y)=1.-X**2/Y**2
24502 FKAC2(X,Y)=2.+X**2/Y**2
24503
24504C...Compressed code and sign; mass.
24505 KFLA=IABS(KFLR)
24506 KFLS=ISIGN(1,KFLR)
24507 KC=PYCOMP(KFLA)
24508 SHR=SQRT(SH)
24509 PMR=PMAS(KC,1)
24510
24511C...Reset width information.
24512 DO 110 I=0,MDCY(KC,3)
24513 WDTP(I)=0D0
24514 DO 100 J=0,5
24515 WDTE(I,J)=0D0
24516 100 CONTINUE
24517 110 CONTINUE
24518
24519C...Allow for fudge factor to rescale resonance width.
24520 FUDGE=1D0
24521 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24522 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24523 IF(MSTP(110).EQ.KFLA) THEN
24524 FUDGE=PARP(110)
24525 ELSEIF(MSTP(110).EQ.-1) THEN
24526 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24527 ELSEIF(MSTP(110).EQ.-2) THEN
24528 FUDGE=PARP(110)
24529 ENDIF
24530 ENDIF
24531
24532C...Not to be treated as a resonance: return.
24533 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24534 &KFLA.NE.22) THEN
24535 WDTP(0)=1D0
24536 WDTE(0,0)=1D0
24537 MINT(61)=0
24538 MINT(62)=0
24539 MINT(63)=0
24540 RETURN
24541
24542C...Treatment as a resonance based on tabulated branching ratios.
24543 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24544C...Loop over possible decay channels; skip irrelevant ones.
24545 DO 120 I=1,MDCY(KC,3)
24546 IDC=I+MDCY(KC,2)-1
24547 IF(MDME(IDC,1).LT.0) GOTO 120
24548
24549C...Read out decay products and nominal masses.
24550 KFD1=KFDP(IDC,1)
24551 KFC1=PYCOMP(KFD1)
24552C...Skip dummy modes or unrecognized particles
24553 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24554 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24555 PM1=PMAS(KFC1,1)
24556 KFD2=KFDP(IDC,2)
24557 KFC2=PYCOMP(KFD2)
24558 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24559 PM2=PMAS(KFC2,1)
24560 KFD3=KFDP(IDC,3)
24561 PM3=0D0
24562 IF(KFD3.NE.0) THEN
24563 KFC3=PYCOMP(KFD3)
24564 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24565 PM3=PMAS(KFC3,1)
24566 ENDIF
24567
24568C...Naive partial width and alternative threshold factors.
24569 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24570 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24571 & PM1+PM2+PM3.GE.SHR) THEN
24572 WDTP(I)=0D0
24573 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24574 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24575 & 4D0*PM1**2*PM2**2))/SH
24576 ELSEIF(MDME(IDC,2).EQ.52) THEN
24577 PMA=MAX(PM1,PM2,PM3)
24578 PMC=MIN(PM1,PM2,PM3)
24579 PMB=PM1+PM2+PM3-PMA-PMC
24580 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24581 PMAN=PMA**2/SH
24582 PMBN=PMB**2/SH
24583 PMCN=PMC**2/SH
24584 PMBCN=PMBC**2/SH
24585 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24586 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24587 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24588 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24589 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24590 & ((1D0-PMBCN)*PMBCN*SH)
24591 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24592 WDTP(I)=WDTP(I)*SQRT(
24593 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24594 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24595 ELSEIF(MDME(IDC,2).EQ.53) THEN
24596 PMA=MAX(PM1,PM2,PM3)
24597 PMC=MIN(PM1,PM2,PM3)
24598 PMB=PM1+PM2+PM3-PMA-PMC
24599 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24600 PMAN=PMA**2/SH
24601 PMBN=PMB**2/SH
24602 PMCN=PMC**2/SH
24603 PMBCN=PMBC**2/SH
24604 FACACT=SQRT(MAX(0D0,
24605 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24606 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24607 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24608 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24609 & ((1D0-PMBCN)*PMBCN*SH)
24610 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24611 PMAN=PMA**2/PMR**2
24612 PMBN=PMB**2/PMR**2
24613 PMCN=PMC**2/PMR**2
24614 PMBCN=PMBC**2/PMR**2
24615 FACNOM=SQRT(MAX(0D0,
24616 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24617 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24618 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24619 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24620 & ((1D0-PMBCN)*PMBCN*PMR**2)
24621 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24622 ENDIF
24623 WDTP(I)=FUDGE*WDTP(I)
24624 WDTP(0)=WDTP(0)+WDTP(I)
24625
24626C...Calculate secondary width (at most two identical/opposite).
24627 WID2=1D0
24628 IF(MDME(IDC,1).GT.0) THEN
24629 IF(KFD2.EQ.KFD1) THEN
24630 IF(KCHG(KFC1,3).EQ.0) THEN
24631 WID2=WIDS(KFC1,1)
24632 ELSEIF(KFD1.GT.0) THEN
24633 WID2=WIDS(KFC1,4)
24634 ELSE
24635 WID2=WIDS(KFC1,5)
24636 ENDIF
24637 IF(KFD3.GT.0) THEN
24638 WID2=WID2*WIDS(KFC3,2)
24639 ELSEIF(KFD3.LT.0) THEN
24640 WID2=WID2*WIDS(KFC3,3)
24641 ENDIF
24642 ELSEIF(KFD2.EQ.-KFD1) THEN
24643 WID2=WIDS(KFC1,1)
24644 IF(KFD3.GT.0) THEN
24645 WID2=WID2*WIDS(KFC3,2)
24646 ELSEIF(KFD3.LT.0) THEN
24647 WID2=WID2*WIDS(KFC3,3)
24648 ENDIF
24649 ELSEIF(KFD3.EQ.KFD1) THEN
24650 IF(KCHG(KFC1,3).EQ.0) THEN
24651 WID2=WIDS(KFC1,1)
24652 ELSEIF(KFD1.GT.0) THEN
24653 WID2=WIDS(KFC1,4)
24654 ELSE
24655 WID2=WIDS(KFC1,5)
24656 ENDIF
24657 IF(KFD2.GT.0) THEN
24658 WID2=WID2*WIDS(KFC2,2)
24659 ELSEIF(KFD2.LT.0) THEN
24660 WID2=WID2*WIDS(KFC2,3)
24661 ENDIF
24662 ELSEIF(KFD3.EQ.-KFD1) THEN
24663 WID2=WIDS(KFC1,1)
24664 IF(KFD2.GT.0) THEN
24665 WID2=WID2*WIDS(KFC2,2)
24666 ELSEIF(KFD2.LT.0) THEN
24667 WID2=WID2*WIDS(KFC2,3)
24668 ENDIF
24669 ELSEIF(KFD3.EQ.KFD2) THEN
24670 IF(KCHG(KFC2,3).EQ.0) THEN
24671 WID2=WIDS(KFC2,1)
24672 ELSEIF(KFD2.GT.0) THEN
24673 WID2=WIDS(KFC2,4)
24674 ELSE
24675 WID2=WIDS(KFC2,5)
24676 ENDIF
24677 IF(KFD1.GT.0) THEN
24678 WID2=WID2*WIDS(KFC1,2)
24679 ELSEIF(KFD1.LT.0) THEN
24680 WID2=WID2*WIDS(KFC1,3)
24681 ENDIF
24682 ELSEIF(KFD3.EQ.-KFD2) THEN
24683 WID2=WIDS(KFC2,1)
24684 IF(KFD1.GT.0) THEN
24685 WID2=WID2*WIDS(KFC1,2)
24686 ELSEIF(KFD1.LT.0) THEN
24687 WID2=WID2*WIDS(KFC1,3)
24688 ENDIF
24689 ELSE
24690 IF(KFD1.GT.0) THEN
24691 WID2=WIDS(KFC1,2)
24692 ELSE
24693 WID2=WIDS(KFC1,3)
24694 ENDIF
24695 IF(KFD2.GT.0) THEN
24696 WID2=WID2*WIDS(KFC2,2)
24697 ELSE
24698 WID2=WID2*WIDS(KFC2,3)
24699 ENDIF
24700 IF(KFD3.GT.0) THEN
24701 WID2=WID2*WIDS(KFC3,2)
24702 ELSEIF(KFD3.LT.0) THEN
24703 WID2=WID2*WIDS(KFC3,3)
24704 ENDIF
24705 ENDIF
24706
24707C...Store effective widths according to case.
24708 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24709 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24710 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24711 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24712 ENDIF
24713 120 CONTINUE
24714C...Return.
24715 MINT(61)=0
24716 MINT(62)=0
24717 MINT(63)=0
24718 RETURN
24719 ENDIF
24720
24721C...Here begins detailed dynamical calculation of resonance widths.
24722C...Shared treatment of Higgs states.
24723 KFHIGG=25
24724 IHIGG=1
24725 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24726 KFHIGG=KFLA
24727 IHIGG=KFLA-33
24728 ENDIF
24729
24730C...Common electroweak and strong constants.
24731 XW=PARU(102)
24732 XWV=XW
24733 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24734 XW1=1D0-XW
24735 AEM=PYALEM(SH)
24736 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24737 AS=PYALPS(SH)
24738 RADC=1D0+AS/PARU(1)
24739
24740 IF(KFLA.EQ.6) THEN
24741C...t quark.
24742 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24743 RADCT=1D0-2.5D0*AS/PARU(1)
24744 DO 140 I=1,MDCY(KC,3)
24745 IDC=I+MDCY(KC,2)-1
24746 IF(MDME(IDC,1).LT.0) GOTO 140
24747 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24748 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24749 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24750 WID2=1D0
24751 IF(I.GE.4.AND.I.LE.7) THEN
24752C...t -> W + q; including approximate QCD correction factor.
24753 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24754 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24755 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24756 IF(KFLR.GT.0) THEN
24757 WID2=WIDS(24,2)
24758 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24759 ELSE
24760 WID2=WIDS(24,3)
24761 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24762 ENDIF
24763 ELSEIF(I.EQ.9) THEN
24764C...t -> H + b.
24765 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24766 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24767 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24768 & 4D0*SQRT(RM2R*RM2))
24769 WID2=WIDS(37,2)
24770 IF(KFLR.LT.0) WID2=WIDS(37,3)
24771CMRENNA++
24772 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24773C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24774 BETA=ATAN(RMSS(5))
24775 SINB=SIN(BETA)
24776 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24777 ET=KCHG(6,1)/3D0
24778 T3L=SIGN(0.5D0,ET)
24779 KFC1=PYCOMP(KFDP(IDC,1))
24780 KFC2=PYCOMP(KFDP(IDC,2))
24781 PMNCHI=PMAS(KFC1,1)
24782 PMSTOP=PMAS(KFC2,1)
24783 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24784 IZ=I-9
24785 DO 130 IK=1,4
24786 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24787 130 CONTINUE
24788 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24789 AR=-ET*ZMIXC(IZ,1)*TANW
24790 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24791 BR=AL
24792 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24793 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24794 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24795 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24796 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24797 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24798 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24799 IF(KFLR.GT.0) THEN
24800 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24801 ELSE
24802 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24803 ENDIF
24804 ENDIF
24805 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24806C...t -> ~g + ~t
24807 KFC1=PYCOMP(KFDP(IDC,1))
24808 KFC2=PYCOMP(KFDP(IDC,2))
24809 PMNCHI=PMAS(KFC1,1)
24810 PMSTOP=PMAS(KFC2,1)
24811 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24812 RL=SFMIX(6,1)
24813 RR=-SFMIX(6,2)
24814 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24815 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24816 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24817 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24818 IF(KFLR.GT.0) THEN
24819 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24820 ELSE
24821 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24822 ENDIF
24823 ENDIF
24824 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24825C...t -> ~gravitino + ~t
24826 XMP2=RMSS(29)**2
24827 KFC1=PYCOMP(KFDP(IDC,1))
24828 XMGR2=PMAS(KFC1,1)**2
24829 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24830 KFC2=PYCOMP(KFDP(IDC,2))
24831 WID2=WIDS(KFC2,2)
24832 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24833CMRENNA--
24834 ENDIF
24835 WDTP(I)=FUDGE*WDTP(I)
24836 WDTP(0)=WDTP(0)+WDTP(I)
24837 IF(MDME(IDC,1).GT.0) THEN
24838 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24839 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24840 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24841 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24842 ENDIF
24843 140 CONTINUE
24844
24845 ELSEIF(KFLA.EQ.7) THEN
24846C...b' quark.
24847 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24848 DO 150 I=1,MDCY(KC,3)
24849 IDC=I+MDCY(KC,2)-1
24850 IF(MDME(IDC,1).LT.0) GOTO 150
24851 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24852 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24853 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24854 WID2=1D0
24855 IF(I.GE.4.AND.I.LE.7) THEN
24856C...b' -> W + q.
24857 WDTP(I)=FAC*VCKM(I-3,4)*
24858 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24859 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24860 IF(KFLR.GT.0) THEN
24861 WID2=WIDS(24,3)
24862 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24863 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24864 ELSE
24865 WID2=WIDS(24,2)
24866 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24867 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24868 ENDIF
24869 WID2=WIDS(24,3)
24870 IF(KFLR.LT.0) WID2=WIDS(24,2)
24871 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24872C...b' -> H + q.
24873 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24874 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24875 IF(KFLR.GT.0) THEN
24876 WID2=WIDS(37,3)
24877 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24878 ELSE
24879 WID2=WIDS(37,2)
24880 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24881 ENDIF
24882 ENDIF
24883 WDTP(I)=FUDGE*WDTP(I)
24884 WDTP(0)=WDTP(0)+WDTP(I)
24885 IF(MDME(IDC,1).GT.0) THEN
24886 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24887 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24888 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24889 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24890 ENDIF
24891 150 CONTINUE
24892
24893 ELSEIF(KFLA.EQ.8) THEN
24894C...t' quark.
24895 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24896 DO 160 I=1,MDCY(KC,3)
24897 IDC=I+MDCY(KC,2)-1
24898 IF(MDME(IDC,1).LT.0) GOTO 160
24899 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24900 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24901 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24902 WID2=1D0
24903 IF(I.GE.4.AND.I.LE.7) THEN
24904C...t' -> W + q.
24905 WDTP(I)=FAC*VCKM(4,I-3)*
24906 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24907 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24908 IF(KFLR.GT.0) THEN
24909 WID2=WIDS(24,2)
24910 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24911 ELSE
24912 WID2=WIDS(24,3)
24913 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24914 ENDIF
24915 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24916C...t' -> H + q.
24917 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24918 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24919 IF(KFLR.GT.0) THEN
24920 WID2=WIDS(37,2)
24921 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24922 ELSE
24923 WID2=WIDS(37,3)
24924 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24925 ENDIF
24926 ENDIF
24927 WDTP(I)=FUDGE*WDTP(I)
24928 WDTP(0)=WDTP(0)+WDTP(I)
24929 IF(MDME(IDC,1).GT.0) THEN
24930 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24931 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24932 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24933 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24934 ENDIF
24935 160 CONTINUE
24936
24937 ELSEIF(KFLA.EQ.17) THEN
24938C...tau' lepton.
24939 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24940 DO 170 I=1,MDCY(KC,3)
24941 IDC=I+MDCY(KC,2)-1
24942 IF(MDME(IDC,1).LT.0) GOTO 170
24943 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24944 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24945 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24946 WID2=1D0
24947 IF(I.EQ.3) THEN
24948C...tau' -> W + nu'_tau.
24949 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24950 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24951 IF(KFLR.GT.0) THEN
24952 WID2=WIDS(24,3)
24953 WID2=WID2*WIDS(18,2)
24954 ELSE
24955 WID2=WIDS(24,2)
24956 WID2=WID2*WIDS(18,3)
24957 ENDIF
24958 ELSEIF(I.EQ.5) THEN
24959C...tau' -> H + nu'_tau.
24960 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24961 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24962 IF(KFLR.GT.0) THEN
24963 WID2=WIDS(37,3)
24964 WID2=WID2*WIDS(18,2)
24965 ELSE
24966 WID2=WIDS(37,2)
24967 WID2=WID2*WIDS(18,3)
24968 ENDIF
24969 ENDIF
24970 WDTP(I)=FUDGE*WDTP(I)
24971 WDTP(0)=WDTP(0)+WDTP(I)
24972 IF(MDME(IDC,1).GT.0) THEN
24973 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24974 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24975 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24976 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24977 ENDIF
24978 170 CONTINUE
24979
24980 ELSEIF(KFLA.EQ.18) THEN
24981C...nu'_tau neutrino.
24982 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24983 DO 180 I=1,MDCY(KC,3)
24984 IDC=I+MDCY(KC,2)-1
24985 IF(MDME(IDC,1).LT.0) GOTO 180
24986 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24987 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24988 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24989 WID2=1D0
24990 IF(I.EQ.2) THEN
24991C...nu'_tau -> W + tau'.
24992 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24993 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24994 IF(KFLR.GT.0) THEN
24995 WID2=WIDS(24,2)
24996 WID2=WID2*WIDS(17,2)
24997 ELSE
24998 WID2=WIDS(24,3)
24999 WID2=WID2*WIDS(17,3)
25000 ENDIF
25001 ELSEIF(I.EQ.3) THEN
25002C...nu'_tau -> H + tau'.
25003 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25004 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25005 IF(KFLR.GT.0) THEN
25006 WID2=WIDS(37,2)
25007 WID2=WID2*WIDS(17,2)
25008 ELSE
25009 WID2=WIDS(37,3)
25010 WID2=WID2*WIDS(17,3)
25011 ENDIF
25012 ENDIF
25013 WDTP(I)=FUDGE*WDTP(I)
25014 WDTP(0)=WDTP(0)+WDTP(I)
25015 IF(MDME(IDC,1).GT.0) THEN
25016 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25017 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25018 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25019 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25020 ENDIF
25021 180 CONTINUE
25022
25023 ELSEIF(KFLA.EQ.21) THEN
25024C...QCD:
25025C***Note that widths are not given in dimensional quantities here.
25026 DO 190 I=1,MDCY(KC,3)
25027 IDC=I+MDCY(KC,2)-1
25028 IF(MDME(IDC,1).LT.0) GOTO 190
25029 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25030 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25031 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25032 WID2=1D0
25033 IF(I.LE.8) THEN
25034C...QCD -> q + qbar
25035 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25036 IF(I.EQ.6) WID2=WIDS(6,1)
25037 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25038 ENDIF
25039 WDTP(I)=FUDGE*WDTP(I)
25040 WDTP(0)=WDTP(0)+WDTP(I)
25041 IF(MDME(IDC,1).GT.0) THEN
25042 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25043 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25044 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25045 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25046 ENDIF
25047 190 CONTINUE
25048
25049 ELSEIF(KFLA.EQ.22) THEN
25050C...QED photon.
25051C***Note that widths are not given in dimensional quantities here.
25052 DO 200 I=1,MDCY(KC,3)
25053 IDC=I+MDCY(KC,2)-1
25054 IF(MDME(IDC,1).LT.0) GOTO 200
25055 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25056 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25057 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25058 WID2=1D0
25059 IF(I.LE.8) THEN
25060C...QED -> q + qbar.
25061 EF=KCHG(I,1)/3D0
25062 FCOF=3D0*RADC
25063 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25064 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25065 IF(I.EQ.6) WID2=WIDS(6,1)
25066 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25067 ELSEIF(I.LE.12) THEN
25068C...QED -> l+ + l-.
25069 EF=KCHG(9+2*(I-8),1)/3D0
25070 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25071 IF(I.EQ.12) WID2=WIDS(17,1)
25072 ENDIF
25073 WDTP(I)=FUDGE*WDTP(I)
25074 WDTP(0)=WDTP(0)+WDTP(I)
25075 IF(MDME(IDC,1).GT.0) THEN
25076 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25077 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25078 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25079 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25080 ENDIF
25081 200 CONTINUE
25082
25083 ELSEIF(KFLA.EQ.23) THEN
25084C...Z0:
25085 ICASE=1
25086 XWC=1D0/(16D0*XW*XW1)
25087 FAC=(AEM*XWC/3D0)*SHR
25088 210 CONTINUE
25089 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25090 VINT(111)=0D0
25091 VINT(112)=0D0
25092 VINT(114)=0D0
25093 ENDIF
25094 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25095 KFI=IABS(MINT(15))
25096 IF(KFI.GT.20) KFI=IABS(MINT(16))
25097 EI=KCHG(KFI,1)/3D0
25098 AI=SIGN(1D0,EI)
25099 VI=AI-4D0*EI*XWV
25100 SQMZ=PMAS(23,1)**2
25101 HZ=SHR*WDTP(0)
25102 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25103 IF(MSTP(43).EQ.3) VINT(112)=
25104 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25105 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25106 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25107 ENDIF
25108 DO 220 I=1,MDCY(KC,3)
25109 IDC=I+MDCY(KC,2)-1
25110 IF(MDME(IDC,1).LT.0) GOTO 220
25111 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25112 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25113 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25114 WID2=1D0
25115 IF(I.LE.8) THEN
25116C...Z0 -> q + qbar
25117 EF=KCHG(I,1)/3D0
25118 AF=SIGN(1D0,EF+0.1D0)
25119 VF=AF-4D0*EF*XWV
25120 FCOF=3D0*RADC
25121 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25122 IF(I.EQ.6) WID2=WIDS(6,1)
25123 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25124 ELSEIF(I.LE.16) THEN
25125C...Z0 -> l+ + l-, nu + nubar
25126 EF=KCHG(I+2,1)/3D0
25127 AF=SIGN(1D0,EF+0.1D0)
25128 VF=AF-4D0*EF*XWV
25129 FCOF=1D0
25130 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25131 ENDIF
25132 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25133 IF(ICASE.EQ.1) THEN
25134 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25135 & BE34
25136 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25137 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25138 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25139 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25140 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25141 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25142 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25143 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25144 ENDIF
25145 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25146 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25147 IF(MDME(IDC,1).GT.0) THEN
25148 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25149 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25150 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25151 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25152 & WDTE(I,MDME(IDC,1))
25153 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25154 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25155 ENDIF
25156 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25157 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25158 & VINT(111)+FGGF*WID2
25159 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25160 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25161 & VINT(114)+FZZF*WID2
25162 ENDIF
25163 ENDIF
25164 220 CONTINUE
25165 IF(MINT(61).GE.1) ICASE=3-ICASE
25166 IF(ICASE.EQ.2) GOTO 210
25167
25168 ELSEIF(KFLA.EQ.24) THEN
25169C...W+/-:
25170 FAC=(AEM/(24D0*XW))*SHR
25171 DO 230 I=1,MDCY(KC,3)
25172 IDC=I+MDCY(KC,2)-1
25173 IF(MDME(IDC,1).LT.0) GOTO 230
25174 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25175 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25176 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25177 WID2=1D0
25178 IF(I.LE.16) THEN
25179C...W+/- -> q + qbar'
25180 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25181 IF(KFLR.GT.0) THEN
25182 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25183 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25184 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25185 ELSE
25186 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25187 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25188 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25189 ENDIF
25190 ELSEIF(I.LE.20) THEN
25191C...W+/- -> l+/- + nu
25192 FCOF=1D0
25193 IF(KFLR.GT.0) THEN
25194 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25195 ELSE
25196 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25197 ENDIF
25198 ENDIF
25199 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25200 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25201 WDTP(I)=FUDGE*WDTP(I)
25202 WDTP(0)=WDTP(0)+WDTP(I)
25203 IF(MDME(IDC,1).GT.0) THEN
25204 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25205 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25206 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25207 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25208 ENDIF
25209 230 CONTINUE
25210
25211 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25212C...h0 (or H0, or A0):
25213 SHFS=SH
25214 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25215 DO 270 I=1,MDCY(KFHIGG,3)
25216 IDC=I+MDCY(KFHIGG,2)-1
25217 IF(MDME(IDC,1).LT.0) GOTO 270
25218 KFC1=PYCOMP(KFDP(IDC,1))
25219 KFC2=PYCOMP(KFDP(IDC,2))
25220 RM1=PMAS(KFC1,1)**2/SH
25221 RM2=PMAS(KFC2,1)**2/SH
25222 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25223 & GOTO 270
25224 WID2=1D0
25225
25226 IF(I.LE.8) THEN
25227C...h0 -> q + qbar
25228 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25229 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25230C...A0 behaves like beta, ho and H0 like beta**3.
25231 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25232 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25233 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25234 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25235 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25236 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25237 IF(IHIGG.NE.3) THEN
25238 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25239 & PARU(151+10*IHIGG))**2
25240 ENDIF
25241 ENDIF
25242 ENDIF
25243 IF(I.EQ.6) WID2=WIDS(6,1)
25244 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25245 ELSEIF(I.LE.12) THEN
25246C...h0 -> l+ + l-
25247 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25248C...A0 behaves like beta, ho and H0 like beta**3.
25249 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25250 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25251 & PARU(153+10*IHIGG)**2
25252 IF(I.EQ.12) WID2=WIDS(17,1)
25253
25254 ELSEIF(I.EQ.13) THEN
25255C...h0 -> g + g; quark loop contribution only
25256 ETARE=0D0
25257 ETAIM=0D0
25258 DO 240 J=1,2*MSTP(1)
25259 EPS=(2D0*PMAS(J,1))**2/SH
25260C...Loop integral; function of eps=4m^2/shat; different for A0.
25261 IF(EPS.LE.1D0) THEN
25262 IF(EPS.GT.1D-4) THEN
25263 ROOT=SQRT(1D0-EPS)
25264 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25265 ELSE
25266 RLN=LOG(4D0/EPS-2D0)
25267 ENDIF
25268 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25269 PHIIM=0.5D0*PARU(1)*RLN
25270 ELSE
25271 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25272 PHIIM=0D0
25273 ENDIF
25274 IF(IHIGG.LE.2) THEN
25275 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25276 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25277 ELSE
25278 ETAREJ=-0.5D0*EPS*PHIRE
25279 ETAIMJ=-0.5D0*EPS*PHIIM
25280 ENDIF
25281C...Couplings (=1 for standard model Higgs).
25282 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25283 IF(MOD(J,2).EQ.1) THEN
25284 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25285 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25286 ELSE
25287 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25288 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25289 ENDIF
25290 ENDIF
25291 ETARE=ETARE+ETAREJ
25292 ETAIM=ETAIM+ETAIMJ
25293 240 CONTINUE
25294 ETA2=ETARE**2+ETAIM**2
25295 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25296
25297 ELSEIF(I.EQ.14) THEN
25298C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25299 ETARE=0D0
25300 ETAIM=0D0
25301 JMAX=3*MSTP(1)+1
25302 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25303 DO 250 J=1,JMAX
25304 IF(J.LE.2*MSTP(1)) THEN
25305 EJ=KCHG(J,1)/3D0
25306 EPS=(2D0*PMAS(J,1))**2/SH
25307 ELSEIF(J.LE.3*MSTP(1)) THEN
25308 JL=2*(J-2*MSTP(1))-1
25309 EJ=KCHG(10+JL,1)/3D0
25310 EPS=(2D0*PMAS(10+JL,1))**2/SH
25311 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25312 EPS=(2D0*PMAS(24,1))**2/SH
25313 ELSE
25314 EPS=(2D0*PMAS(37,1))**2/SH
25315 ENDIF
25316C...Loop integral; function of eps=4m^2/shat.
25317 IF(EPS.LE.1D0) THEN
25318 IF(EPS.GT.1D-4) THEN
25319 ROOT=SQRT(1D0-EPS)
25320 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25321 ELSE
25322 RLN=LOG(4D0/EPS-2D0)
25323 ENDIF
25324 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25325 PHIIM=0.5D0*PARU(1)*RLN
25326 ELSE
25327 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25328 PHIIM=0D0
25329 ENDIF
25330 IF(J.LE.3*MSTP(1)) THEN
25331C...Fermion loops: loop integral different for A0; charges.
25332 IF(IHIGG.LE.2) THEN
25333 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25334 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25335 ELSE
25336 PHIPRE=-0.5D0*EPS*PHIRE
25337 PHIPIM=-0.5D0*EPS*PHIIM
25338 ENDIF
25339 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25340 EJC=3D0*EJ**2
25341 EJH=PARU(151+10*IHIGG)
25342 ELSEIF(J.LE.2*MSTP(1)) THEN
25343 EJC=3D0*EJ**2
25344 EJH=PARU(152+10*IHIGG)
25345 ELSE
25346 EJC=EJ**2
25347 EJH=PARU(153+10*IHIGG)
25348 ENDIF
25349 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25350 ETAREJ=EJC*EJH*PHIPRE
25351 ETAIMJ=EJC*EJH*PHIPIM
25352 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25353C...W loops: loop integral and charges.
25354 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25355 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25356 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25357 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25358 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25359 ENDIF
25360 ELSE
25361C...Charged H loops: loop integral and charges.
25362 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25363 & PARU(158+10*IHIGG+2*(IHIGG/3))
25364 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25365 ETAIMJ=-EPS**2*PHIIM*FACHHH
25366 ENDIF
25367 ETARE=ETARE+ETAREJ
25368 ETAIM=ETAIM+ETAIMJ
25369 250 CONTINUE
25370 ETA2=ETARE**2+ETAIM**2
25371 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25372
25373 ELSEIF(I.EQ.15) THEN
25374C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25375 ETARE=0D0
25376 ETAIM=0D0
25377 JMAX=3*MSTP(1)+1
25378 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25379 DO 260 J=1,JMAX
25380 IF(J.LE.2*MSTP(1)) THEN
25381 EJ=KCHG(J,1)/3D0
25382 AJ=SIGN(1D0,EJ+0.1D0)
25383 VJ=AJ-4D0*EJ*XWV
25384 EPS=(2D0*PMAS(J,1))**2/SH
25385 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25386 ELSEIF(J.LE.3*MSTP(1)) THEN
25387 JL=2*(J-2*MSTP(1))-1
25388 EJ=KCHG(10+JL,1)/3D0
25389 AJ=SIGN(1D0,EJ+0.1D0)
25390 VJ=AJ-4D0*EJ*XWV
25391 EPS=(2D0*PMAS(10+JL,1))**2/SH
25392 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25393 ELSE
25394 EPS=(2D0*PMAS(24,1))**2/SH
25395 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25396 ENDIF
25397C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25398 IF(EPS.LE.1D0) THEN
25399 ROOT=SQRT(1D0-EPS)
25400 IF(EPS.GT.1D-4) THEN
25401 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25402 ELSE
25403 RLN=LOG(4D0/EPS-2D0)
25404 ENDIF
25405 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25406 PHIIM=0.5D0*PARU(1)*RLN
25407 PSIRE=0.5D0*ROOT*RLN
25408 PSIIM=-0.5D0*ROOT*PARU(1)
25409 ELSE
25410 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25411 PHIIM=0D0
25412 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25413 PSIIM=0D0
25414 ENDIF
25415 IF(EPSP.LE.1D0) THEN
25416 ROOT=SQRT(1D0-EPSP)
25417 IF(EPSP.GT.1D-4) THEN
25418 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25419 ELSE
25420 RLN=LOG(4D0/EPSP-2D0)
25421 ENDIF
25422 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25423 PHIIMP=0.5D0*PARU(1)*RLN
25424 PSIREP=0.5D0*ROOT*RLN
25425 PSIIMP=-0.5D0*ROOT*PARU(1)
25426 ELSE
25427 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25428 PHIIMP=0D0
25429 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25430 PSIIMP=0D0
25431 ENDIF
25432 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25433 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25434 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25435 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25436 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25437 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25438 IF(J.LE.3*MSTP(1)) THEN
25439C...Fermion loops: loop integral different for A0; charges.
25440 IF(IHIGG.EQ.3) FXYRE=0D0
25441 IF(IHIGG.EQ.3) FXYIM=0D0
25442 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25443 EJC=-3D0*EJ*VJ
25444 EJH=PARU(151+10*IHIGG)
25445 ELSEIF(J.LE.2*MSTP(1)) THEN
25446 EJC=-3D0*EJ*VJ
25447 EJH=PARU(152+10*IHIGG)
25448 ELSE
25449 EJC=-EJ*VJ
25450 EJH=PARU(153+10*IHIGG)
25451 ENDIF
25452 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25453 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25454 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25455 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25456C...W loops: loop integral and charges.
25457 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25458 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25459 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25460 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25461 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25462 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25463 ENDIF
25464 ELSE
25465C...Charged H loops: loop integral and charges.
25466 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25467 & PARU(158+10*IHIGG+2*(IHIGG/3))
25468 ETAREJ=FACHHH*FXYRE
25469 ETAIMJ=FACHHH*FXYIM
25470 ENDIF
25471 ETARE=ETARE+ETAREJ
25472 ETAIM=ETAIM+ETAIMJ
25473 260 CONTINUE
25474 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25475 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25476 WID2=WIDS(23,2)
25477
25478 ELSEIF(I.LE.17) THEN
25479C...h0 -> Z0 + Z0, W+ + W-
25480 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25481 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25482 IF(MINT(62).GE.1) THEN
25483 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25484 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25485 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25486 MOFSV(IHIGG,I-15)=0
25487 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25488 & 1D0-4D0*RM1))
25489 WID2=1D0
25490 ELSE
25491 MOFSV(IHIGG,I-15)=1
25492 RMAS=SQRT(MAX(0D0,SH))
25493 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25494 & WID2)
25495 WIDWSV(IHIGG,I-15)=WIDW
25496 WID2SV(IHIGG,I-15)=WID2
25497 ENDIF
25498 ELSE
25499 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25500 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25501 & 1D0-4D0*RM1))
25502 WID2=1D0
25503 ELSE
25504 WIDW=WIDWSV(IHIGG,I-15)
25505 WID2=WID2SV(IHIGG,I-15)
25506 ENDIF
25507 ENDIF
25508 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25509 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25510 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25511 & PARU(138+I+10*IHIGG)**2
25512 WID2=WID2*WIDS(7+I,1)
25513
25514 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25515C...H0 -> Z0 + h0, A0-> Z0 + h0
25516 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25517 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25518 IF(IHIGG.EQ.2) THEN
25519 WDTP(I)=WDTP(I)*PARU(179)**2
25520 ELSEIF(IHIGG.EQ.3) THEN
25521 WDTP(I)=WDTP(I)*PARU(186)**2
25522 ENDIF
25523 WID2=WIDS(23,2)*WIDS(25,2)
25524
25525 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25526C...H0 -> h0 + h0, A0-> h0 + h0
25527 WDTP(I)=FAC*0.25D0*
25528 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25529 IF(IHIGG.EQ.2) THEN
25530 WDTP(I)=WDTP(I)*PARU(176)**2
25531 ELSEIF(IHIGG.EQ.3) THEN
25532 WDTP(I)=WDTP(I)*PARU(169)**2
25533 ENDIF
25534 WID2=WIDS(25,1)
25535 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25536C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25537 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25538 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25539 & *PARU(195+IHIGG)**2
25540 IF(I.EQ.20) THEN
25541 WID2=WIDS(24,2)*WIDS(37,3)
25542 ELSEIF(I.EQ.21) THEN
25543 WID2=WIDS(24,3)*WIDS(37,2)
25544 ENDIF
25545
25546 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25547C...H0 -> Z0 + A0.
25548 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25549 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25550 WID2=WIDS(36,2)*WIDS(23,2)
25551
25552 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25553C...H0 -> h0 + A0.
25554 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25555 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25556 WID2=WIDS(25,2)*WIDS(36,2)
25557
25558 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25559C...H0 -> A0 + A0
25560 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25561 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25562 WID2=WIDS(36,1)
25563
25564CMRENNA++
25565 ELSE
25566C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25567 RM10=RM1*SH/PMR**2
25568 RM20=RM2*SH/PMR**2
25569 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25570 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25571 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25572 WFAC=0D0
25573 ELSE
25574 WFAC=WFAC/WFAC0
25575 ENDIF
25576 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25577CMRENNA--
25578 IF(KFC2.EQ.KFC1) THEN
25579 WID2=WIDS(KFC1,1)
25580 ELSE
25581 KSGN1=2
25582 IF(KFDP(IDC,1).LT.0) KSGN1=3
25583 KSGN2=2
25584 IF(KFDP(IDC,2).LT.0) KSGN2=3
25585 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25586 ENDIF
25587 ENDIF
25588 WDTP(I)=FUDGE*WDTP(I)
25589 WDTP(0)=WDTP(0)+WDTP(I)
25590 IF(MDME(IDC,1).GT.0) THEN
25591 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25592 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25593 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25594 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25595 ENDIF
25596 270 CONTINUE
25597
25598 ELSEIF(KFLA.EQ.32) THEN
25599C...Z'0:
25600 ICASE=1
25601 XWC=1D0/(16D0*XW*XW1)
25602 FAC=(AEM*XWC/3D0)*SHR
25603 VINT(117)=0D0
25604 280 CONTINUE
25605 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25606 VINT(111)=0D0
25607 VINT(112)=0D0
25608 VINT(113)=0D0
25609 VINT(114)=0D0
25610 VINT(115)=0D0
25611 VINT(116)=0D0
25612 ENDIF
25613 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25614 KFAI=IABS(MINT(15))
25615 EI=KCHG(KFAI,1)/3D0
25616 AI=SIGN(1D0,EI+0.1D0)
25617 VI=AI-4D0*EI*XWV
25618 KFAIC=1
25619 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25620 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25621 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25622 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25623 VPI=PARU(119+2*KFAIC)
25624 API=PARU(120+2*KFAIC)
25625 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25626 VPI=PARJ(178+2*KFAIC)
25627 API=PARJ(179+2*KFAIC)
25628 ELSE
25629 VPI=PARJ(186+2*KFAIC)
25630 API=PARJ(187+2*KFAIC)
25631 ENDIF
25632 SQMZ=PMAS(23,1)**2
25633 HZ=SHR*VINT(117)
25634 SQMZP=PMAS(32,1)**2
25635 HZP=SHR*WDTP(0)
25636 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25637 & MSTP(44).EQ.7) VINT(111)=1D0
25638 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25639 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25640 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25641 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25642 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25643 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25644 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25645 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25646 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25647 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25648 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25649 ENDIF
25650 DO 290 I=1,MDCY(KC,3)
25651 IDC=I+MDCY(KC,2)-1
25652 IF(MDME(IDC,1).LT.0) GOTO 290
25653 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25654 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25656 WID2=1D0
25657 IF(I.LE.16) THEN
25658 IF(I.LE.8) THEN
25659C...Z'0 -> q + qbar
25660 EF=KCHG(I,1)/3D0
25661 AF=SIGN(1D0,EF+0.1D0)
25662 VF=AF-4D0*EF*XWV
25663 IF(I.LE.2) THEN
25664 VPF=PARU(123-2*MOD(I,2))
25665 APF=PARU(124-2*MOD(I,2))
25666 ELSEIF(I.LE.4) THEN
25667 VPF=PARJ(182-2*MOD(I,2))
25668 APF=PARJ(183-2*MOD(I,2))
25669 ELSE
25670 VPF=PARJ(190-2*MOD(I,2))
25671 APF=PARJ(191-2*MOD(I,2))
25672 ENDIF
25673 FCOF=3D0*RADC
25674 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25675 & PYHFTH(SH,SH*RM1,1D0)
25676 IF(I.EQ.6) WID2=WIDS(6,1)
25677 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25678 ELSEIF(I.LE.16) THEN
25679C...Z'0 -> l+ + l-, nu + nubar
25680 EF=KCHG(I+2,1)/3D0
25681 AF=SIGN(1D0,EF+0.1D0)
25682 VF=AF-4D0*EF*XWV
25683 IF(I.LE.10) THEN
25684 VPF=PARU(127-2*MOD(I,2))
25685 APF=PARU(128-2*MOD(I,2))
25686 ELSEIF(I.LE.12) THEN
25687 VPF=PARJ(186-2*MOD(I,2))
25688 APF=PARJ(187-2*MOD(I,2))
25689 ELSE
25690 VPF=PARJ(194-2*MOD(I,2))
25691 APF=PARJ(195-2*MOD(I,2))
25692 ENDIF
25693 FCOF=1D0
25694 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25695 ENDIF
25696 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25697 IF(ICASE.EQ.1) THEN
25698 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25699 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25700 & APF**2*(1D0-4D0*RM1))*BE34
25701 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25702 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25703 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25704 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25705 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25706 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25707 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25708 ELSEIF(MINT(61).EQ.2) THEN
25709 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25710 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25711 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25712 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25713 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25714 & BE34
25715 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25716 & BE34
25717 ENDIF
25718 ELSEIF(I.EQ.17) THEN
25719C...Z'0 -> W+ + W-
25720 WDTPZP=PARU(129)**2*XW1**2*
25721 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25722 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25723 IF(ICASE.EQ.1) THEN
25724 WDTPZ=0D0
25725 WDTP(I)=FAC*WDTPZP
25726 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25727 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25728 ELSEIF(MINT(61).EQ.2) THEN
25729 FGGF=0D0
25730 FGZF=0D0
25731 FGZPF=0D0
25732 FZZF=0D0
25733 FZZPF=0D0
25734 FZPZPF=WDTPZP
25735 ENDIF
25736 WID2=WIDS(24,1)
25737 ELSEIF(I.EQ.18) THEN
25738C...Z'0 -> H+ + H-
25739 CZC=2D0*(1D0-2D0*XW)
25740 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25741 IF(ICASE.EQ.1) THEN
25742 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25743 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25744 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25745 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25746 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25747 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25748 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25749 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25750 ELSEIF(MINT(61).EQ.2) THEN
25751 FGGF=0.25D0*BE34C
25752 FGZF=0.25D0*PARU(142)*CZC*BE34C
25753 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25754 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25755 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25756 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25757 ENDIF
25758 WID2=WIDS(37,1)
25759 ELSEIF(I.EQ.19) THEN
25760C...Z'0 -> Z0 + gamma.
25761 ELSEIF(I.EQ.20) THEN
25762C...Z'0 -> Z0 + h0
25763 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25764 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25765 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25766 IF(ICASE.EQ.1) THEN
25767 WDTPZ=0D0
25768 WDTP(I)=FAC*WDTPZP
25769 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25770 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25771 ELSEIF(MINT(61).EQ.2) THEN
25772 FGGF=0D0
25773 FGZF=0D0
25774 FGZPF=0D0
25775 FZZF=0D0
25776 FZZPF=0D0
25777 FZPZPF=WDTPZP
25778 ENDIF
25779 WID2=WIDS(23,2)*WIDS(25,2)
25780 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25781C...Z' -> h0 + A0 or H0 + A0.
25782 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25783 IF(I.EQ.21) THEN
25784 CZAH=PARU(186)
25785 CZPAH=PARU(188)
25786 ELSE
25787 CZAH=PARU(187)
25788 CZPAH=PARU(189)
25789 ENDIF
25790 IF(ICASE.EQ.1) THEN
25791 WDTPZ=CZAH**2*BE34C
25792 WDTP(I)=FAC*CZPAH**2*BE34C
25793 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25794 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25795 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25796 & VINT(116))*BE34C
25797 ELSEIF(MINT(61).EQ.2) THEN
25798 FGGF=0D0
25799 FGZF=0D0
25800 FGZPF=0D0
25801 FZZF=CZAH**2*BE34C
25802 FZZPF=CZAH*CZPAH*BE34C
25803 FZPZPF=CZPAH**2*BE34C
25804 ENDIF
25805 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25806 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25807 ENDIF
25808 IF(ICASE.EQ.1) THEN
25809 VINT(117)=VINT(117)+FAC*WDTPZ
25810 WDTP(I)=FUDGE*WDTP(I)
25811 WDTP(0)=WDTP(0)+WDTP(I)
25812 ENDIF
25813 IF(MDME(IDC,1).GT.0) THEN
25814 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25815 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25816 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25817 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25818 & WDTE(I,MDME(IDC,1))
25819 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25820 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25821 ENDIF
25822 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25823 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25824 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25825 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25826 & FGZF*WID2
25827 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25828 & FGZPF*WID2
25829 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25830 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25831 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25832 & FZZPF*WID2
25833 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25834 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25835 ENDIF
25836 ENDIF
25837 290 CONTINUE
25838 IF(MINT(61).GE.1) ICASE=3-ICASE
25839 IF(ICASE.EQ.2) GOTO 280
25840
25841 ELSEIF(KFLA.EQ.34) THEN
25842C...W'+/-:
25843 FAC=(AEM/(24D0*XW))*SHR
25844 DO 300 I=1,MDCY(KC,3)
25845 IDC=I+MDCY(KC,2)-1
25846 IF(MDME(IDC,1).LT.0) GOTO 300
25847 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25848 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25849 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25850 WID2=1D0
25851 IF(I.LE.20) THEN
25852 IF(I.LE.16) THEN
25853C...W'+/- -> q + qbar'
25854 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25855 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25856 IF(KFLR.GT.0) THEN
25857 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25858 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25859 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25860 ELSE
25861 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25862 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25863 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25864 ENDIF
25865 ELSEIF(I.LE.20) THEN
25866C...W'+/- -> l+/- + nu
25867 FCOF=PARU(133)**2+PARU(134)**2
25868 IF(KFLR.GT.0) THEN
25869 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25870 ELSE
25871 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25872 ENDIF
25873 ENDIF
25874 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25875 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25876 ELSEIF(I.EQ.21) THEN
25877C...W'+/- -> W+/- + Z0
25878 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25880 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25881 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25882 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25883 ELSEIF(I.EQ.23) THEN
25884C...W'+/- -> W+/- + h0
25885 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25886 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25887 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25888 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25889 ENDIF
25890 WDTP(I)=FUDGE*WDTP(I)
25891 WDTP(0)=WDTP(0)+WDTP(I)
25892 IF(MDME(IDC,1).GT.0) THEN
25893 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25894 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25895 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25896 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25897 ENDIF
25898 300 CONTINUE
25899
25900 ELSEIF(KFLA.EQ.37) THEN
25901C...H+/-:
25902C IF(MSTP(49).EQ.0) THEN
25903 SHFS=SH
25904C ELSE
25905C SHFS=PMAS(37,1)**2
25906C ENDIF
25907 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25908 DO 310 I=1,MDCY(KC,3)
25909 IDC=I+MDCY(KC,2)-1
25910 IF(MDME(IDC,1).LT.0) GOTO 310
25911 KFC1=PYCOMP(KFDP(IDC,1))
25912 KFC2=PYCOMP(KFDP(IDC,2))
25913 RM1=PMAS(KFC1,1)**2/SH
25914 RM2=PMAS(KFC2,1)**2/SH
25915 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25916 WID2=1D0
25917 IF(I.LE.4) THEN
25918C...H+/- -> q + qbar'
25919 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25920 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25921 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25922 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25923 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25924 IF(KFLR.GT.0) THEN
25925 IF(I.EQ.3) WID2=WIDS(6,2)
25926 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25927 ELSE
25928 IF(I.EQ.3) WID2=WIDS(6,3)
25929 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25930 ENDIF
25931 ELSEIF(I.LE.8) THEN
25932C...H+/- -> l+/- + nu
25933 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25934 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25935 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25936 IF(KFLR.GT.0) THEN
25937 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25938 ELSE
25939 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25940 ENDIF
25941 ELSEIF(I.EQ.9) THEN
25942C...H+/- -> W+/- + h0.
25943 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25944 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25945 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25946 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25947
25948CMRENNA++
25949 ELSE
25950C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25951 RM10=RM1*SH/PMR**2
25952 RM20=RM2*SH/PMR**2
25953 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25954 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25955 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25956 WFAC=0D0
25957 ELSE
25958 WFAC=WFAC/WFAC0
25959 ENDIF
25960 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25961CMRENNA--
25962 KSGN1=2
25963 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25964 KSGN2=2
25965 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25966 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25967 ENDIF
25968 WDTP(I)=FUDGE*WDTP(I)
25969 WDTP(0)=WDTP(0)+WDTP(I)
25970 IF(MDME(IDC,1).GT.0) THEN
25971 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25972 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25973 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25974 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25975 ENDIF
25976 310 CONTINUE
25977
25978 ELSEIF(KFLA.EQ.41) THEN
25979C...R:
25980 FAC=(AEM/(12D0*XW))*SHR
25981 DO 320 I=1,MDCY(KC,3)
25982 IDC=I+MDCY(KC,2)-1
25983 IF(MDME(IDC,1).LT.0) GOTO 320
25984 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25985 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25986 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25987 WID2=1D0
25988 IF(I.LE.6) THEN
25989C...R -> q + qbar'
25990 FCOF=3D0*RADC
25991 ELSEIF(I.LE.9) THEN
25992C...R -> l+ + l'-
25993 FCOF=1D0
25994 ENDIF
25995 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25996 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25997 IF(KFLR.GT.0) THEN
25998 IF(I.EQ.4) WID2=WIDS(6,3)
25999 IF(I.EQ.5) WID2=WIDS(7,3)
26000 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26001 IF(I.EQ.9) WID2=WIDS(17,3)
26002 ELSE
26003 IF(I.EQ.4) WID2=WIDS(6,2)
26004 IF(I.EQ.5) WID2=WIDS(7,2)
26005 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26006 IF(I.EQ.9) WID2=WIDS(17,2)
26007 ENDIF
26008 WDTP(I)=FUDGE*WDTP(I)
26009 WDTP(0)=WDTP(0)+WDTP(I)
26010 IF(MDME(IDC,1).GT.0) THEN
26011 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26012 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26013 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26014 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26015 ENDIF
26016 320 CONTINUE
26017
26018 ELSEIF(KFLA.EQ.42) THEN
26019C...LQ (leptoquark).
26020 FAC=(AEM/4D0)*PARU(151)*SHR
26021 DO 330 I=1,MDCY(KC,3)
26022 IDC=I+MDCY(KC,2)-1
26023 IF(MDME(IDC,1).LT.0) GOTO 330
26024 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26025 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26026 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26027 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26028 WID2=1D0
26029 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26030 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26031 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26032 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26033 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26034 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26035 WDTP(I)=FUDGE*WDTP(I)
26036 WDTP(0)=WDTP(0)+WDTP(I)
26037 IF(MDME(IDC,1).GT.0) THEN
26038 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26039 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26040 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26041 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26042 ENDIF
26043 330 CONTINUE
26044
26045C...UED: kk state width decays : flav: 451 476
26046 ELSEIF(IUED(1).EQ.1.AND.
26047 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26048 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26049 KCLA=PYCOMP(KFLA)
26050C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26051 RMFLAS=PMAS(KCLA,1)
26052 FACSH=SH/PMAS(KCLA,1)**2
26053 ALPHEM=PYALEM(RMFLAS**2)
26054 ALPHS=PYALPS(RMFLAS**2)
26055
26056C...uedcor parameters (alpha_s is calculated at mkk scale)
26057C...alpha_em is calculated at z pole !
26058 ALPHEM=PARU(101)
26059 FACSH=1.
26060
26061 DO 1070 I=1,MDCY(KCLA,3)
26062 IDC=I+MDCY(KCLA,2)-1
26063
26064 IF(MDME(IDC,1).LT.0) GOTO 1070
26065 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26066 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26067 RM1=PMAS(KFC1,1)**2/SH
26068 RM2=PMAS(KFC2,1)**2/SH
26069 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26070 & GOTO 1070
26071 WID2=1D0
26072
26073C...N.B. RINV=RUED(1)
26074 RMKK=RUED(1)
26075 RMWKK=PMAS(475,1)
26076 RMZKK=PMAS(474,1)
26077 SW2=PARU(102)
26078 CW2=1.-SW2
26079 KKCLA=KCLA-KKFLMI+1
26080 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26081 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26082 IF(KKCLA.LE.6) THEN
26083C...q*_S -> q + gamma* (in first time sw21=0)
26084 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26085C...Eventually change the following by enabling a choice of open or closed.
26086C...Only the gamma_kk channel is open.
26087 IF(MOD(I,2).EQ.0)
26088 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26089 WDTP(I)=FACSH*WDTP(I)
26090 WID2=WIDS(473,2)
26091 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26092C...q*_D -> q + Z*/W*
26093 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26094 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26095 IF(I.EQ.1)THEN
26096C...q*_D -> q + Z*
26097 WDTP(I)=0.5*GAMMAW
26098 WID2=WIDS(474,2)
26099 ELSEIF(I.EQ.2)THEN
26100C...q*_D -> q + W*
26101 WDTP(I)=GAMMAW
26102 WID2=WIDS(475,2)
26103 ENDIF
26104 WDTP(I)=FACSH*WDTP(I)
26105C...q*_D -> q + gamma* is closed
26106 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26107C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26108 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26109 RMGAKK=PMAS(473,1)
26110 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26111 + FKAC1(RMGAKK,RMFLAS)**2
26112 WDTP(I)=FACSH*WDTP(I)
26113 WID2=WIDS(473,2)
26114 ELSEIF(KKCLA.EQ.22)THEN
26115 RMQST=PMAS(KKPART,1)
26116 WID2=WIDS(KKPART,2)
26117C...g* -> q*_S/q*_D + q
26118 FAC=10.*ALPHS/12.*RMFLAS
26119 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26120 WDTP(I)=FACSH*WDTP(I)
26121 ELSEIF(KKCLA.EQ.23)THEN
26122C...gamma* decays to graviton + gamma : initial value is used
26123 ICHI=IUED(4)/2
26124 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26125 & *CHIDEL(ICHI)
26126 ELSEIF(KKCLA.EQ.24)THEN
26127C...Z* -> l*_S + l is closed
26128C... Z* -> l*_D + l
26129 IF(I.LE.3)GOTO 1070
26130c... After closing the channels for a Z* decaying into positively charged
26131C... KK lepton singlets, close the channels for a Z* decaying into negatively
26132C... charged KK lepton singlets + positively charged SM particles
26133 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26134 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26135 RMLST=PMAS(KKPART,1)
26136 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26137 WDTP(I)=FACSH*WDTP(I)
26138 WID2=WIDS(KKPART,2)
26139 ELSEIF(KKCLA.EQ.25)THEN
26140C...W* -> l*_D lbar
26141 FAC=3.*ALPHEM/12./SW2*RMWKK
26142 RMLST=PMAS(KKPART,1)
26143 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26144 WDTP(I)=FACSH*WDTP(I)
26145 WID2=WIDS(KKPART,2)
26146 ENDIF
26147 WDTP(0)=WDTP(0)+WDTP(I)
26148 IF(MDME(IDC,1).GT.0) THEN
26149 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26150 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26151 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26152 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26153 ENDIF
26154 1070 CONTINUE
26155 IUEDPR(KKCLA)=1
26156
26157 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26158C...Techni-pi0 and techni-pi0':
26159 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26160 DO 340 I=1,MDCY(KC,3)
26161 IDC=I+MDCY(KC,2)-1
26162 IF(MDME(IDC,1).LT.0) GOTO 340
26163 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26164 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26165 RM1=PM1**2/SH
26166 RM2=PM2**2/SH
26167 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26168 WID2=1D0
26169C...pi_tc -> g + g
26170 IF(I.EQ.8) THEN
26171 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26172 & /(8D0*PARU(1))*SH*SHR
26173 IF(KFLA.EQ.KTECHN+111) THEN
26174 FACP=FACP*RTCM(9)
26175 ELSE
26176 FACP=FACP*RTCM(10)
26177 ENDIF
26178 WDTP(I)=FACP
26179 ELSE
26180C...pi_tc -> f + fbar.
26181 FCOF=1D0
26182 IKA=IABS(KFDP(IDC,1))
26183 IF(IKA.LT.10) FCOF=3D0*RADC
26184 HM1=PM1
26185 HM2=PM2
26186 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26187 FCOF=FCOF*RTCM(1+IKA)**2
26188 HM1=PYMRUN(KFDP(IDC,1),SH)
26189 HM2=PYMRUN(KFDP(IDC,2),SH)
26190 ELSEIF(IKA.EQ.15) THEN
26191 FCOF=FCOF*RTCM(8)**2
26192 ENDIF
26193 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26194 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26195 ENDIF
26196 WDTP(I)=FUDGE*WDTP(I)
26197 WDTP(0)=WDTP(0)+WDTP(I)
26198 IF(MDME(IDC,1).GT.0) THEN
26199 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26200 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26201 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26202 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26203 ENDIF
26204 340 CONTINUE
26205
26206 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26207C...pi+_tc
26208 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26209 DO 350 I=1,MDCY(KC,3)
26210 IDC=I+MDCY(KC,2)-1
26211 IF(MDME(IDC,1).LT.0) GOTO 350
26212 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26213 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26214 PM3=0D0
26215 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26216 RM1=PM1**2/SH
26217 RM2=PM2**2/SH
26218 RM3=PM3**2/SH
26219 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26220 WID2=1D0
26221C...pi_tc -> f + f'.
26222 FCOF=1D0
26223 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26224C...pi_tc+ -> W b b~
26225 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26226 FCOF=3D0*RADC
26227 XMT2=PMAS(6,1)**2/SH
26228 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26229 KFC3=PYCOMP(KFDP(IDC,3))
26230 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26231 CHECK = SQRT(RM1)
26232 T0 = (1D0-CHECK**2)*
26233 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26234 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26235 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26236 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26237 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26238 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26239 & +T3*LOG(CHECK))
26240 IF(KFLR.GT.0) THEN
26241 WID2=WIDS(24,2)
26242 ELSE
26243 WID2=WIDS(24,3)
26244 ENDIF
26245 ELSE
26246 FCOF=1D0
26247 IKA=IABS(KFDP(IDC,1))
26248 IF(IKA.LT.10) FCOF=3D0*RADC
26249 HM1=PM1
26250 HM2=PM2
26251 IF(I.GE.1.AND.I.LE.5) THEN
26252 IF(I.LE.2) THEN
26253 FCOF=FCOF*RTCM(5)**2
26254 ELSEIF(I.LE.4) THEN
26255 FCOF=FCOF*RTCM(6)**2
26256 ELSEIF(I.EQ.5) THEN
26257 FCOF=FCOF*RTCM(7)**2
26258 ENDIF
26259 HM1=PYMRUN(KFDP(IDC,1),SH)
26260 HM2=PYMRUN(KFDP(IDC,2),SH)
26261 ELSEIF(I.EQ.8) THEN
26262 FCOF=FCOF*RTCM(8)**2
26263 ENDIF
26264 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26265 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26266 ENDIF
26267 WDTP(I)=FUDGE*WDTP(I)
26268 WDTP(0)=WDTP(0)+WDTP(I)
26269 IF(MDME(IDC,1).GT.0) THEN
26270 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26271 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26272 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26273 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26274 ENDIF
26275 350 CONTINUE
26276
26277 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26278C...Techni-eta.
26279 FAC=(SH/PARP(46)**2)*SHR
26280 DO 360 I=1,MDCY(KC,3)
26281 IDC=I+MDCY(KC,2)-1
26282 IF(MDME(IDC,1).LT.0) GOTO 360
26283 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26284 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26285 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26286 WID2=1D0
26287 IF(I.LE.2) THEN
26288 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26289 IF(I.EQ.2) WID2=WIDS(6,1)
26290 ELSE
26291 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26292 ENDIF
26293 WDTP(I)=FUDGE*WDTP(I)
26294 WDTP(0)=WDTP(0)+WDTP(I)
26295 IF(MDME(IDC,1).GT.0) THEN
26296 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26297 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26298 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26299 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26300 ENDIF
26301 360 CONTINUE
26302
26303 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26304C...Techni-rho0:
26305 ALPRHT=2.16D0*(3D0/ITCM(1))
26306 FAC=(ALPRHT/12D0)*SHR
26307 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26308 SQMZ=PMAS(23,1)**2
26309 SQMW=PMAS(24,1)**2
26310 SHP=SH
26311 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26312 GMMZ=SHR*WDTPP(0)
26313 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26314 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26315 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26316 DO 370 I=1,MDCY(KC,3)
26317 IDC=I+MDCY(KC,2)-1
26318 IF(MDME(IDC,1).LT.0) GOTO 370
26319 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26320 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26321 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26322 WID2=1D0
26323 IF(I.EQ.1) THEN
26324C...rho_tc0 -> W+ + W-.
26325C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26326 WDTP(I)=FAC*RTCM(3)**4*
26327 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26328 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26329 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26330 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26331 WID2=WIDS(24,1)
26332 ELSEIF(I.EQ.2) THEN
26333C...rho_tc0 -> W+ + pi_tc-.
26334C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26335 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26336 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26337 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26338 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26339 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26340 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26341 ELSEIF(I.EQ.3) THEN
26342C...rho_tc0 -> pi_tc+ + W-.
26343 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26344 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26345 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26346 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26347 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26348 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26349 ELSEIF(I.EQ.4) THEN
26350C...rho_tc0 -> pi_tc+ + pi_tc-.
26351 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26352 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26353 WID2=WIDS(PYCOMP(KTECHN+211),1)
26354 ELSEIF(I.EQ.5) THEN
26355C...rho_tc0 -> gamma + pi_tc0
26356 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26357 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26358 & SHR**3
26359 WID2=WIDS(PYCOMP(KTECHN+111),2)
26360 ELSEIF(I.EQ.6) THEN
26361C...rho_tc0 -> gamma + pi_tc0'
26362 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26363 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26364 WID2=WIDS(PYCOMP(KTECHN+221),2)
26365 ELSEIF(I.EQ.7) THEN
26366C...rho_tc0 -> Z0 + pi_tc0
26367 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26368 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26369 & XW/XW1*SHR**3
26370 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26371 ELSEIF(I.EQ.8) THEN
26372C...rho_tc0 -> Z0 + pi_tc0'
26373 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26374 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26375 & XW/XW1*SHR**3
26376 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26377 ELSEIF(I.EQ.9) THEN
26378C...rho_tc0 -> gamma + Z0
26379 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26380 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26381 WID2=WIDS(23,2)
26382 ELSEIF(I.EQ.10) THEN
26383C...rho_tc0 -> Z0 + Z0
26384 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26385 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26386 & SHR**3
26387 WID2=WIDS(23,1)
26388 ELSE
26389C...rho_tc0 -> f + fbar.
26390 WID2=1D0
26391 IF(I.LE.18) THEN
26392 IA=I-10
26393 FCOF=3D0*RADC
26394 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26395 ELSE
26396 IA=I-6
26397 FCOF=1D0
26398 IF(IA.GE.17) WID2=WIDS(IA,1)
26399 ENDIF
26400 EI=KCHG(IA,1)/3D0
26401 AI=SIGN(1D0,EI+0.1D0)
26402 VI=AI-4D0*EI*XWV
26403 VALI=0.5D0*(VI+AI)
26404 VARI=0.5D0*(VI-AI)
26405 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26406 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26407 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26408 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26409 ENDIF
26410 WDTP(I)=FUDGE*WDTP(I)
26411 WDTP(0)=WDTP(0)+WDTP(I)
26412 IF(MDME(IDC,1).GT.0) THEN
26413 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26414 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26415 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26416 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26417 ENDIF
26418 370 CONTINUE
26419
26420 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26421C...Techni-rho+/-:
26422 ALPRHT=2.16D0*(3D0/ITCM(1))
26423 FAC=(ALPRHT/12D0)*SHR
26424 SQMZ=PMAS(23,1)**2
26425 SQMW=PMAS(24,1)**2
26426 SHP=SH
26427 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26428 GMMW=SHR*WDTPP(0)
26429 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26430 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26431 DO 380 I=1,MDCY(KC,3)
26432 IDC=I+MDCY(KC,2)-1
26433 IF(MDME(IDC,1).LT.0) GOTO 380
26434 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26435 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26436 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26437 WID2=1D0
26438 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26439c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26440c & /3D0*SHR**3
26441 IF(I.EQ.1) THEN
26442C...rho_tc+ -> W+ + Z0.
26443C......Goldstone
26444 WDTP(I)=FAC*RTCM(3)**4*
26445 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26446 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26447 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26448C......W_L Z_T
26449 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26450 & /3D0*SHR**3
26451 VA2=0D0
26452 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26453C......W_T Z_L
26454 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26455 & /3D0*SHR**3
26456 IF(KFLR.GT.0) THEN
26457 WID2=WIDS(24,2)*WIDS(23,2)
26458 ELSE
26459 WID2=WIDS(24,3)*WIDS(23,2)
26460 ENDIF
26461 ELSEIF(I.EQ.2) THEN
26462C...rho_tc+ -> W+ + pi_tc0.
26463 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26464 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26465 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26466 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26467 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26468 IF(KFLR.GT.0) THEN
26469 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26470 ELSE
26471 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26472 ENDIF
26473 ELSEIF(I.EQ.3) THEN
26474C...rho_tc+ -> pi_tc+ + Z0.
26475 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26476 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26477 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26478 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26479 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26480 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26481 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26482 & SHR**3*XW/XW1
26483 IF(KFLR.GT.0) THEN
26484 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26485 ELSE
26486 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26487 ENDIF
26488 ELSEIF(I.EQ.4) THEN
26489C...rho_tc+ -> pi_tc+ + pi_tc0.
26490 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26491 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26492 IF(KFLR.GT.0) THEN
26493 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26494 ELSE
26495 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26496 ENDIF
26497 ELSEIF(I.EQ.5) THEN
26498C...rho_tc+ -> pi_tc+ + gamma
26499 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26500 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26501 & SHR**3
26502 IF(KFLR.GT.0) THEN
26503 WID2=WIDS(PYCOMP(KTECHN+211),2)
26504 ELSE
26505 WID2=WIDS(PYCOMP(KTECHN+211),3)
26506 ENDIF
26507 ELSEIF(I.EQ.6) THEN
26508C...rho_tc+ -> W+ + pi_tc0'
26509 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26510 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26511 IF(KFLR.GT.0) THEN
26512 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26513 ELSE
26514 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26515 ENDIF
26516 ELSEIF(I.EQ.7) THEN
26517C...rho_tc+ -> W+ + gamma
26518 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26519 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26520 IF(KFLR.GT.0) THEN
26521 WID2=WIDS(24,2)
26522 ELSE
26523 WID2=WIDS(24,3)
26524 ENDIF
26525 ELSE
26526C...rho_tc+ -> f + fbar'.
26527 IA=I-7
26528 WID2=1D0
26529 IF(IA.LE.16) THEN
26530 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26531 IF(KFLR.GT.0) THEN
26532 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26533 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26534 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26535 ELSE
26536 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26537 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26538 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26539 ENDIF
26540 ELSE
26541 FCOF=1D0
26542 IF(KFLR.GT.0) THEN
26543 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26544 ELSE
26545 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26546 ENDIF
26547 ENDIF
26548 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26549 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26550 ENDIF
26551 WDTP(I)=FUDGE*WDTP(I)
26552 WDTP(0)=WDTP(0)+WDTP(I)
26553 IF(MDME(IDC,1).GT.0) THEN
26554 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26555 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26556 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26557 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26558 ENDIF
26559 380 CONTINUE
26560
26561 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26562C...Techni-omega:
26563 ALPRHT=2.16D0*(3D0/ITCM(1))
26564 FAC=(ALPRHT/12D0)*SHR
26565 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26566 SQMZ=PMAS(23,1)**2
26567 SHP=SH
26568 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26569 GMMZ=SHR*WDTPP(0)
26570 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26571 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26572 DO 390 I=1,MDCY(KC,3)
26573 IDC=I+MDCY(KC,2)-1
26574 IF(MDME(IDC,1).LT.0) GOTO 390
26575 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26576 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26577 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26578 WID2=1D0
26579 IF(I.EQ.1) THEN
26580C...omega_tc0 -> gamma + pi_tc0.
26581 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26582 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26583 WID2=WIDS(PYCOMP(KTECHN+111),2)
26584 ELSEIF(I.EQ.2) THEN
26585C...omega_tc0 -> Z0 + pi_tc0
26586 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26587 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26588 & XW/XW1*SHR**3
26589 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26590 ELSEIF(I.EQ.3) THEN
26591C...omega_tc0 -> gamma + pi_tc0'
26592 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26593 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26594 & SHR**3
26595 WID2=WIDS(PYCOMP(KTECHN+221),2)
26596 ELSEIF(I.EQ.4) THEN
26597C...omega_tc0 -> Z0 + pi_tc0'
26598 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26599 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26600 & XW/XW1*SHR**3
26601 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26602 ELSEIF(I.EQ.5) THEN
26603C...omega_tc0 -> W+ + pi_tc-
26604 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26605 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26606 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26607 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26608 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26609 ELSEIF(I.EQ.6) THEN
26610C...omega_tc0 -> pi_tc+ + W-
26611 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26612 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26613 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26614 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26615 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26616 ELSEIF(I.EQ.7) THEN
26617C...omega_tc0 -> W+ + W-.
26618C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26619 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26620 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26621 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26622 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26623 WID2=WIDS(24,1)
26624 ELSEIF(I.EQ.8) THEN
26625C...omega_tc0 -> pi_tc+ + pi_tc-.
26626 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26627 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26628 WID2=WIDS(PYCOMP(KTECHN+211),1)
26629C...omega_tc0 -> gamma + Z0
26630 ELSEIF(I.EQ.9) THEN
26631 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26632 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26633 WID2=WIDS(23,2)
26634C...omega_tc0 -> Z0 + Z0
26635 ELSEIF(I.EQ.10) THEN
26636 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26637 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26638 & /24D0/RTCM(12)**2*SHR**3
26639 WID2=WIDS(23,1)
26640 ELSE
26641C...omega_tc0 -> f + fbar.
26642 WID2=1D0
26643 IF(I.LE.18) THEN
26644 IA=I-10
26645 FCOF=3D0*RADC
26646 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26647 ELSE
26648 IA=I-8
26649 FCOF=1D0
26650 IF(IA.GE.17) WID2=WIDS(IA,1)
26651 ENDIF
26652 EI=KCHG(IA,1)/3D0
26653 AI=SIGN(1D0,EI+0.1D0)
26654 VI=AI-4D0*EI*XWV
26655 VALI=-0.5D0*(VI+AI)
26656 VARI=-0.5D0*(VI-AI)
26657 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26658 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26659 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26660 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26661 ENDIF
26662 WDTP(I)=FUDGE*WDTP(I)
26663 WDTP(0)=WDTP(0)+WDTP(I)
26664 IF(MDME(IDC,1).GT.0) THEN
26665 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26666 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26667 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26668 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26669 ENDIF
26670 390 CONTINUE
26671
26672C.....V8 -> quark anti-quark
26673 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26674 FAC=AS/6D0*SHR
26675 TANT3=RTCM(21)
26676 IF(ITCM(2).EQ.0) THEN
26677 IMDL=1
26678 ELSEIF(ITCM(2).EQ.1) THEN
26679 IMDL=2
26680 ENDIF
26681 DO 400 I=1,MDCY(KC,3)
26682 IDC=I+MDCY(KC,2)-1
26683 IF(MDME(IDC,1).LT.0) GOTO 400
26684 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26685 RM1=PM1**2/SH
26686 IF(RM1.GT.0.25D0) GOTO 400
26687 WID2=1D0
26688 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26689 FMIX=1D0/TANT3**2
26690 ELSE
26691 FMIX=TANT3**2
26692 ENDIF
26693 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26694 IF(I.EQ.6) WID2=WIDS(6,1)
26695 WDTP(I)=FUDGE*WDTP(I)
26696 WDTP(0)=WDTP(0)+WDTP(I)
26697 IF(MDME(IDC,1).GT.0) THEN
26698 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26699 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26700 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26701 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26702 ENDIF
26703 400 CONTINUE
26704
26705 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26706 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26707 CLEBF=0D0
26708 DO 410 I=1,MDCY(KC,3)
26709 IDC=I+MDCY(KC,2)-1
26710 IF(MDME(IDC,1).LT.0) GOTO 410
26711 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26712 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26713 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26714 WID2=1D0
26715C...pi_tc -> g + g
26716 IF(I.EQ.7) THEN
26717 IF(KFLA.EQ.KTECHN+100111) THEN
26718 CLEBG=4D0/3D0
26719 ELSE
26720 CLEBG=5D0/3D0
26721 ENDIF
26722 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26723 & /(2D0*PARU(1))*SH*SHR*CLEBG
26724 WDTP(I)=FACP
26725 ELSE
26726C...pi_tc -> f + fbar.
26727 IF(I.EQ.6) WID2=WIDS(6,1)
26728 FCOF=1D0
26729 IKA=IABS(KFDP(IDC,1))
26730 IF(IKA.LT.10) FCOF=3D0*RADC
26731 HM1=PYMRUN(KFDP(IDC,1),SH)
26732 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26733 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26734 ENDIF
26735 WDTP(I)=FUDGE*WDTP(I)
26736 WDTP(0)=WDTP(0)+WDTP(I)
26737 IF(MDME(IDC,1).GT.0) THEN
26738 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26739 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26740 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26741 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26742 ENDIF
26743 410 CONTINUE
26744
26745 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26746 FAC=AS/6D0*SHR
26747 ALPRHT=2.16D0*(3D0/ITCM(1))
26748 TANT3=RTCM(21)
26749 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26750 SINT3=TANT3/SQRT(TANT3**2+1D0)
26751 CSXPP=RTCM(22)
26752 RM82=RTCM(27)**2
26753 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26754 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26755 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26756 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26757 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26758 & SINT3**2)*2D0
26759 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26760 & SINT3**2)*2D0
26761 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26762
26763 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26764 GMV8=SHR*WDTPP(0)
26765 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26766 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26767 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26768 IF(ITCM(2).EQ.0) THEN
26769 IMDL=1
26770 ELSE
26771 IMDL=2
26772 ENDIF
26773 DO 420 I=1,MDCY(KC,3)
26774 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26775 & KFLA.EQ.KTECHN+300113)) GOTO 420
26776 IDC=I+MDCY(KC,2)-1
26777 IF(MDME(IDC,1).LT.0) GOTO 420
26778 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26779 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26780 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26781 WID2=1D0
26782 IF(I.LE.6) THEN
26783 IF(I.EQ.6) WID2=WIDS(6,1)
26784 XIG=1D0
26785 IF(KFLA.EQ.KTECHN+200113) THEN
26786 XIG=0D0
26787 XIJ=X12
26788 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26789 XIG=0D0
26790 XIJ=X21
26791 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26792 XIJ=X11
26793 ELSE
26794 XIJ=X22
26795 ENDIF
26796 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26797 FMIX=1D0/TANT3/SIN2T
26798 ELSE
26799 FMIX=-TANT3/SIN2T
26800 ENDIF
26801 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26802 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26803 ELSEIF(I.EQ.7) THEN
26804 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26805 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26806 PSH=SHR*(1D0-RM1)/2D0
26807 WDTP(I)=AS/9D0*PSH**3/RM82
26808 IF(I.EQ.8) THEN
26809 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26810 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26811 ELSE
26812 WDTP(I)=5D0*WDTP(I)
26813 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26814 ENDIF
26815 ENDIF
26816 WDTP(I)=FUDGE*WDTP(I)
26817 WDTP(0)=WDTP(0)+WDTP(I)
26818 IF(MDME(IDC,1).GT.0) THEN
26819 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26820 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26821 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26822 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26823 ENDIF
26824 420 CONTINUE
26825
26826 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26827C...d* excited quark.
26828 FAC=(SH/RTCM(41)**2)*SHR
26829 DO 430 I=1,MDCY(KC,3)
26830 IDC=I+MDCY(KC,2)-1
26831 IF(MDME(IDC,1).LT.0) GOTO 430
26832 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26833 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26834 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26835 WID2=1D0
26836 IF(I.EQ.1) THEN
26837C...d* -> g + d.
26838 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26839 WID2=1D0
26840 ELSEIF(I.EQ.2) THEN
26841C...d* -> gamma + d.
26842 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26843 WDTP(I)=FAC*AEM*QF**2/4D0
26844 WID2=1D0
26845 ELSEIF(I.EQ.3) THEN
26846C...d* -> Z0 + d.
26847 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26848 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26849 & (1D0-RM1)**2*(2D0+RM1)
26850 WID2=WIDS(23,2)
26851 ELSEIF(I.EQ.4) THEN
26852C...d* -> W- + u.
26853 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26854 & (1D0-RM1)**2*(2D0+RM1)
26855 IF(KFLR.GT.0) WID2=WIDS(24,3)
26856 IF(KFLR.LT.0) WID2=WIDS(24,2)
26857 ENDIF
26858 WDTP(I)=FUDGE*WDTP(I)
26859 WDTP(0)=WDTP(0)+WDTP(I)
26860 IF(MDME(IDC,1).GT.0) THEN
26861 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26862 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26863 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26864 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26865 ENDIF
26866 430 CONTINUE
26867
26868 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26869C...u* excited quark.
26870 FAC=(SH/RTCM(41)**2)*SHR
26871 DO 440 I=1,MDCY(KC,3)
26872 IDC=I+MDCY(KC,2)-1
26873 IF(MDME(IDC,1).LT.0) GOTO 440
26874 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26875 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26876 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26877 WID2=1D0
26878 IF(I.EQ.1) THEN
26879C...u* -> g + u.
26880 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26881 WID2=1D0
26882 ELSEIF(I.EQ.2) THEN
26883C...u* -> gamma + u.
26884 QF=RTCM(43)/2D0+RTCM(44)/6D0
26885 WDTP(I)=FAC*AEM*QF**2/4D0
26886 WID2=1D0
26887 ELSEIF(I.EQ.3) THEN
26888C...u* -> Z0 + u.
26889 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26890 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26891 & (1D0-RM1)**2*(2D0+RM1)
26892 WID2=WIDS(23,2)
26893 ELSEIF(I.EQ.4) THEN
26894C...u* -> W+ + d.
26895 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26896 & (1D0-RM1)**2*(2D0+RM1)
26897 IF(KFLR.GT.0) WID2=WIDS(24,2)
26898 IF(KFLR.LT.0) WID2=WIDS(24,3)
26899 ENDIF
26900 WDTP(I)=FUDGE*WDTP(I)
26901 WDTP(0)=WDTP(0)+WDTP(I)
26902 IF(MDME(IDC,1).GT.0) THEN
26903 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26904 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26905 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26906 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26907 ENDIF
26908 440 CONTINUE
26909
26910 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26911C...e* excited lepton.
26912 FAC=(SH/RTCM(41)**2)*SHR
26913 DO 450 I=1,MDCY(KC,3)
26914 IDC=I+MDCY(KC,2)-1
26915 IF(MDME(IDC,1).LT.0) GOTO 450
26916 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26917 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26918 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26919 WID2=1D0
26920 IF(I.EQ.1) THEN
26921C...e* -> gamma + e.
26922 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26923 WDTP(I)=FAC*AEM*QF**2/4D0
26924 WID2=1D0
26925 ELSEIF(I.EQ.2) THEN
26926C...e* -> Z0 + e.
26927 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26928 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26929 & (1D0-RM1)**2*(2D0+RM1)
26930 WID2=WIDS(23,2)
26931 ELSEIF(I.EQ.3) THEN
26932C...e* -> W- + nu.
26933 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26934 & (1D0-RM1)**2*(2D0+RM1)
26935 IF(KFLR.GT.0) WID2=WIDS(24,3)
26936 IF(KFLR.LT.0) WID2=WIDS(24,2)
26937 ENDIF
26938 WDTP(I)=FUDGE*WDTP(I)
26939 WDTP(0)=WDTP(0)+WDTP(I)
26940 IF(MDME(IDC,1).GT.0) THEN
26941 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26942 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26943 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26944 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26945 ENDIF
26946 450 CONTINUE
26947
26948 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26949C...nu*_e excited neutrino.
26950 FAC=(SH/RTCM(41)**2)*SHR
26951 DO 460 I=1,MDCY(KC,3)
26952 IDC=I+MDCY(KC,2)-1
26953 IF(MDME(IDC,1).LT.0) GOTO 460
26954 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26955 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26956 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26957 WID2=1D0
26958 IF(I.EQ.1) THEN
26959C...nu*_e -> Z0 + nu*_e.
26960 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26961 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26962 & (1D0-RM1)**2*(2D0+RM1)
26963 WID2=WIDS(23,2)
26964 ELSEIF(I.EQ.2) THEN
26965C...nu*_e -> W+ + e.
26966 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26967 & (1D0-RM1)**2*(2D0+RM1)
26968 IF(KFLR.GT.0) WID2=WIDS(24,2)
26969 IF(KFLR.LT.0) WID2=WIDS(24,3)
26970 ENDIF
26971 WDTP(I)=FUDGE*WDTP(I)
26972 WDTP(0)=WDTP(0)+WDTP(I)
26973 IF(MDME(IDC,1).GT.0) THEN
26974 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26975 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26976 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26977 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26978 ENDIF
26979 460 CONTINUE
26980
26981 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26982C...G* (graviton resonance):
26983 FAC=(PARP(50)**2/PARU(1))*SHR
26984 DO 470 I=1,MDCY(KC,3)
26985 IDC=I+MDCY(KC,2)-1
26986 IF(MDME(IDC,1).LT.0) GOTO 470
26987 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26988 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26989 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26990 WID2=1D0
26991 IF(I.LE.8) THEN
26992C...G* -> q + qbar
26993 FCOF=3D0*RADC
26994 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26995 & PYHFTH(SH,SH*RM1,1D0)
26996 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
26997 & (1D0+8D0*RM1/3D0)/320D0
26998 IF(I.EQ.6) WID2=WIDS(6,1)
26999 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27000 ELSEIF(I.LE.16) THEN
27001C...G* -> l+ + l-, nu + nubar
27002 FCOF=1D0
27003 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27004 & (1D0+8D0*RM1/3D0)/320D0
27005 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27006 ELSEIF(I.EQ.17) THEN
27007C...G* -> g + g.
27008 WDTP(I)=FAC/20D0
27009 ELSEIF(I.EQ.18) THEN
27010C...G* -> gamma + gamma.
27011 WDTP(I)=FAC/160D0
27012 ELSEIF(I.EQ.19) THEN
27013C...G* -> Z0 + Z0.
27014 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27015 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27016 WID2=WIDS(23,1)
27017 ELSEIF(I.EQ.20) THEN
27018C...G* -> W+ + W-.
27019 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27020 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27021 WID2=WIDS(24,1)
27022 ENDIF
27023 WDTP(I)=FUDGE*WDTP(I)
27024 WDTP(0)=WDTP(0)+WDTP(I)
27025 IF(MDME(IDC,1).GT.0) THEN
27026 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27027 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27028 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27029 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27030 ENDIF
27031 470 CONTINUE
27032
27033 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27034C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27035 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27036 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27037 DO 480 I=1,MDCY(KC,3)
27038 IDC=I+MDCY(KC,2)-1
27039 IF(MDME(IDC,1).LT.0) GOTO 480
27040 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27041 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27042 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27043 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27044 WID2=1D0
27045 IF(I.LE.9) THEN
27046C...nu_lR -> l- qbar q'
27047 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27048 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27049 ELSEIF(I.LE.18) THEN
27050C...nu_lR -> l+ q qbar'
27051 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27052 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27053 ELSE
27054C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27055 FCOF=1D0
27056 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27057 ENDIF
27058 X=(PM1+PM2+PM3)/SHR
27059 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27060 Y=(SHR/PMWR)**2
27061 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27062 WDTP(I)=FAC*FCOF*FX*FY
27063 WDTP(I)=FUDGE*WDTP(I)
27064 WDTP(0)=WDTP(0)+WDTP(I)
27065 IF(MDME(IDC,1).GT.0) THEN
27066 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27067 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27068 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27069 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27070 ENDIF
27071 480 CONTINUE
27072
27073 ELSEIF(KFLA.EQ.9900023) THEN
27074C...Z_R0:
27075 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27076 DO 490 I=1,MDCY(KC,3)
27077 IDC=I+MDCY(KC,2)-1
27078 IF(MDME(IDC,1).LT.0) GOTO 490
27079 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27080 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27081 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27082 WID2=1D0
27083 SYMMET=1D0
27084 IF(I.LE.6) THEN
27085C...Z_R0 -> q + qbar
27086 EF=KCHG(I,1)/3D0
27087 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27088 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27089 FCOF=3D0*RADC
27090 IF(I.EQ.6) WID2=WIDS(6,1)
27091 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27092C...Z_R0 -> l+ + l-
27093 AF=-(1D0-2D0*XW)
27094 VF=-1D0+4D0*XW
27095 FCOF=1D0
27096 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27097C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27098 AF=-2D0*XW
27099 VF=0D0
27100 FCOF=1D0
27101 SYMMET=0.5D0
27102 ELSEIF(I.LE.15) THEN
27103C...Z0 -> nu_R + nu_R, assumed Majorana.
27104 AF=2D0*XW1
27105 VF=0D0
27106 FCOF=1D0
27107 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27108 SYMMET=0.5D0
27109 ENDIF
27110 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27111 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27112 WDTP(I)=FUDGE*WDTP(I)
27113 WDTP(0)=WDTP(0)+WDTP(I)
27114 IF(MDME(IDC,1).GT.0) THEN
27115 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27116 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27117 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27118 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27119 ENDIF
27120 490 CONTINUE
27121
27122 ELSEIF(KFLA.EQ.9900024) THEN
27123C...W_R+/-:
27124 FAC=(AEM/(24D0*XW))*SHR
27125 DO 500 I=1,MDCY(KC,3)
27126 IDC=I+MDCY(KC,2)-1
27127 IF(MDME(IDC,1).LT.0) GOTO 500
27128 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27129 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27130 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27131 WID2=1D0
27132 IF(I.LE.9) THEN
27133C...W_R+/- -> q + qbar'
27134 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27135 IF(KFLR.GT.0) THEN
27136 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27137 ELSE
27138 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27139 ENDIF
27140 ELSEIF(I.LE.12) THEN
27141C...W_R+/- -> l+/- + nu_R
27142 FCOF=1D0
27143 ENDIF
27144 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27145 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27146 WDTP(I)=FUDGE*WDTP(I)
27147 WDTP(0)=WDTP(0)+WDTP(I)
27148 IF(MDME(IDC,1).GT.0) THEN
27149 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27150 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27151 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27152 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27153 ENDIF
27154 500 CONTINUE
27155
27156 ELSEIF(KFLA.EQ.9900041) THEN
27157C...H_L++/--:
27158 FAC=(1D0/(8D0*PARU(1)))*SHR
27159 DO 510 I=1,MDCY(KC,3)
27160 IDC=I+MDCY(KC,2)-1
27161 IF(MDME(IDC,1).LT.0) GOTO 510
27162 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27163 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27164 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27165 WID2=1D0
27166 IF(I.LE.6) THEN
27167C...H_L++/-- -> l+/- + l'+/-
27168 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27169 & (IABS(KFDP(IDC,2))-9)/2)**2
27170 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27171 ELSEIF(I.EQ.7) THEN
27172C...H_L++/-- -> W_L+/- + W_L+/-
27173 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27174 & (3D0*RM1+0.25D0/RM1-1D0)
27175 WID2=WIDS(24,4+(1-KFLS)/2)
27176 ENDIF
27177 WDTP(I)=FAC*FCOF*
27178 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27179 WDTP(I)=FUDGE*WDTP(I)
27180 WDTP(0)=WDTP(0)+WDTP(I)
27181 IF(MDME(IDC,1).GT.0) THEN
27182 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27183 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27184 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27185 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27186 ENDIF
27187 510 CONTINUE
27188
27189 ELSEIF(KFLA.EQ.9900042) THEN
27190C...H_R++/--:
27191 FAC=(1D0/(8D0*PARU(1)))*SHR
27192 DO 520 I=1,MDCY(KC,3)
27193 IDC=I+MDCY(KC,2)-1
27194 IF(MDME(IDC,1).LT.0) GOTO 520
27195 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27196 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27197 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27198 WID2=1D0
27199 IF(I.LE.6) THEN
27200C...H_R++/-- -> l+/- + l'+/-
27201 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27202 & (IABS(KFDP(IDC,2))-9)/2)**2
27203 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27204 ELSEIF(I.EQ.7) THEN
27205C...H_R++/-- -> W_R+/- + W_R+/-
27206 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27207 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27208 ENDIF
27209 WDTP(I)=FAC*FCOF*
27210 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27211 WDTP(I)=FUDGE*WDTP(I)
27212 WDTP(0)=WDTP(0)+WDTP(I)
27213 IF(MDME(IDC,1).GT.0) THEN
27214 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27215 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27216 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27217 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27218 ENDIF
27219 520 CONTINUE
27220
27221 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27222C...Techni-a2:
27223C...Need to update to alpha_rho
27224 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27225 FAC=(ALPRHT/12D0)*SHR
27226 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27227 SQMZ=PMAS(23,1)**2
27228 SQMW=PMAS(24,1)**2
27229 SHP=SH
27230 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27231 GMMZ=SHR*WDTPP(0)
27232 XWRHT=1D0/(4D0*XW*(1D0-XW))
27233 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27234 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27235 DO 530 I=1,MDCY(KC,3)
27236 IDC=I+MDCY(KC,2)-1
27237 IF(MDME(IDC,1).LT.0) GOTO 530
27238 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27239 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27240 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27241 WID2=1D0
27242 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27243 IF(I.LE.4) THEN
27244 FACPV=PCM**2
27245 FACPA=PCM**2+1.5D0*RM1
27246 VA2=0D0
27247 AA2=0D0
27248C...a2_tc0 -> W+ + W-
27249 IF(I.EQ.1) THEN
27250 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27251C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27252 WID2=WIDS(24,1)
27253C...a2_tc0 -> W+ + pi_tc- + c.c.
27254 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27255 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27256 IF(I.EQ.6) THEN
27257 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27258 ELSE
27259 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27260 ENDIF
27261 ELSEIF(I.EQ.4) THEN
27262C...a2_tc0 -> Z0 + pi_tc0'
27263 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27264 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27265 ENDIF
27266 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27267 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27268 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27269 FACPA=PCM**2*(1D0+RM1+RM2)
27270 VA2=0D0
27271 AA2=0D0
27272 IF(I.EQ.5) THEN
27273C...a_T^0 -> gamma rho_T^0
27274 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27275 WID2=WIDS(PYCOMP(KTECHN+113),2)
27276 ELSEIF(I.EQ.6) THEN
27277C...a_T^0 -> gamma omega_T
27278 VA2=1D0/RTCM(50)**4
27279 WID2=WIDS(PYCOMP(KTECHN+223),2)
27280 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27281C...a_T^0 -> W^+- rho_T^-+
27282 AA2=.25D0/XW/RTCM(51)**4
27283 IF(I.EQ.7) THEN
27284 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27285 ELSE
27286 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27287 ENDIF
27288 ELSEIF(I.EQ.9) THEN
27289C...a_T^0 -> Z^0 rho_T^0
27290 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27291 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27292 ELSEIF(I.EQ.10) THEN
27293C...a_T^0 -> Z^0 omega_T
27294 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27295 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27296 ENDIF
27297 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27298 ELSE
27299C...a2_tc0 -> f + fbar.
27300 WID2=1D0
27301 IF(I.LE.18) THEN
27302 IA=I-10
27303 FCOF=3D0*RADC
27304 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27305 ELSE
27306 IA=I-8
27307 FCOF=1D0
27308 IF(IA.GE.17) WID2=WIDS(IA,1)
27309 ENDIF
27310 EI=KCHG(IA,1)/3D0
27311 AI=SIGN(1D0,EI+0.1D0)
27312 VI=AI-4D0*EI*XWV
27313 VALI=0.5D0*(VI+AI)
27314 VARI=0.5D0*(VI-AI)
27315 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27316 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27317 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27318 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27319 ENDIF
27320 WDTP(I)=FUDGE*WDTP(I)
27321 WDTP(0)=WDTP(0)+WDTP(I)
27322 IF(MDME(IDC,1).GT.0) THEN
27323 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27324 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27325 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27326 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27327 ENDIF
27328 530 CONTINUE
27329
27330 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27331C...Techni-a2+/-:
27332 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27333 FAC=(ALPRHT/12D0)*SHR
27334 SQMZ=PMAS(23,1)**2
27335 SQMW=PMAS(24,1)**2
27336 SHP=SH
27337 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27338 GMMW=SHR*WDTPP(0)
27339 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27340 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27341 DO 540 I=1,MDCY(KC,3)
27342 IDC=I+MDCY(KC,2)-1
27343 IF(MDME(IDC,1).LT.0) GOTO 540
27344 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27345 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27346 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27347 WID2=1D0
27348 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27349 IF(KFLR.GT.0) THEN
27350 ICHANN=2
27351 ELSE
27352 ICHANN=3
27353 ENDIF
27354 IF(I.LE.7) THEN
27355 AA2=0
27356 VA2=0
27357C...a2_tc+ -> gamma + W+.
27358 IF(I.EQ.1) THEN
27359 AA2=RTCM(3)**2/RTCM(49)**2
27360 WID2=WIDS(24,ICHANN)
27361C...a2_tc+ -> gamma + pi_tc+.
27362 ELSEIF(I.EQ.2) THEN
27363 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27364 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27365C...a2_tc+ -> W+ + Z
27366 ELSEIF(I.EQ.3) THEN
27367 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27368 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27369 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27370C...a2_tc+ -> W+ + pi_tc0.
27371 ELSEIF(I.EQ.4) THEN
27372 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27373 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27374C...a2_tc+ -> W+ + pi_tc'0.
27375 ELSEIF(I.EQ.5) THEN
27376 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27377 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27378C...a2_tc+ -> Z0 + pi_tc+.
27379 ELSEIF(I.EQ.6) THEN
27380 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27381 & RTCM(49)**2
27382 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27383 ENDIF
27384 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27385 & /3D0*SHR**3
27386 ELSEIF(I.LE.10) THEN
27387 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27388 FACPA=PCM**2*(1D0+RM1+RM2)
27389 VA2=0D0
27390 AA2=0D0
27391C...a2_tc+ -> gamma + rho_tc+
27392 IF(I.EQ.7) THEN
27393 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27394 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27395C...a2_tc+ -> W+ + rho_T^0
27396 ELSEIF(I.EQ.8) THEN
27397 AA2=1D0/(4D0*XW)/RTCM(51)**4
27398 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27399C...a2_tc+ -> W+ + omega_T
27400 ELSEIF(I.EQ.9) THEN
27401 VA2=.25D0/XW/RTCM(50)**4
27402 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27403C...a2_tc+ -> Z^0 + rho_T^+
27404 ELSEIF(I.EQ.10) THEN
27405 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27406 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27407 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27408 ENDIF
27409 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27410 ELSE
27411C...a2_tc+ -> f + fbar'.
27412 IA=I-10
27413 WID2=1D0
27414 IF(IA.LE.16) THEN
27415 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27416 IF(KFLR.GT.0) THEN
27417 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27418 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27419 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27420 ELSE
27421 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27422 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27423 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27424 ENDIF
27425 ELSE
27426 FCOF=1D0
27427 IF(KFLR.GT.0) THEN
27428 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27429 ELSE
27430 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27431 ENDIF
27432 ENDIF
27433 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27434 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27435 ENDIF
27436 WDTP(I)=FUDGE*WDTP(I)
27437 WDTP(0)=WDTP(0)+WDTP(I)
27438 IF(MDME(IDC,1).GT.0) THEN
27439 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27440 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27441 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27442 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27443 ENDIF
27444 540 CONTINUE
27445
27446 ENDIF
27447 MINT(61)=0
27448 MINT(62)=0
27449 MINT(63)=0
27450 RETURN
27451 END
27452
27453C***********************************************************************
27454
27455C...PYOFSH
27456C...Calculates partial width and differential cross-section maxima
27457C...of channels/processes not allowed on mass-shell, and selects
27458C...masses in such channels/processes.
27459
27460 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27461
27462C...Double precision and integer declarations.
27463 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27464 IMPLICIT INTEGER(I-N)
27465 INTEGER PYK,PYCHGE,PYCOMP
27466C...Commonblocks.
27467 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27468 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27469 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27470 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27471 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27472 COMMON/PYINT1/MINT(400),VINT(400)
27473 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27474 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27475 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27476 &/PYINT2/,/PYINT5/
27477C...Local arrays.
27478 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27479 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27480 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27481 &WDTE(0:400,0:5)
27482
27483C...Find if particles equal, maximum mass, matrix elements, etc.
27484 MINT(51)=0
27485 ISUB=MINT(1)
27486 KFD(1)=IABS(KFD1)
27487 KFD(2)=IABS(KFD2)
27488 MEQL=0
27489 IF(KFD(1).EQ.KFD(2)) MEQL=1
27490 MLM=0
27491 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27492 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27493 NOFF=44
27494 PMMX=PMMO
27495 ELSE
27496 NOFF=40
27497 PMMX=VINT(1)
27498 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27499 ENDIF
27500 MMED=0
27501 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27502 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27503 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27504 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27505 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27506 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27507 LOOP=1
27508
27509C...Find where Breit-Wigners are required, else select discrete masses.
27510 100 DO 110 I=1,2
27511 KFCA=PYCOMP(KFD(I))
27512 IF(KFCA.GT.0) THEN
27513 PMD(I)=PMAS(KFCA,1)
27514 PGD(I)=PMAS(KFCA,2)
27515 ELSE
27516 PMD(I)=0D0
27517 PGD(I)=0D0
27518 ENDIF
27519 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27520 MBW(I)=0
27521 PMG(I)=PMD(I)
27522 RMG(I)=(PMG(I)/PMMX)**2
27523 ELSE
27524 MBW(I)=1
27525 ENDIF
27526 110 CONTINUE
27527
27528C...Find allowed mass range and Breit-Wigner parameters.
27529 DO 120 I=1,2
27530 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27531 PML(I)=PARP(42)
27532 PMU(I)=PMMX-PARP(42)
27533 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27534 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27535 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27536 ILM=I
27537 IF(MLM.EQ.2) ILM=3-I
27538 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27539 IF(MBW(3-I).EQ.0) THEN
27540 PMU(I)=PMMX-PMD(3-I)
27541 ELSE
27542 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27543 ENDIF
27544 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27545 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27546 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27547 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27548 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27549 IF(MBW(I).EQ.1) THEN
27550 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27551 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27552 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27553 & PGD(I)))
27554 ENDIF
27555 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27556 ILM=I
27557 IF(MLM.EQ.2) ILM=3-I
27558 PML(I)=MAX(CKIN(48+I),PARP(42))
27559 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27560 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27561 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27562 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27563 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27564 IF(MBW(I).EQ.1) THEN
27565 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27566 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27567 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27568 & PGD(I)))
27569 ENDIF
27570 ENDIF
27571 120 CONTINUE
27572 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27573 &THEN
27574 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27575 MINT(51)=1
27576 RETURN
27577 ENDIF
27578
27579C...Calculation of partial width of resonance.
27580 IF(MOFSH.EQ.1) THEN
27581
27582C..If only one integration, pick that to be the inner.
27583 IF(MBW(1).EQ.0) THEN
27584 PM2=PMD(1)
27585 PMD(1)=PMD(2)
27586 PGD(1)=PGD(2)
27587 PML(1)=PML(2)
27588 PMU(1)=PMU(2)
27589 ELSEIF(MBW(2).EQ.0) THEN
27590 PM2=PMD(2)
27591 ENDIF
27592
27593C...Start outer loop of integration.
27594 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27595 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27596 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27597 NPT2=1
27598 XPT2(1)=1D0
27599 INX2(1)=0
27600 FMAX2=0D0
27601 ENDIF
27602 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27603 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27604 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27605 ENDIF
27606 RM2=(PM2/PMMX)**2
27607
27608C...Start inner loop of integration.
27609 PML1=PML(1)
27610 PMU1=MIN(PMU(1),PMMX-PM2)
27611 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27612 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27613 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27614 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27615 FUNC2=0D0
27616 GOTO 180
27617 ENDIF
27618 NPT1=1
27619 XPT1(1)=1D0
27620 INX1(1)=0
27621 FMAX1=0D0
27622 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27623 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27624 RM1=(PM1/PMMX)**2
27625
27626C...Evaluate function value - inner loop.
27627 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27628 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27629 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27630 & RM2**2+10D0*RM1*RM2)
27631 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27632 FPT1(NPT1)=FUNC1
27633
27634C...Go to next position in inner loop.
27635 IF(NPT1.EQ.1) THEN
27636 NPT1=NPT1+1
27637 XPT1(NPT1)=0D0
27638 INX1(NPT1)=1
27639 GOTO 140
27640 ELSEIF(NPT1.LE.8) THEN
27641 NPT1=NPT1+1
27642 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27643 ISH1=ISH1+1
27644 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27645 INX1(NPT1)=INX1(ISH1)
27646 INX1(ISH1)=NPT1
27647 GOTO 140
27648 ELSEIF(NPT1.LT.100) THEN
27649 ISN1=ISH1
27650 150 ISH1=ISH1+1
27651 IF(ISH1.GT.NPT1) ISH1=2
27652 IF(ISH1.EQ.ISN1) GOTO 160
27653 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27654 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27655 NPT1=NPT1+1
27656 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27657 INX1(NPT1)=INX1(ISH1)
27658 INX1(ISH1)=NPT1
27659 GOTO 140
27660 ENDIF
27661
27662C...Calculate integral over inner loop.
27663 160 FSUM1=0D0
27664 DO 170 IPT1=2,NPT1
27665 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27666 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27667 170 CONTINUE
27668 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27669 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27670 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27671 FPT2(NPT2)=FUNC2
27672
27673C...Go to next position in outer loop.
27674 IF(NPT2.EQ.1) THEN
27675 NPT2=NPT2+1
27676 XPT2(NPT2)=0D0
27677 INX2(NPT2)=1
27678 GOTO 130
27679 ELSEIF(NPT2.LE.8) THEN
27680 NPT2=NPT2+1
27681 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27682 ISH2=ISH2+1
27683 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27684 INX2(NPT2)=INX2(ISH2)
27685 INX2(ISH2)=NPT2
27686 GOTO 130
27687 ELSEIF(NPT2.LT.100) THEN
27688 ISN2=ISH2
27689 190 ISH2=ISH2+1
27690 IF(ISH2.GT.NPT2) ISH2=2
27691 IF(ISH2.EQ.ISN2) GOTO 200
27692 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27693 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27694 NPT2=NPT2+1
27695 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27696 INX2(NPT2)=INX2(ISH2)
27697 INX2(ISH2)=NPT2
27698 GOTO 130
27699 ENDIF
27700
27701C...Calculate integral over outer loop.
27702 200 FSUM2=0D0
27703 DO 210 IPT2=2,NPT2
27704 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27705 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27706 210 CONTINUE
27707 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27708 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27709 ELSE
27710 FSUM2=FUNC2
27711 ENDIF
27712
27713C...Save result; second integration for user-selected mass range.
27714 IF(LOOP.EQ.1) WIDW=FSUM2
27715 WID2=FSUM2
27716 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27717 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27718 LOOP=2
27719 GOTO 100
27720 ENDIF
27721 RET1=WIDW
27722 RET2=WID2/WIDW
27723
27724C...Select two decay product masses of a resonance.
27725 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27726 220 DO 230 I=1,2
27727 IF(MBW(I).EQ.0) GOTO 230
27728 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27729 & (ATU(I)-ATL(I)))
27730 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27731 RMG(I)=(PMG(I)/PMMX)**2
27732 230 CONTINUE
27733 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27734 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27735
27736C...Weight with matrix element (if none known, use beta factor).
27737 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27738 IF(MMED.EQ.1) THEN
27739 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27740 ELSEIF(MMED.EQ.2) THEN
27741 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27742 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27743 ELSEIF(MMED.EQ.3) THEN
27744 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27745 ELSE
27746 WTBE=FLAM
27747 ENDIF
27748 IF(WTBE.LT.PYR(0)) GOTO 220
27749 RET1=PMG(1)
27750 RET2=PMG(2)
27751
27752C...Find suitable set of masses for initialization of 2 -> 2 processes.
27753 ELSEIF(MOFSH.EQ.3) THEN
27754 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27755 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27756 PMG(2)=PMD(2)
27757 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27758 PMG(1)=PMD(1)
27759 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27760 ELSE
27761 IDIV=-1
27762 240 IDIV=IDIV+1
27763 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27764 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27765 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27766 ENDIF
27767 RET1=PMG(1)
27768 RET2=PMG(2)
27769
27770C...Evaluate importance of excluded tails of Breit-Wigners.
27771 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27772 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27773 IF(MEQL.LE.1) THEN
27774 VINT(80)=1D0
27775 DO 250 I=1,2
27776 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27777 & PARU(1)
27778 250 CONTINUE
27779 ELSE
27780 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27781 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27782 ENDIF
27783 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27784 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27785 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27786 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27787
27788C...Pick one particle to be the lighter (if improves efficiency).
27789 ELSEIF(MOFSH.EQ.4) THEN
27790 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27791 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27792 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27793
27794C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27795 DO 270 I=1,2
27796 IF(MBW(I).EQ.0) GOTO 270
27797 PMV=PMU(I)
27798 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27799 ATV=ATU(I)
27800 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27801 RBR=PYR(0)
27802 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27803 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27804 IF(RBR.LT.0.8D0) THEN
27805 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27806 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27807 ELSEIF(RBR.LT.0.9D0) THEN
27808 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27809 ELSEIF(RBR.LT.1.5D0) THEN
27810 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27811 ELSE
27812 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27813 & (PMV**2-PML(I)**2))))
27814 ENDIF
27815 270 CONTINUE
27816 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27817 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27818 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27819 NGEN(0,1)=NGEN(0,1)+1
27820 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27821 GOTO 260
27822 ELSE
27823 MINT(51)=1
27824 RETURN
27825 ENDIF
27826 ENDIF
27827 RET1=PMG(1)
27828 RET2=PMG(2)
27829
27830C...Give weight for selected mass distribution.
27831 VINT(80)=1D0
27832 DO 280 I=1,2
27833 IF(MBW(I).EQ.0) GOTO 280
27834 PMV=PMU(I)
27835 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27836 ATV=ATU(I)
27837 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27838 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27839 & (PMD(I)*PGD(I))**2)/PARU(1)
27840 F1=1D0
27841 F2=1D0/PMG(I)**2
27842 F3=1D0/PMG(I)**4
27843 FI0=(ATV-ATL(I))/PARU(1)
27844 FI1=PMV**2-PML(I)**2
27845 FI2=2D0*LOG(PMV/PML(I))
27846 FI3=1D0/PML(I)**2-1D0/PMV**2
27847 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27848 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27849 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27850 & 5D0*F3/FI3))
27851 ELSE
27852 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27853 ENDIF
27854 VINT(80)=VINT(80)*FI0
27855 280 CONTINUE
27856 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27857 ENDIF
27858
27859 RETURN
27860 END
27861
27862C***********************************************************************
27863
27864C...PYRECO
27865C...Handles the possibility of colour reconnection in W+W- events,
27866C...Based on the main scenarios of the Sjostrand and Khoze study:
27867C...I, II, II', intermediate and instantaneous; plus one model
27868C...along the lines of the Gustafson and Hakkinen: GH.
27869C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27870C...is as if first resonance is W+ and second W-.
27871
27872 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27873
27874C...Double precision and integer declarations.
27875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27876 IMPLICIT INTEGER(I-N)
27877 INTEGER PYK,PYCHGE,PYCOMP
27878C...Parameter value; number of points in MC integration.
27879 PARAMETER (NPT=100)
27880C...Commonblocks.
27881 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27882 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27883 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27884 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27885 COMMON/PYINT1/MINT(400),VINT(400)
27886 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27887C...Local arrays.
27888 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27889 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27890 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27891 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27892 &TMC(20),IJOIN(100)
27893
27894C...Functions to give four-product and to do determinants.
27895 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)
27896 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27897 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27898 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27899
27900C...Only allow fraction of recoupling for GH, intermediate and
27901C...instantaneous.
27902 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27903 IF(PYR(0).GT.PARP(120)) RETURN
27904 ENDIF
27905 ISUB=MINT(1)
27906
27907C...Common part for scenarios I, II, II', and GH.
27908 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27909 &MSTP(115).EQ.5) THEN
27910
27911C...Read out frequently-used parameters.
27912 PI=PARU(1)
27913 HBAR=PARU(3)
27914 PMW=PMAS(24,1)
27915 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27916 PGW=PMAS(24,2)
27917 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27918 TFRAG=PARP(115)
27919 RHAD=PARP(116)
27920 FACT=PARP(117)
27921 BLOWR=PARP(118)
27922 BLOWT=PARP(119)
27923
27924C...Find range of decay products of the W's.
27925C...Background: the W's are stored in IW1 and IW2.
27926C...Their direct decay products in NSD1+1 through NSD1+4.
27927C...Products after shower (if any) in NSD1+5 through NAFT1
27928C...for first W and in NAFT1+1 through N for the second.
27929 IF(NAFT1.GT.NSD1+4) THEN
27930 NBEG(1)=NSD1+5
27931 NEND(1)=NAFT1
27932 ELSE
27933 NBEG(1)=NSD1+1
27934 NEND(1)=NSD1+2
27935 ENDIF
27936 IF(N.GT.NAFT1) THEN
27937 NBEG(2)=NAFT1+1
27938 NEND(2)=N
27939 ELSE
27940 NBEG(2)=NSD1+3
27941 NEND(2)=NSD1+4
27942 ENDIF
27943
27944C...Rearrange parton shower products along strings.
27945 NOLD=N
27946 CALL PYPREP(NSD1+1)
27947 IF(MINT(51).NE.0) RETURN
27948
27949C...Find partons pointing back to W+ and W-; store them with quark
27950C...end of string first.
27951 NNP=0
27952 NNM=0
27953 ISGP=0
27954 ISGM=0
27955 DO 120 I=NOLD+1,N
27956 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27957 IF(IABS(K(I,2)).GE.22) GOTO 120
27958 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27959 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27960 NNP=NNP+1
27961 IF(ISGP.EQ.1) THEN
27962 INP(NNP)=I
27963 ELSE
27964 DO 100 I1=NNP,2,-1
27965 INP(I1)=INP(I1-1)
27966 100 CONTINUE
27967 INP(1)=I
27968 ENDIF
27969 IF(K(I,1).EQ.1) ISGP=0
27970 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27971 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27972 NNM=NNM+1
27973 IF(ISGM.EQ.1) THEN
27974 INM(NNM)=I
27975 ELSE
27976 DO 110 I1=NNM,2,-1
27977 INM(I1)=INM(I1-1)
27978 110 CONTINUE
27979 INM(1)=I
27980 ENDIF
27981 IF(K(I,1).EQ.1) ISGM=0
27982 ENDIF
27983 120 CONTINUE
27984
27985C...Boost to W+W- rest frame (not strictly needed).
27986 DO 130 J=1,3
27987 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27988 130 CONTINUE
27989 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27990 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27991 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27992
27993C...Select decay vertices of W+ and W-.
27994 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
27995 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
27996 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
27997 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
27998 GTMAX=MAX(TP,TM)
27999 DO 140 J=1,3
28000 XP(J)=TP*P(IW1,J)/P(IW1,4)
28001 XM(J)=TM*P(IW2,J)/P(IW2,4)
28002 140 CONTINUE
28003
28004C...Begin scenario I specifics.
28005 IF(MSTP(115).EQ.1) THEN
28006
28007C...Reconstruct velocity and direction of W+ string pieces.
28008 DO 170 IIP=1,NNP-1
28009 IF(K(INP(IIP),2).LT.0) GOTO 170
28010 I1=INP(IIP)
28011 I2=INP(IIP+1)
28012 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28013 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28014 DO 150 J=1,3
28015 V1(J)=P(I1,J)/P1A
28016 V2(J)=P(I2,J)/P2A
28017 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28018 DIRP(IIP,J)=V1(J)-V2(J)
28019 150 CONTINUE
28020 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28021 & BETP(IIP,3)**2)
28022 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28023 DO 160 J=1,3
28024 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28025 160 CONTINUE
28026 170 CONTINUE
28027
28028C...Reconstruct velocity and direction of W- string pieces.
28029 DO 200 IIM=1,NNM-1
28030 IF(K(INM(IIM),2).LT.0) GOTO 200
28031 I1=INM(IIM)
28032 I2=INM(IIM+1)
28033 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28034 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28035 DO 180 J=1,3
28036 V1(J)=P(I1,J)/P1A
28037 V2(J)=P(I2,J)/P2A
28038 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28039 DIRM(IIM,J)=V1(J)-V2(J)
28040 180 CONTINUE
28041 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28042 & BETM(IIM,3)**2)
28043 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28044 DO 190 J=1,3
28045 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28046 190 CONTINUE
28047 200 CONTINUE
28048
28049C...Loop over number of space-time points.
28050 NACC=0
28051 SUM=0D0
28052 DO 250 IPT=1,NPT
28053
28054C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28055 R=SQRT(-LOG(PYR(0)))
28056 PHI=2D0*PI*PYR(0)
28057 X=BLOWR*RHAD*R*COS(PHI)
28058 Y=BLOWR*RHAD*R*SIN(PHI)
28059 R=SQRT(-LOG(PYR(0)))
28060 PHI=2D0*PI*PYR(0)
28061 Z=BLOWR*RHAD*R*COS(PHI)
28062 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28063
28064C...Reject impossible points. Weight for sample distribution.
28065 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28066 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28067 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28068
28069C...Loop over W+ string pieces and find one with largest weight.
28070 IMAXP=0
28071 WTMAXP=1D-10
28072 XD(1)=X-XP(1)
28073 XD(2)=Y-XP(2)
28074 XD(3)=Z-XP(3)
28075 XD(4)=T-TP
28076 DO 220 IIP=1,NNP-1
28077 IF(K(INP(IIP),2).LT.0) GOTO 220
28078 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28079 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28080 DO 210 J=1,3
28081 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28082 210 CONTINUE
28083 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28084 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28085 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28086 & DIRP(IIP,3)*XB(3))**2
28087 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28088 & TFRAG**2)
28089 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28090 IF(WTP.GT.WTMAXP) THEN
28091 IMAXP=IIP
28092 WTMAXP=WTP
28093 ENDIF
28094 220 CONTINUE
28095
28096C...Loop over W- string pieces and find one with largest weight.
28097 IMAXM=0
28098 WTMAXM=1D-10
28099 XD(1)=X-XM(1)
28100 XD(2)=Y-XM(2)
28101 XD(3)=Z-XM(3)
28102 XD(4)=T-TM
28103 DO 240 IIM=1,NNM-1
28104 IF(K(INM(IIM),2).LT.0) GOTO 240
28105 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28106 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28107 DO 230 J=1,3
28108 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28109 230 CONTINUE
28110 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28111 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28112 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28113 & DIRM(IIM,3)*XB(3))**2
28114 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28115 & TFRAG**2)
28116 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28117 IF(WTM.GT.WTMAXM) THEN
28118 IMAXM=IIM
28119 WTMAXM=WTM
28120 ENDIF
28121 240 CONTINUE
28122
28123C...Result of integration.
28124 WT=0D0
28125 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28126 WT=WTMAXP*WTMAXM/WTSMP
28127 SUM=SUM+WT
28128 NACC=NACC+1
28129 IAP(NACC)=IMAXP
28130 IAM(NACC)=IMAXM
28131 WTA(NACC)=WT
28132 ENDIF
28133 250 CONTINUE
28134 RES=BLOWR**3*BLOWT*SUM/NPT
28135
28136C...Decide whether to reconnect and, if so, where.
28137 IACC=0
28138 PREC=1D0-EXP(-FACT*RES)
28139 IF(PREC.GT.PYR(0)) THEN
28140 RSUM=PYR(0)*SUM
28141 DO 260 IA=1,NACC
28142 IACC=IA
28143 RSUM=RSUM-WTA(IA)
28144 IF(RSUM.LE.0D0) GOTO 270
28145 260 CONTINUE
28146 270 IIP=IAP(IACC)
28147 IIM=IAM(IACC)
28148 ENDIF
28149
28150C...Begin scenario II and II' specifics.
28151 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28152
28153C...Loop through all string pieces, one from W+ and one from W-.
28154 NCROSS=0
28155 TC(0)=0D0
28156 DO 340 IIP=1,NNP-1
28157 IF(K(INP(IIP),2).LT.0) GOTO 340
28158 I1P=INP(IIP)
28159 I2P=INP(IIP+1)
28160 DO 330 IIM=1,NNM-1
28161 IF(K(INM(IIM),2).LT.0) GOTO 330
28162 I1M=INM(IIM)
28163 I2M=INM(IIM+1)
28164
28165C...Find endpoint velocity vectors.
28166 DO 280 J=1,3
28167 V1P(J)=P(I1P,J)/P(I1P,4)
28168 V2P(J)=P(I2P,J)/P(I2P,4)
28169 V1M(J)=P(I1M,J)/P(I1M,4)
28170 V2M(J)=P(I2M,J)/P(I2M,4)
28171 280 CONTINUE
28172
28173C...Define q matrix and find t.
28174 DO 290 J=1,3
28175 Q(1,J)=V2P(J)-V1P(J)
28176 Q(2,J)=-(V2M(J)-V1M(J))
28177 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28178 Q(4,J)=V1P(J)-V1M(J)
28179 290 CONTINUE
28180 T=-DETER(1,2,3)/DETER(1,2,4)
28181
28182C...Find alpha and beta; i.e. coordinates of crossing point.
28183 S11=Q(1,1)*(T-TP)
28184 S12=Q(2,1)*(T-TM)
28185 S13=Q(3,1)+Q(4,1)*T
28186 S21=Q(1,2)*(T-TP)
28187 S22=Q(2,2)*(T-TM)
28188 S23=Q(3,2)+Q(4,2)*T
28189 DEN=S11*S22-S12*S21
28190 ALP=(S12*S23-S22*S13)/DEN
28191 BET=(S21*S13-S11*S23)/DEN
28192
28193C...Check if solution acceptable.
28194 IANSW=1
28195 IF(T.LT.GTMAX) IANSW=0
28196 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28197 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28198
28199C...Find point of crossing and check that not inconsistent.
28200 DO 300 J=1,3
28201 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28202 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28203 300 CONTINUE
28204 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28205 & (XPP(3)-XMM(3))**2
28206 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28207 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28208 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28209
28210C...Find string eigentimes at crossing.
28211 IF(IANSW.EQ.1) THEN
28212 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28213 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28214 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28215 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28216 ELSE
28217 TAUP=0D0
28218 TAUM=0D0
28219 ENDIF
28220
28221C...Order crossings by time. End loop over crossings.
28222 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28223 NCROSS=NCROSS+1
28224 DO 310 I1=NCROSS,1,-1
28225 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28226 IPC(I1)=IIP
28227 IMC(I1)=IIM
28228 TC(I1)=T
28229 TPC(I1)=TAUP
28230 TMC(I1)=TAUM
28231 GOTO 320
28232 ELSE
28233 IPC(I1)=IPC(I1-1)
28234 IMC(I1)=IMC(I1-1)
28235 TC(I1)=TC(I1-1)
28236 TPC(I1)=TPC(I1-1)
28237 TMC(I1)=TMC(I1-1)
28238 ENDIF
28239 310 CONTINUE
28240 320 CONTINUE
28241 ENDIF
28242 330 CONTINUE
28243 340 CONTINUE
28244
28245C...Loop over crossings; find first (if any) acceptable one.
28246 IACC=0
28247 IF(NCROSS.GE.1) THEN
28248 DO 350 IC=1,NCROSS
28249 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28250 IF(PNFRAG.GT.PYR(0)) THEN
28251C...Scenario II: only compare with fragmentation time.
28252 IF(MSTP(115).EQ.2) THEN
28253 IACC=IC
28254 IIP=IPC(IACC)
28255 IIM=IMC(IACC)
28256 GOTO 360
28257C...Scenario II': also require that string length decreases.
28258 ELSE
28259 IIP=IPC(IC)
28260 IIM=IMC(IC)
28261 I1P=INP(IIP)
28262 I2P=INP(IIP+1)
28263 I1M=INM(IIM)
28264 I2M=INM(IIM+1)
28265 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28266 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28267 IF(ELNEW.LT.ELOLD) THEN
28268 IACC=IC
28269 IIP=IPC(IACC)
28270 IIM=IMC(IACC)
28271 GOTO 360
28272 ENDIF
28273 ENDIF
28274 ENDIF
28275 350 CONTINUE
28276 360 CONTINUE
28277 ENDIF
28278
28279C...Begin scenario GH specifics.
28280 ELSEIF(MSTP(115).EQ.5) THEN
28281
28282C...Loop through all string pieces, one from W+ and one from W-.
28283 IACC=0
28284 ELMIN=1D0
28285 DO 380 IIP=1,NNP-1
28286 IF(K(INP(IIP),2).LT.0) GOTO 380
28287 I1P=INP(IIP)
28288 I2P=INP(IIP+1)
28289 DO 370 IIM=1,NNM-1
28290 IF(K(INM(IIM),2).LT.0) GOTO 370
28291 I1M=INM(IIM)
28292 I2M=INM(IIM+1)
28293
28294C...Look for largest decrease of (exponent of) Lambda measure.
28295 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28296 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28297 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28298 IF(ELDIF.LT.ELMIN) THEN
28299 IACC=IIP+IIM
28300 ELMIN=ELDIF
28301 IPC(1)=IIP
28302 IMC(1)=IIM
28303 ENDIF
28304 370 CONTINUE
28305 380 CONTINUE
28306 IIP=IPC(1)
28307 IIM=IMC(1)
28308 ENDIF
28309
28310C...Common for scenarios I, II, II' and GH: reconnect strings.
28311 IF(IACC.NE.0) THEN
28312 MINT(32)=1
28313 NJOIN=0
28314 DO 390 IS=1,NNP+NNM
28315 NJOIN=NJOIN+1
28316 IF(IS.LE.IIP) THEN
28317 I=INP(IS)
28318 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28319 I=INM(IS-IIP+IIM)
28320 ELSEIF(IS.LE.IIP+NNM) THEN
28321 I=INM(IS-IIP-NNM+IIM)
28322 ELSE
28323 I=INP(IS-NNM)
28324 ENDIF
28325 IJOIN(NJOIN)=I
28326 IF(K(I,2).LT.0) THEN
28327 CALL PYJOIN(NJOIN,IJOIN)
28328 NJOIN=0
28329 ENDIF
28330 390 CONTINUE
28331
28332C...Restore original event record if no reconnection.
28333 ELSE
28334 DO 400 I=NSD1+1,NOLD
28335 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28336 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28337 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28338 ENDIF
28339 400 CONTINUE
28340 DO 410 I=NOLD+1,N
28341 K(K(I,3),1)=3
28342 410 CONTINUE
28343 N=NOLD
28344 ENDIF
28345
28346C...Boost back system.
28347 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28348 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28349 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28350 & BEWW(1),BEWW(2),BEWW(3))
28351
28352C...Common part for intermediate and instantaneous scenarios.
28353 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28354 MINT(32)=1
28355
28356C...Remove old shower products and reset showering ones.
28357 N=NSD1+4
28358 DO 420 I=NSD1+1,NSD1+4
28359 K(I,1)=3
28360 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28361 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28362 420 CONTINUE
28363
28364C...Identify quark-antiquark pairs.
28365 IQ1=NSD1+1
28366 IQ2=NSD1+2
28367 IQ3=NSD1+3
28368 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28369 IQ4=2*NSD1+7-IQ3
28370
28371C...Reconnect strings.
28372 IJOIN(1)=IQ1
28373 IJOIN(2)=IQ4
28374 CALL PYJOIN(2,IJOIN)
28375 IJOIN(1)=IQ3
28376 IJOIN(2)=IQ2
28377 CALL PYJOIN(2,IJOIN)
28378
28379C...Do new parton showers in intermediate scenario.
28380 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28381 MSTJ50=MSTJ(50)
28382 MSTJ(50)=0
28383 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28384 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28385 MSTJ(50)=MSTJ50
28386
28387C...Do new parton showers in instantaneous scenario.
28388 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28389 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28390 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28391 PPM=SQRT(MAX(0D0,PPM2))
28392 CALL PYSHOW(IQ1,IQ4,PPM)
28393 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28394 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28395 PPM=SQRT(MAX(0D0,PPM2))
28396 CALL PYSHOW(IQ3,IQ2,PPM)
28397 ENDIF
28398 ENDIF
28399
28400 RETURN
28401 END
28402
28403C***********************************************************************
28404
28405C...PYKLIM
28406C...Checks generated variables against pre-set kinematical limits;
28407C...also calculates limits on variables used in generation.
28408
28409 SUBROUTINE PYKLIM(ILIM)
28410
28411C...Double precision and integer declarations.
28412 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28413 IMPLICIT INTEGER(I-N)
28414 INTEGER PYK,PYCHGE,PYCOMP
28415C...Commonblocks.
28416 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28417 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28418 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28419 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28420 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28421 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28422 COMMON/PYINT1/MINT(400),VINT(400)
28423 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28424 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28425 &/PYINT1/,/PYINT2/
28426
28427C...Common kinematical expressions.
28428 MINT(51)=0
28429 ISUB=MINT(1)
28430 ISTSB=ISET(ISUB)
28431 IF(ISUB.EQ.96) GOTO 100
28432 SQM3=VINT(63)
28433 SQM4=VINT(64)
28434 IF(ILIM.NE.0) THEN
28435 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28436 CKIN09=MAX(CKIN(9),CKIN(13))
28437 CKIN10=MIN(CKIN(10),CKIN(14))
28438 CKIN11=MAX(CKIN(11),CKIN(15))
28439 CKIN12=MIN(CKIN(12),CKIN(16))
28440 ELSE
28441 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28442 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28443 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28444 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28445 ENDIF
28446 ENDIF
28447 IF(ILIM.NE.1) THEN
28448 TAU=VINT(21)
28449 RM3=SQM3/(TAU*VINT(2))
28450 RM4=SQM4/(TAU*VINT(2))
28451 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28452 ENDIF
28453 PTHMIN=CKIN(3)
28454 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28455 &PTHMIN=MAX(CKIN(3),CKIN(5))
28456
28457 IF(ILIM.EQ.0) THEN
28458C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28459C...pre-set kinematical limits.
28460 YST=VINT(22)
28461 CTH=VINT(23)
28462 TAUP=VINT(26)
28463 TAUE=TAU
28464 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28465 X1=SQRT(TAUE)*EXP(YST)
28466 X2=SQRT(TAUE)*EXP(-YST)
28467 XF=X1-X2
28468 IF(MINT(47).NE.1) THEN
28469 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28470 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28471 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28472 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28473 ENDIF
28474 IF(MINT(45).NE.1) THEN
28475 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28476 ENDIF
28477 IF(MINT(46).NE.1) THEN
28478 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28479 ENDIF
28480 IF(MINT(45).EQ.2) THEN
28481 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28482 ENDIF
28483 IF(MINT(46).EQ.2) THEN
28484 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28485 ENDIF
28486 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28487 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28488 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28489 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28490 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28491 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28492 Y3=YST+0.5D0*LOG(EXPY3)
28493 Y4=YST+0.5D0*LOG(EXPY4)
28494 YLARGE=MAX(Y3,Y4)
28495 YSMALL=MIN(Y3,Y4)
28496 ETALAR=20D0
28497 ETASMA=-20D0
28498 STH=SQRT(MAX(0D0,1D0-CTH**2))
28499 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28500 & CTH)**2-4D0*RM3))
28501 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28502 & CTH)**2-4D0*RM4))
28503 IF(STH.GE.1D-10) THEN
28504 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28505 & (BE34*STH)
28506 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28507 & (BE34*STH)
28508 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28509 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28510 ETALAR=MAX(ETA3,ETA4)
28511 ETASMA=MIN(ETA3,ETA4)
28512 ENDIF
28513 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28514 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28515 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28516 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28517 SH=TAU*VINT(2)
28518 RPTS=4D0*VINT(71)**2/SH
28519 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28520 RM34=MAX(1D-20,2D0*RM3*RM4)
28521 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28522 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28523 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28524 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28525 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28526 IF(PTH.LT.PTHMIN) MINT(51)=1
28527 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28528 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28529 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28530 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28531 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28532 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28533 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28534 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28535 IF(THA.LT.CKIN(35)) MINT(51)=1
28536 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28537 IF(UHA.LT.CKIN(37)) MINT(51)=1
28538 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28539 ENDIF
28540 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28541 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28542 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28543 ENDIF
28544
28545C...Additional cuts on W2 (approximately) in DIS.
28546 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28547 XBJ=X2
28548 IF(IABS(MINT(12)).LT.20) XBJ=X1
28549 Q2BJ=THA
28550 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28551 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28552 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28553 ENDIF
28554
28555 ELSEIF(ILIM.EQ.1) THEN
28556C...Calculate limits on tau
28557C...0) due to definition
28558 TAUMN0=0D0
28559 TAUMX0=1D0
28560C...1) due to limits on subsystem mass
28561 TAUMN1=CKIN(1)**2/VINT(2)
28562 TAUMX1=1D0
28563 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28564C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28565 TM3=SQRT(SQM3+PTHMIN**2)
28566 TM4=SQRT(SQM4+PTHMIN**2)
28567 YDCOSH=1D0
28568 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28569 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28570 TAUMX2=1D0
28571C...3) due to limits on pT-hat and cos(theta-hat)
28572 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28573 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28574 TAUMN3=0D0
28575 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28576 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28577 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28578 TAUMX3=1D0
28579 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28580 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28581 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28582C...4) due to limits on x1 and x2
28583 TAUMN4=CKIN(21)*CKIN(23)
28584 TAUMX4=CKIN(22)*CKIN(24)
28585C...5) due to limits on xF
28586 TAUMN5=0D0
28587 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28588C...6) due to limits on that and uhat
28589 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28590 TAUMX6=1D0
28591 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28592 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28593
28594C...Net effect of all separate limits.
28595 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28596 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28597 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28598 VINT(11)=1D0-1D-9
28599 VINT(31)=1D0+1D-9
28600 ELSEIF(MINT(47).EQ.5) THEN
28601 VINT(31)=MIN(VINT(31),1D0-2D-10)
28602 ELSEIF(MINT(47).GE.6) THEN
28603 VINT(31)=MIN(VINT(31),1D0-1D-10)
28604 ENDIF
28605 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28606
28607 ELSEIF(ILIM.EQ.2) THEN
28608C...Calculate limits on y*
28609 TAUE=TAU
28610 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28611 TAURT=SQRT(TAUE)
28612C...0) due to kinematics
28613 YSTMN0=LOG(TAURT)
28614 YSTMX0=-YSTMN0
28615C...1) due to explicit limits
28616 YSTMN1=CKIN(7)
28617 YSTMX1=CKIN(8)
28618C...2) due to limits on x1
28619 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28620 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28621C...3) due to limits on x2
28622 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28623 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28624C...4) due to limits on xF
28625 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28626 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28627 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28628 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28629C...5) due to simultaneous limits on y-large and y-small
28630 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28631 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28632 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28633 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28634 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28635 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28636C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28637C... y-small
28638 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28639 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28640 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28641 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28642 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28643 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28644 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28645 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28646 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28647
28648C...Net effect of all separate limits.
28649 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28650 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28651 IF(MINT(47).EQ.1) THEN
28652 VINT(12)=-1D-9
28653 VINT(32)=1D-9
28654 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28655 VINT(12)=(1D0-1D-9)*YSTMX0
28656 VINT(32)=(1D0+1D-9)*YSTMX0
28657 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28658 VINT(12)=-(1D0+1D-9)*YSTMX0
28659 VINT(32)=-(1D0-1D-9)*YSTMX0
28660 ELSEIF(MINT(47).EQ.5) THEN
28661 YSTEE=LOG((1D0-1D-10)/TAURT)
28662 VINT(12)=MAX(VINT(12),-YSTEE)
28663 VINT(32)=MIN(VINT(32),YSTEE)
28664 ENDIF
28665 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28666
28667 ELSEIF(ILIM.EQ.3) THEN
28668C...Calculate limits on cos(theta-hat)
28669 YST=VINT(22)
28670C...0) due to definition
28671 CTNMN0=-1D0
28672 CTNMX0=0D0
28673 CTPMN0=0D0
28674 CTPMX0=1D0
28675C...1) due to explicit limits
28676 CTNMN1=MIN(0D0,CKIN(27))
28677 CTNMX1=MIN(0D0,CKIN(28))
28678 CTPMN1=MAX(0D0,CKIN(27))
28679 CTPMX1=MAX(0D0,CKIN(28))
28680C...2) due to limits on pT-hat
28681 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28682 CTPMX2=-CTNMN2
28683 CTNMX2=0D0
28684 CTPMN2=0D0
28685 IF(CKIN(4).GE.0D0) THEN
28686 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28687 & (BE34**2*TAU*VINT(2))))
28688 CTPMN2=-CTNMX2
28689 ENDIF
28690C...3) due to limits on y-large and y-small
28691 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28692 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28693 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28694 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28695 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28696 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28697 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28698 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28699C...4) due to limits on that
28700 CTNMN4=-1D0
28701 CTNMX4=0D0
28702 CTPMN4=0D0
28703 CTPMX4=1D0
28704 SH=TAU*VINT(2)
28705 IF(CKIN(35).GT.0D0) THEN
28706 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28707 IF(CTLIM.GT.0D0) THEN
28708 CTPMX4=CTLIM
28709 ELSE
28710 CTPMX4=0D0
28711 CTNMX4=CTLIM
28712 ENDIF
28713 ENDIF
28714 IF(CKIN(36).GT.0D0) THEN
28715 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28716 IF(CTLIM.LT.0D0) THEN
28717 CTNMN4=CTLIM
28718 ELSE
28719 CTNMN4=0D0
28720 CTPMN4=CTLIM
28721 ENDIF
28722 ENDIF
28723C...5) due to limits on uhat
28724 CTNMN5=-1D0
28725 CTNMX5=0D0
28726 CTPMN5=0D0
28727 CTPMX5=1D0
28728 IF(CKIN(37).GT.0D0) THEN
28729 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28730 IF(CTLIM.LT.0D0) THEN
28731 CTNMN5=CTLIM
28732 ELSE
28733 CTNMN5=0D0
28734 CTPMN5=CTLIM
28735 ENDIF
28736 ENDIF
28737 IF(CKIN(38).GT.0D0) THEN
28738 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28739 IF(CTLIM.GT.0D0) THEN
28740 CTPMX5=CTLIM
28741 ELSE
28742 CTPMX5=0D0
28743 CTNMX5=CTLIM
28744 ENDIF
28745 ENDIF
28746
28747C...Net effect of all separate limits.
28748 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28749 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28750 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28751 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28752 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28753
28754 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28755 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28756
28757 ELSEIF(ILIM.EQ.4) THEN
28758C...Calculate limits on tau'
28759C...0) due to kinematics
28760 TAPMN0=TAU
28761 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28762 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28763 TAPMN0=(SQRT(TAU)+PQRAT)**2
28764 ENDIF
28765 TAPMX0=1D0
28766C...1) due to explicit limits
28767 TAPMN1=CKIN(31)**2/VINT(2)
28768 TAPMX1=1D0
28769 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28770
28771C...Net effect of all separate limits.
28772 VINT(16)=MAX(TAPMN0,TAPMN1)
28773 VINT(36)=MIN(TAPMX0,TAPMX1)
28774 IF(MINT(47).EQ.1) THEN
28775 VINT(16)=1D0-1D-9
28776 VINT(36)=1D0+1D-9
28777 ELSEIF(MINT(47).EQ.5) THEN
28778 VINT(36)=MIN(VINT(36),1D0-2D-10)
28779 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28780 VINT(36)=MIN(VINT(36),1D0-1D-10)
28781 ENDIF
28782 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28783
28784 ENDIF
28785 RETURN
28786
28787C...Special case for low-pT and multiple interactions:
28788C...effective kinematical limits for tau, y*, cos(theta-hat).
28789 100 IF(ILIM.EQ.0) THEN
28790 ELSEIF(ILIM.EQ.1) THEN
28791 IF(MSTP(82).LE.1) THEN
28792 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28793 & VINT(2)
28794 ELSE
28795 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28796 ENDIF
28797 VINT(31)=1D0
28798 ELSEIF(ILIM.EQ.2) THEN
28799 VINT(12)=0.5D0*LOG(VINT(21))
28800 VINT(32)=-VINT(12)
28801 ELSEIF(ILIM.EQ.3) THEN
28802 IF(MSTP(82).LE.1) THEN
28803 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28804 & (VINT(21)*VINT(2))
28805 ELSE
28806 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28807 & (VINT(21)*VINT(2))
28808 ENDIF
28809 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28810 VINT(33)=0D0
28811 VINT(14)=0D0
28812 VINT(34)=-VINT(13)
28813 ENDIF
28814
28815 RETURN
28816 END
28817
28818C*********************************************************************
28819
28820C...PYKMAP
28821C...Maps a uniform distribution into a distribution of a kinematical
28822C...variable according to one of the possibilities allowed. It is
28823C...assumed that kinematical limits have been set by a PYKLIM call.
28824
28825 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28826
28827C...Double precision and integer declarations.
28828 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28829 IMPLICIT INTEGER(I-N)
28830 INTEGER PYK,PYCHGE,PYCOMP
28831C...Commonblocks.
28832 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28833 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28834 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28835 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28836 COMMON/PYINT1/MINT(400),VINT(400)
28837 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28838 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28839
28840C...Convert VVAR to tau variable.
28841 ISUB=MINT(1)
28842 ISTSB=ISET(ISUB)
28843 IF(IVAR.EQ.1) THEN
28844 TAUMIN=VINT(11)
28845 TAUMAX=VINT(31)
28846 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28847 TAURE=VINT(73)
28848 GAMRE=VINT(74)
28849 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28850 TAURE=VINT(75)
28851 GAMRE=VINT(76)
28852 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28853 TAURE=VINT(77)
28854 GAMRE=VINT(78)
28855 ENDIF
28856 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28857 TAU=1D0
28858 ELSEIF(MVAR.EQ.1) THEN
28859 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28860 ELSEIF(MVAR.EQ.2) THEN
28861 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28862 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28863 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28864 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28865 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28866 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28867 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28868 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28869 ELSEIF(MINT(47).EQ.5) THEN
28870 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28871 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28872 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28873 ELSE
28874 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28875 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28876 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28877 ENDIF
28878 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28879
28880C...Convert VVAR to y* variable.
28881 ELSEIF(IVAR.EQ.2) THEN
28882 YSTMIN=VINT(12)
28883 YSTMAX=VINT(32)
28884 TAUE=VINT(21)
28885 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28886 IF(MINT(47).EQ.1) THEN
28887 YST=0D0
28888 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28889 YST=-0.5D0*LOG(TAUE)
28890 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28891 YST=0.5D0*LOG(TAUE)
28892 ELSEIF(MVAR.EQ.1) THEN
28893 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28894 ELSEIF(MVAR.EQ.2) THEN
28895 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28896 ELSEIF(MVAR.EQ.3) THEN
28897 AUPP=ATAN(EXP(YSTMAX))
28898 ALOW=ATAN(EXP(YSTMIN))
28899 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28900 ELSEIF(MVAR.EQ.4) THEN
28901 YST0=-0.5D0*LOG(TAUE)
28902 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28903 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28904 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28905 ELSE
28906 YST0=-0.5D0*LOG(TAUE)
28907 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28908 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28909 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28910 ENDIF
28911 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28912
28913C...Convert VVAR to cos(theta-hat) variable.
28914 ELSEIF(IVAR.EQ.3) THEN
28915 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28916 RSQM=1D0+RM34
28917 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28918 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28919 CTNMIN=VINT(13)
28920 CTNMAX=VINT(33)
28921 CTPMIN=VINT(14)
28922 CTPMAX=VINT(34)
28923 IF(MVAR.EQ.1) THEN
28924 ANEG=CTNMAX-CTNMIN
28925 APOS=CTPMAX-CTPMIN
28926 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28927 VCTN=VVAR*(ANEG+APOS)/ANEG
28928 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28929 ELSE
28930 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28931 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28932 ENDIF
28933 ELSEIF(MVAR.EQ.2) THEN
28934 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28935 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28936 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28937 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28938 ANEG=LOG(RMNMIN/RMNMAX)
28939 APOS=LOG(RMPMIN/RMPMAX)
28940 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28941 VCTN=VVAR*(ANEG+APOS)/ANEG
28942 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28943 ELSE
28944 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28945 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28946 ENDIF
28947 ELSEIF(MVAR.EQ.3) THEN
28948 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28949 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28950 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28951 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28952 ANEG=LOG(RMNMAX/RMNMIN)
28953 APOS=LOG(RMPMAX/RMPMIN)
28954 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28955 VCTN=VVAR*(ANEG+APOS)/ANEG
28956 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28957 ELSE
28958 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28959 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28960 ENDIF
28961 ELSEIF(MVAR.EQ.4) THEN
28962 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28963 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28964 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28965 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28966 ANEG=1D0/RMNMAX-1D0/RMNMIN
28967 APOS=1D0/RMPMAX-1D0/RMPMIN
28968 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28969 VCTN=VVAR*(ANEG+APOS)/ANEG
28970 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28971 ELSE
28972 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28973 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28974 ENDIF
28975 ELSEIF(MVAR.EQ.5) THEN
28976 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28977 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28978 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28979 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28980 ANEG=1D0/RMNMIN-1D0/RMNMAX
28981 APOS=1D0/RMPMIN-1D0/RMPMAX
28982 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28983 VCTN=VVAR*(ANEG+APOS)/ANEG
28984 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28985 ELSE
28986 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28987 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28988 ENDIF
28989 ENDIF
28990 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
28991 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
28992 VINT(23)=CTH
28993
28994C...Convert VVAR to tau' variable.
28995 ELSEIF(IVAR.EQ.4) THEN
28996 TAU=VINT(21)
28997 TAUPMN=VINT(16)
28998 TAUPMX=VINT(36)
28999 IF(MINT(47).EQ.1) THEN
29000 TAUP=1D0
29001 ELSEIF(MVAR.EQ.1) THEN
29002 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29003 ELSEIF(MVAR.EQ.2) THEN
29004 AUPP=(1D0-TAU/TAUPMX)**4
29005 ALOW=(1D0-TAU/TAUPMN)**4
29006 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29007 ELSEIF(MINT(47).EQ.5) THEN
29008 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29009 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29010 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29011 ELSE
29012 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29013 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29014 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29015 ENDIF
29016 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29017
29018C...Selection of extra variables needed in 2 -> 3 process:
29019C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29020C...Since no options are available, the functions of PYKLIM
29021C...and PYKMAP are joint for these choices.
29022 ELSEIF(IVAR.EQ.5) THEN
29023
29024C...Read out total energy and particle masses.
29025 MINT(51)=0
29026 MPTPK=1
29027 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29028 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29029 & MPTPK=2
29030 SHP=VINT(26)*VINT(2)
29031 SHPR=SQRT(SHP)
29032 PM1=VINT(201)
29033 PM2=VINT(206)
29034 PM3=SQRT(VINT(21))*VINT(1)
29035 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29036 MINT(51)=1
29037 RETURN
29038 ENDIF
29039 PMRS1=VINT(204)**2
29040 PMRS2=VINT(209)**2
29041
29042C...Specify coefficients of pT choice; upper and lower limits.
29043 IF(MPTPK.EQ.1) THEN
29044 HWT1=0.4D0
29045 HWT2=0.4D0
29046 ELSE
29047 HWT1=0.05D0
29048 HWT2=0.05D0
29049 ENDIF
29050 HWT3=1D0-HWT1-HWT2
29051 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29052 & (4D0*SHP)
29053 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29054 PTSMN1=CKIN(51)**2
29055 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29056 & (4D0*SHP)
29057 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29058 PTSMN2=CKIN(53)**2
29059
29060C...Select transverse momenta according to
29061C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29062 HMX=PMRS1+PTSMX1
29063 HMN=PMRS1+PTSMN1
29064 IF(HMX.LT.1.0001D0*HMN) THEN
29065 MINT(51)=1
29066 RETURN
29067 ENDIF
29068 HDE=PTSMX1-PTSMN1
29069 RPT=PYR(0)
29070 IF(RPT.LT.HWT1) THEN
29071 PTS1=PTSMN1+PYR(0)*HDE
29072 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29073 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29074 ELSE
29075 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29076 ENDIF
29077 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29078 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29079 HMX=PMRS2+PTSMX2
29080 HMN=PMRS2+PTSMN2
29081 IF(HMX.LT.1.0001D0*HMN) THEN
29082 MINT(51)=1
29083 RETURN
29084 ENDIF
29085 HDE=PTSMX2-PTSMN2
29086 RPT=PYR(0)
29087 IF(RPT.LT.HWT1) THEN
29088 PTS2=PTSMN2+PYR(0)*HDE
29089 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29090 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29091 ELSE
29092 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29093 ENDIF
29094 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29095 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29096
29097C...Select azimuthal angles and check pT choice.
29098 PHI1=PARU(2)*PYR(0)
29099 PHI2=PARU(2)*PYR(0)
29100 PHIR=PHI2-PHI1
29101 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29102 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29103 & CKIN(56)**2)) THEN
29104 MINT(51)=1
29105 RETURN
29106 ENDIF
29107
29108C...Calculate transverse masses and check phase space not closed.
29109 PMS1=PM1**2+PTS1
29110 PMS2=PM2**2+PTS2
29111 PMS3=PM3**2+PTS3
29112 PMT1=SQRT(PMS1)
29113 PMT2=SQRT(PMS2)
29114 PMT3=SQRT(PMS3)
29115 PM12=(PMT1+PMT2)**2
29116 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29117 MINT(51)=1
29118 RETURN
29119 ENDIF
29120
29121C...Select rapidity for particle 3 and check phase space not closed.
29122 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29123 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29124 IF(Y3MAX.LT.1D-6) THEN
29125 MINT(51)=1
29126 RETURN
29127 ENDIF
29128 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29129 PZ3=PMT3*SINH(Y3)
29130 PE3=PMT3*COSH(Y3)
29131
29132C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29133 PZ12=-PZ3
29134 PE12=SHPR-PE3
29135 PMS12=PE12**2-PZ12**2
29136 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29137 IF(SQL12.LT.1D-6*SHP) THEN
29138 MINT(51)=1
29139 RETURN
29140 ENDIF
29141 PMM1=PMS12+PMS1-PMS2
29142 PMM2=PMS12+PMS2-PMS1
29143 TFAC=-SHPR/(2D0*PMS12)
29144 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29145 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29146 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29147 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29148
29149C...Construct relative mirror weights and make choice.
29150 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29151 WTPU=1D0
29152 WTNU=1D0
29153 ELSE
29154 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29155 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29156 ENDIF
29157 WTP=WTPU/(WTPU+WTNU)
29158 WTN=WTNU/(WTPU+WTNU)
29159 EPS=1D0
29160 IF(WTN.GT.PYR(0)) EPS=-1D0
29161
29162C...Store result of variable choice and associated weights.
29163 VINT(202)=PTS1
29164 VINT(207)=PTS2
29165 VINT(203)=PHI1
29166 VINT(208)=PHI2
29167 VINT(205)=WTPTS1
29168 VINT(210)=WTPTS2
29169 VINT(211)=Y3
29170 VINT(212)=Y3MAX
29171 VINT(213)=EPS
29172 IF(EPS.GT.0D0) THEN
29173 VINT(214)=1D0/WTP
29174 VINT(215)=T1P
29175 VINT(216)=T2P
29176 ELSE
29177 VINT(214)=1D0/WTN
29178 VINT(215)=T1N
29179 VINT(216)=T2N
29180 ENDIF
29181 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29182 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29183 VINT(219)=0.5D0*(PMS12-PTS3)
29184 VINT(220)=SQL12
29185 ENDIF
29186
29187 RETURN
29188 END
29189
29190C***********************************************************************
29191
29192C...PYSIGH
29193C...Differential matrix elements for all included subprocesses
29194C...Note that what is coded is (disregarding the COMFAC factor)
29195C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29196C...when d(sigma-hat) is given in the zero-width limit, the delta
29197C...function in tau is replaced by a (modified) Breit-Wigner:
29198C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29199C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29200C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29201C...i.e., dimensionless quantities
29202C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29203C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29204C...(2pi)^4 delta^4(P - sum p_i)
29205C...COMFAC contains the factor pi/s (or equivalent) and
29206C...the conversion factor from GeV^-2 to mb
29207
29208 SUBROUTINE PYSIGH(NCHN,SIGS)
29209
29210C...Double precision and integer declarations
29211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29212 IMPLICIT INTEGER(I-N)
29213 INTEGER PYK,PYCHGE,PYCOMP
29214C...Parameter statement to help give large particle numbers.
29215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29216 &KEXCIT=4000000,KDIMEN=5000000)
29217C...Commonblocks
29218 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29219 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29220 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29221 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29222 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29223 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29224 COMMON/PYINT1/MINT(400),VINT(400)
29225 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29226 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29227 COMMON/PYINT4/MWID(500),WIDS(500,5)
29228 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29229 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29231 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29232 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29233 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29234 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29235 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29236 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29237 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29238 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29239 COMMON/PYTCCO/COEFX(194:380,2)
29240 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29241 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29242 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29243C...Local arrays and complex variables
29244 DIMENSION XPQ(-25:25)
29245
29246C...Map of processes onto which routine to call
29247C...in order to evaluate cross section:
29248C...0 = not implemented;
29249C...1 = standard QCD (including photons);
29250C...2 = heavy flavours;
29251C...3 = W/Z;
29252C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29253C...5 = SUSY;
29254C...6 = Technicolor;
29255C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29256C...8 = Universal Extra Dimensions
29257 DIMENSION MAPPR(500)
29258 DATA (MAPPR(I),I=1,180)/
29259 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29260 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29261 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29262 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29263 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29264 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29265 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29266 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29267 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29268 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29269 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29270 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29271 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29272 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29273 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29274 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29275 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29276 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29277 DATA (MAPPR(I),I=181,500)/
29278 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29279 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29280 & 100*5,
29281 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29282 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29283 1 20*0,
29284 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29285 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29286 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29287 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29288 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29289 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29290 & 4, 4, 18*0,
29291 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29292 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29293 4 20*0,
29294 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29295 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29296 8 20*0/
29297
29298C...Reset number of channels and cross-section
29299 NCHN=0
29300 SIGS=0D0
29301
29302C...Read process to consider.
29303 ISUB=MINT(1)
29304 ISUBSV=ISUB
29305 MAP=MAPPR(ISUB)
29306
29307C...Read kinematical variables and limits
29308 ISTSB=ISET(ISUBSV)
29309 TAUMIN=VINT(11)
29310 YSTMIN=VINT(12)
29311 CTNMIN=VINT(13)
29312 CTPMIN=VINT(14)
29313 TAUPMN=VINT(16)
29314 TAU=VINT(21)
29315 YST=VINT(22)
29316 CTH=VINT(23)
29317 XT2=VINT(25)
29318 TAUP=VINT(26)
29319 TAUMAX=VINT(31)
29320 YSTMAX=VINT(32)
29321 CTNMAX=VINT(33)
29322 CTPMAX=VINT(34)
29323 TAUPMX=VINT(36)
29324
29325C...Derive kinematical quantities
29326 TAUE=TAU
29327 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29328 X(1)=SQRT(TAUE)*EXP(YST)
29329 X(2)=SQRT(TAUE)*EXP(-YST)
29330 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29331 IF(X(1).GT.1D0-1D-7) RETURN
29332 ELSEIF(MINT(45).EQ.3) THEN
29333 X(1)=MIN(1D0-1.1D-10,X(1))
29334 ENDIF
29335 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29336 IF(X(2).GT.1D0-1D-7) RETURN
29337 ELSEIF(MINT(46).EQ.3) THEN
29338 X(2)=MIN(1D0-1.1D-10,X(2))
29339 ENDIF
29340 SH=MAX(1D0,TAU*VINT(2))
29341 SQM3=VINT(63)
29342 SQM4=VINT(64)
29343 RM3=SQM3/SH
29344 RM4=SQM4/SH
29345 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29346 RPTS=4D0*VINT(71)**2/SH
29347 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29348 RM34=MAX(1D-20,2D0*RM3*RM4)
29349 RSQM=1D0+RM34
29350 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29351 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29352 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29353 IF(ISTSB.EQ.0) THEN
29354 TH=VINT(45)
29355 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29356 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29357 ELSE
29358C...Kinematics with incoming masses tricky: now depends on how
29359C...subprocess has been set up w.r.t. order of incoming partons.
29360 RM1=0D0
29361 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29362 RM2=0D0
29363 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29364 IF(ISUB.EQ.35) THEN
29365 RM2=MIN(RM1,RM2)
29366 RM1=0D0
29367 ENDIF
29368 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29369 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29370 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29371 & BE12*BE34*CTH)
29372 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29373 & BE12*BE34*CTH)
29374 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29375 ENDIF
29376 SHR=SQRT(SH)
29377 SH2=SH**2
29378 TH2=TH**2
29379 UH2=UH**2
29380
29381C...Choice of Q2 scale for hard process (e.g. alpha_s).
29382 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29383 Q2=SH
29384 ELSEIF(ISTSB.EQ.8) THEN
29385 IF(MINT(107).EQ.4) Q2=VINT(307)
29386 IF(MINT(108).EQ.4) Q2=VINT(308)
29387 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29388 Q2IN1=0D0
29389 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29390 Q2IN2=0D0
29391 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29392 IF(MSTP(32).EQ.1) THEN
29393 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29394 ELSEIF(MSTP(32).EQ.2) THEN
29395 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29396 ELSEIF(MSTP(32).EQ.3) THEN
29397 Q2=MIN(-TH,-UH)
29398 ELSEIF(MSTP(32).EQ.4) THEN
29399 Q2=SH
29400 ELSEIF(MSTP(32).EQ.5) THEN
29401 Q2=-TH
29402 ELSEIF(MSTP(32).EQ.6) THEN
29403 XSF1=X(1)
29404 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29405 XSF2=X(2)
29406 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29407 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29408 & (SQPTH+0.5D0*(SQM3+SQM4))
29409 ELSEIF(MSTP(32).EQ.7) THEN
29410 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29411 ELSEIF(MSTP(32).EQ.8) THEN
29412 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29413 ELSEIF(MSTP(32).EQ.9) THEN
29414 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29415 ELSEIF(MSTP(32).EQ.10) THEN
29416 Q2=VINT(2)
29417C..Begin JA 040914
29418 ELSEIF(MSTP(32).EQ.11) THEN
29419 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29420 ELSEIF(MSTP(32).EQ.12) THEN
29421 Q2=PARP(193)
29422C..End JA
29423 ELSEIF(MSTP(32).EQ.13) THEN
29424 Q2=SQPTH
29425 ENDIF
29426 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29427 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29428 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29429 ENDIF
29430
29431C...Choice of Q2 scale for parton densities.
29432 Q2SF=Q2
29433C..Begin JA 040914
29434 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29435 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29436 & Q2=PARP(194)
29437C..End JA
29438 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29439 Q2SF=PMAS(23,1)**2
29440 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29441 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29442 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29443 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29444 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29445 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29446 IF(MSTP(39).EQ.2) Q2SF=
29447 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29448 IF(MSTP(39).EQ.3) Q2SF=SH
29449 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29450 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29451C..Begin JA 040914
29452 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29453 IF(MSTP(39).EQ.7) Q2SF=
29454 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29455 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29456C..End JA
29457 ENDIF
29458 ENDIF
29459 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29460
29461 Q2PS=Q2SF
29462 Q2SF=Q2SF*PARP(34)
29463 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29464 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29465
29466C...Identify to which class(es) subprocess belongs
29467 ISMECR=0
29468 ISQCD=0
29469 ISJETS=0
29470 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29471 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29472 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29473 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29474 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29475 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29476 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29477 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29478 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29479 IF (ISTSB.EQ.9) ISQCD=1
29480 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29481 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29482 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29483 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29484 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29485 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29486 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29487 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29488C...WBF is special case of ISJETS
29489 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29490 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29491 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29492 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29493 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29494 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29495 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29496 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29497 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29498C...Some processes with photons also belong here.
29499 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29500 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29501 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29502 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29503 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29504 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29505
29506C...Choice of Q2 scale for parton-shower activity.
29507 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29508 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29509 XBJ=X(2)
29510 IF(MINT(43).EQ.3) XBJ=X(1)
29511 IF(MSTP(22).EQ.1) THEN
29512 Q2PS=-TH
29513 ELSEIF(MSTP(22).EQ.2) THEN
29514 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29515 ELSEIF(MSTP(22).EQ.3) THEN
29516 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29517 ELSE
29518 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29519 ENDIF
29520 ENDIF
29521C...For multiple interactions, start from scale defined above
29522C...For all other QCD or "+jets"-type events, start shower from pThard.
29523 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29524 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29525C...Max shower scale = s for ME corrected processes.
29526C...(pT-ordering: max pT2 is s/4)
29527 Q2PS=VINT(2)
29528 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29529 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29530C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29531C...(pT-ordering: max pT2 is s/4)
29532 Q2PS=VINT(2)
29533 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29534 ENDIF
29535 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29536
29537C...Elastic and diffractive events not associated with scales so set 0.
29538 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29539 Q2SF=0D0
29540 Q2PS=0D0
29541 ENDIF
29542
29543C...Store derived kinematical quantities
29544 VINT(41)=X(1)
29545 VINT(42)=X(2)
29546 VINT(44)=SH
29547 VINT(43)=SQRT(SH)
29548 VINT(45)=TH
29549 VINT(46)=UH
29550 IF(ISTSB.NE.8) VINT(48)=SQPTH
29551 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29552 VINT(50)=TAUP*VINT(2)
29553 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29554 VINT(52)=Q2
29555 VINT(51)=SQRT(Q2)
29556 VINT(54)=Q2SF
29557 VINT(53)=SQRT(Q2SF)
29558 VINT(56)=Q2PS
29559 VINT(55)=SQRT(Q2PS)
29560
29561C...Set starting scale for multiple interactions
29562 IF (ISUBSV.EQ.95) THEN
29563 XT2GMX=0D0
29564 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29565 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29566 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29567 & ISUBSV.NE.96)) THEN
29568C...All accessible phase space allowed.
29569 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29570 ELSE
29571C...Scale of hard process sets limit.
29572C...2 -> 1. Limit is tau = x1*x2.
29573C...2 -> 2. Limit is XT2 for hard process + FS masses.
29574C...2 -> n > 2. Limit is tau' = tau of outer process.
29575 XT2GMX=VINT(25)
29576 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29577 IF(ISTSB.EQ.2)
29578 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29579 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29580 ENDIF
29581 VINT(62)=0.25D0*XT2GMX*VINT(2)
29582 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29583
29584C...Calculate parton distributions
29585 IF(ISTSB.LE.0) GOTO 160
29586 IF(MINT(47).GE.2) THEN
29587 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29588 XSF=X(I)
29589 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29590 IF(ISUB.EQ.99) THEN
29591 IF(MINT(140+I).EQ.0) THEN
29592 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29593 ELSE
29594 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29595 ENDIF
29596 VINT(40+I)=XSF
29597 Q2SF=VINT(309-I)
29598 ENDIF
29599 MINT(105)=MINT(102+I)
29600 MINT(109)=MINT(106+I)
29601 VINT(120)=VINT(2+I)
29602C.... ALICE
29603C.... Store side in MINT(124)
29604 MINT(124) = I
29605C....
29606 IF(MSTP(57).LE.1) THEN
29607 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29608 ELSE
29609 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29610 ENDIF
29611C...Safety margin against heavy flavour very close to threshold,
29612C...e.g. caused by mismatch in c and b masses.
29613 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29614 XPQ(4)=0D0
29615 XPQ(-4)=0D0
29616 ENDIF
29617 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29618 XPQ(5)=0D0
29619 XPQ(-5)=0D0
29620 ENDIF
29621 DO 100 KFL=-25,25
29622 XSFX(I,KFL)=XPQ(KFL)
29623 100 CONTINUE
29624 110 CONTINUE
29625 ENDIF
29626
29627C...Calculate alpha_em, alpha_strong and K-factor
29628 XW=PARU(102)
29629 XWV=XW
29630 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29631 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29632 XW1=1D0-XW
29633 XWC=1D0/(16D0*XW*XW1)
29634 AEM=PYALEM(Q2)
29635 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29636 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29637 FACK=1D0
29638 FACA=1D0
29639 IF(MSTP(33).EQ.1) THEN
29640 FACK=PARP(31)
29641 ELSEIF(MSTP(33).EQ.2) THEN
29642 FACK=PARP(31)
29643 FACA=PARP(32)/PARP(31)
29644 ELSEIF(MSTP(33).EQ.3) THEN
29645 Q2AS=PARP(33)*Q2
29646 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29647 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29648 AS=PYALPS(Q2AS)
29649 ENDIF
29650 VINT(138)=1D0
29651 VINT(57)=AEM
29652 VINT(58)=AS
29653
29654C...Set flags for allowed reacting partons/leptons
29655 DO 140 I=1,2
29656 DO 120 J=-25,25
29657 KFAC(I,J)=0
29658 120 CONTINUE
29659 IF(MINT(44+I).EQ.1) THEN
29660 KFAC(I,MINT(10+I))=1
29661 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29662 KFAC(I,MINT(10+I))=1
29663 KFAC(I,22)=1
29664 KFAC(I,24)=1
29665 KFAC(I,-24)=1
29666 ELSE
29667 DO 130 J=-25,25
29668 KFAC(I,J)=KFIN(I,J)
29669 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29670 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29671 130 CONTINUE
29672 ENDIF
29673 140 CONTINUE
29674
29675C...Lower and upper limit for fermion flavour loops
29676 MMIN1=0
29677 MMAX1=0
29678 MMIN2=0
29679 MMAX2=0
29680 DO 150 J=-20,20
29681 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29682 IF(KFAC(1,J).EQ.1) MMAX1=J
29683 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29684 IF(KFAC(2,J).EQ.1) MMAX2=J
29685 150 CONTINUE
29686 MMINA=MIN(MMIN1,MMIN2)
29687 MMAXA=MAX(MMAX1,MMAX2)
29688
29689C...Common resonance mass and width combinations
29690 SQMZ=PMAS(23,1)**2
29691 SQMW=PMAS(24,1)**2
29692 GMMZ=PMAS(23,1)*PMAS(23,2)
29693 GMMW=PMAS(24,1)*PMAS(24,2)
29694
29695C...Polarization factors...implemented so far for W+W-(25)
29696 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29697 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29698 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29699 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29700
29701C...Phase space integral in tau
29702 COMFAC=PARU(1)*PARU(5)/VINT(2)
29703 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29704 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29705 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29706 ATAU1=LOG(TAUMAX/TAUMIN)
29707 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29708 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29709 IF(MINT(72).GE.1) THEN
29710 TAUR1=VINT(73)
29711 GAMR1=VINT(74)
29712 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29713 ATAU3=ATAUD/TAUR1
29714 IF(ATAUD.GT.1D-10) H1=H1+
29715 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29716 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29717 ATAU4=ATAUD/GAMR1
29718 IF(ATAUD.GT.1D-10) H1=H1+
29719 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29720 ENDIF
29721 IF(MINT(72).GE.2) THEN
29722 TAUR2=VINT(75)
29723 GAMR2=VINT(76)
29724 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29725 ATAU5=ATAUD/TAUR2
29726 IF(ATAUD.GT.1D-10) H1=H1+
29727 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29728 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29729 ATAU6=ATAUD/GAMR2
29730 IF(ATAUD.GT.1D-10) H1=H1+
29731 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29732 ENDIF
29733 IF(MINT(72).EQ.3) THEN
29734 TAUR3=VINT(77)
29735 GAMR3=VINT(78)
29736 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29737 ATAU50=ATAUD/TAUR3
29738 IF(ATAUD.GT.1D-10) H1=H1+
29739 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29740 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29741 ATAU60=ATAUD/GAMR3
29742 IF(ATAUD.GT.1D-10) H1=H1+
29743 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29744 ENDIF
29745 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29746 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29747 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29748 & MAX(2D-10,1D0-TAU)
29749 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29750 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29751 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29752 & MAX(1D-10,1D0-TAU)
29753 ENDIF
29754 COMFAC=COMFAC*ATAU1/(TAU*H1)
29755 ENDIF
29756
29757C...Phase space integral in y*
29758 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29759 &THEN
29760 AYST0=YSTMAX-YSTMIN
29761 IF(AYST0.LT.1D-10) THEN
29762 COMFAC=0D0
29763 ELSE
29764 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29765 AYST2=AYST1
29766 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29767 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29768 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29769 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29770 IF(MINT(45).EQ.3) THEN
29771 YST0=-0.5D0*LOG(TAUE)
29772 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29773 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29774 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29775 & MAX(1D-10,1D0-EXP(YST-YST0))
29776 ENDIF
29777 IF(MINT(46).EQ.3) THEN
29778 YST0=-0.5D0*LOG(TAUE)
29779 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29780 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29781 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29782 & MAX(1D-10,1D0-EXP(-YST-YST0))
29783 ENDIF
29784 COMFAC=COMFAC*AYST0/H2
29785 ENDIF
29786 ENDIF
29787
29788C...2 -> 1 processes: reduction in angular part of phase space integral
29789C...for case of decaying resonance
29790 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29791 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29792 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29793 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29794 & KFPR(ISUB,1).EQ.39) THEN
29795 COMFAC=COMFAC*0.5D0*ACTH0
29796 ELSE
29797 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29798 & CTPMAX**3-CTPMIN**3)
29799 ENDIF
29800 ENDIF
29801
29802C...2 -> 2 processes: angular part of phase space integral
29803 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29804 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29805 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29806 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29807 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29808 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29809 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29810 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29811 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29812 H3=COEF(ISUBSV,13)+
29813 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29814 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29815 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29816 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29817 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29818
29819C...2 -> 2 processes: take into account final state Breit-Wigners
29820 COMFAC=COMFAC*VINT(80)
29821 ENDIF
29822
29823C...2 -> 3, 4 processes: phace space integral in tau'
29824 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29825 ATAUP1=LOG(TAUPMX/TAUPMN)
29826 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29827 H4=COEF(ISUBSV,18)+
29828 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29829 IF(MINT(47).EQ.5) THEN
29830 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29831 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29832 ELSEIF(MINT(47).GE.6) THEN
29833 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29834 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29835 ENDIF
29836 COMFAC=COMFAC*ATAUP1/H4
29837 ENDIF
29838
29839C...2 -> 3, 4 processes: effective W/Z parton distributions
29840 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29841 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29842 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29843 ELSE
29844 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29845 ENDIF
29846 COMFAC=COMFAC*FZW
29847 ENDIF
29848
29849C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29850 IF(ISTSB.EQ.5) THEN
29851 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29852 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29853 ENDIF
29854
29855C...Phase space integral for low-pT and multiple interactions
29856 IF(ISTSB.EQ.9) THEN
29857 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29858 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29859 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29860 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29861 COMFAC=COMFAC*ATAU1/H1
29862 AYST0=YSTMAX-YSTMIN
29863 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29864 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29865 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29866 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29867 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29868 COMFAC=COMFAC*AYST0/H2
29869 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29870C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29871C...introduced to make cross-section finite for xT2 -> 0
29872 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29873 & (1D0+VINT(149)))
29874 ENDIF
29875
29876C...Real gamma + gamma: include factor 2 when different nature
29877 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29878 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29879
29880C...Extra factors to include the effects of
29881C...longitudinal resolved photons (but not direct or DIS ones).
29882 DO 170 ISDE=1,2
29883 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29884 & MINT(106+ISDE).LE.3) THEN
29885 VINT(314+ISDE)=1D0
29886 XY=PARP(166+ISDE)
29887 IF(MSTP(16).EQ.0) THEN
29888 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29889 & XY=VINT(304+ISDE)
29890 ELSE
29891 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29892 & XY=VINT(308+ISDE)
29893 ENDIF
29894 Q2GA=VINT(306+ISDE)
29895 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29896 & Q2GA.GT.0D0) THEN
29897 REDUCE=0D0
29898 IF(MSTP(17).EQ.1) THEN
29899 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29900 ELSEIF(MSTP(17).EQ.2) THEN
29901 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29902 ELSEIF(MSTP(17).EQ.3) THEN
29903 PMVIRT=PMAS(PYCOMP(113),1)
29904 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29905 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29906 PMVIRT=PMAS(PYCOMP(113),1)
29907 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29908 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29909 PMVIRT=PMAS(PYCOMP(113),1)
29910 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29911 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29912 PMVSMN=4D0*PARP(15)**2
29913 PMVSMX=4D0*VINT(154)**2
29914 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29915 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29916 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29917 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29918 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29919 PMVIRT=PMAS(PYCOMP(113),1)
29920 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29921 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29922 PMVIRT=PMAS(PYCOMP(113),1)
29923 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29924 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29925 PMVSMN=4D0*PARP(15)**2
29926 PMVSMX=4D0*VINT(154)**2
29927 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29928 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29929 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29930 ENDIF
29931 BEAMAS=PYMASS(11)
29932 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29933 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29934 & (1D0-2D0*BEAMAS**2/Q2GA))
29935 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29936 ENDIF
29937 ELSE
29938 VINT(314+ISDE)=1D0
29939 ENDIF
29940 COMFAC=COMFAC*VINT(314+ISDE)
29941 170 CONTINUE
29942
29943C...Evaluate cross sections - done in separate routines by kind
29944C...of physics, to keep PYSIGH of sensible size.
29945 IF(MAP.EQ.1) THEN
29946C...Standard QCD (including photons).
29947 CALL PYSGQC(NCHN,SIGS)
29948 ELSEIF(MAP.EQ.2) THEN
29949C...Heavy flavours.
29950 CALL PYSGHF(NCHN,SIGS)
29951 ELSEIF(MAP.EQ.3) THEN
29952C...W/Z.
29953 CALL PYSGWZ(NCHN,SIGS)
29954 ELSEIF(MAP.EQ.4) THEN
29955C...Higgs (2 doublets; including longitudinal W/Z scattering).
29956 CALL PYSGHG(NCHN,SIGS)
29957 ELSEIF(MAP.EQ.5) THEN
29958C...SUSY.
29959 CALL PYSGSU(NCHN,SIGS)
29960 ELSEIF(MAP.EQ.6) THEN
29961C...Technicolor.
29962 CALL PYSGTC(NCHN,SIGS)
29963 ELSEIF(MAP.EQ.7) THEN
29964C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29965 CALL PYSGEX(NCHN,SIGS)
29966 ELSEIF(MAP.EQ.8) THEN
29967C... Universal Extra Dimensions
29968 CALL PYXUED(NCHN,SIGS)
29969 ENDIF
29970
29971C...Multiply with parton distributions
29972 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29973 DO 180 ICHN=1,NCHN
29974 IF(MINT(45).GE.2) THEN
29975 KFL1=ISIG(ICHN,1)
29976 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29977 ENDIF
29978 IF(MINT(46).GE.2) THEN
29979 KFL2=ISIG(ICHN,2)
29980 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29981 ENDIF
29982 SIGS=SIGS+SIGH(ICHN)
29983 180 CONTINUE
29984 ENDIF
29985
29986 RETURN
29987 END
29988
29989C*********************************************************************
29990
29991C...PYSGQC
29992C...Subprocess cross sections for QCD processes,
29993C...including photons.
29994C...Auxiliary to PYSIGH.
29995
29996 SUBROUTINE PYSGQC(NCHN,SIGS)
29997
29998C...Double precision and integer declarations
29999 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30000 IMPLICIT INTEGER(I-N)
30001 INTEGER PYK,PYCHGE,PYCOMP
30002C...Parameter statement to help give large particle numbers.
30003 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30004 &KEXCIT=4000000,KDIMEN=5000000)
30005C...Commonblocks
30006 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30007 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30008 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30009 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30010 COMMON/PYINT1/MINT(400),VINT(400)
30011 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30012 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30013 COMMON/PYINT4/MWID(500),WIDS(500,5)
30014 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30015 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30016 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30017 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30018 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30019 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30020 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30021C...Local arrays
30022 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30023
30024C...Differential cross section expressions.
30025
30026 IF(ISUB.LE.20) THEN
30027 IF(ISUB.EQ.10) THEN
30028C...f + f' -> f + f' (gamma/Z/W exchange)
30029 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30030 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30031 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30032 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30033 DO 110 I=MMIN1,MMAX1
30034 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30035 IA=IABS(I)
30036 DO 100 J=MMIN2,MMAX2
30037 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30038 JA=IABS(J)
30039C...Electroweak couplings
30040 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30041 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30042 VI=AI-4D0*EI*XWV
30043 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30044 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30045 VJ=AJ-4D0*EJ*XWV
30046 EPSIJ=ISIGN(1,I*J)
30047C...gamma/Z exchange, only gamma exchange, or only Z exchange
30048 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30049 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30050 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30051 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30052 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30053 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30054 ELSEIF(MSTP(21).EQ.2) THEN
30055 FACNCF=FACGGF*EI**2*EJ**2
30056 ELSE
30057 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30058 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30059 ENDIF
30060C...Extrafactor 2 for only one incoming neutrino spin state.
30061 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30062 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30063 NCHN=NCHN+1
30064 ISIG(NCHN,1)=I
30065 ISIG(NCHN,2)=J
30066 ISIG(NCHN,3)=1
30067 SIGH(NCHN)=FACNCF
30068 ENDIF
30069C...W exchange
30070 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30071 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30072 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30073 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30074 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30075 NCHN=NCHN+1
30076 ISIG(NCHN,1)=I
30077 ISIG(NCHN,2)=J
30078 ISIG(NCHN,3)=2
30079 SIGH(NCHN)=FACCCF
30080 ENDIF
30081 100 CONTINUE
30082 110 CONTINUE
30083
30084 ELSEIF(ISUB.EQ.11) THEN
30085C...f + f' -> f + f' (g exchange)
30086 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30087 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30088 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30089 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30090 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30091 DO 130 I=MMIN1,MMAX1
30092 IA=IABS(I)
30093 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30094 DO 120 J=MMIN2,MMAX2
30095 JA=IABS(J)
30096 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30097 NCHN=NCHN+1
30098 ISIG(NCHN,1)=I
30099 ISIG(NCHN,2)=J
30100 ISIG(NCHN,3)=1
30101 SIGH(NCHN)=FACQQ1
30102 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30103 IF(I.EQ.J) THEN
30104 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30105 NCHN=NCHN+1
30106 ISIG(NCHN,1)=I
30107 ISIG(NCHN,2)=J
30108 ISIG(NCHN,3)=2
30109 SIGH(NCHN)=0.5D0*FACQQ2
30110 ENDIF
30111 120 CONTINUE
30112 130 CONTINUE
30113
30114 ELSEIF(ISUB.EQ.12) THEN
30115C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30116 CALL PYWIDT(21,SH,WDTP,WDTE)
30117 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30118 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30119 DO 140 I=MMINA,MMAXA
30120 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30121 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30122 NCHN=NCHN+1
30123 ISIG(NCHN,1)=I
30124 ISIG(NCHN,2)=-I
30125 ISIG(NCHN,3)=1
30126 SIGH(NCHN)=FACQQB
30127 140 CONTINUE
30128
30129 ELSEIF(ISUB.EQ.13) THEN
30130C...f + fbar -> g + g (q + qbar -> g + g only)
30131 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30132 & UH2/SH2)
30133 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30134 & TH2/SH2)
30135 DO 150 I=MMINA,MMAXA
30136 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30137 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30138 NCHN=NCHN+1
30139 ISIG(NCHN,1)=I
30140 ISIG(NCHN,2)=-I
30141 ISIG(NCHN,3)=1
30142 SIGH(NCHN)=0.5D0*FACGG1
30143 NCHN=NCHN+1
30144 ISIG(NCHN,1)=I
30145 ISIG(NCHN,2)=-I
30146 ISIG(NCHN,3)=2
30147 SIGH(NCHN)=0.5D0*FACGG2
30148 150 CONTINUE
30149
30150 ELSEIF(ISUB.EQ.14) THEN
30151C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30152 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30153 DO 160 I=MMINA,MMAXA
30154 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30155 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30156 EI=KCHG(IABS(I),1)/3D0
30157 NCHN=NCHN+1
30158 ISIG(NCHN,1)=I
30159 ISIG(NCHN,2)=-I
30160 ISIG(NCHN,3)=1
30161 SIGH(NCHN)=FACGG*EI**2
30162 160 CONTINUE
30163
30164 ELSEIF(ISUB.EQ.18) THEN
30165C...f + fbar -> gamma + gamma
30166 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30167 DO 170 I=MMINA,MMAXA
30168 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30169 EI=KCHG(IABS(I),1)/3D0
30170 FCOI=1D0
30171 IF(IABS(I).LE.10) FCOI=FACA/3D0
30172 NCHN=NCHN+1
30173 ISIG(NCHN,1)=I
30174 ISIG(NCHN,2)=-I
30175 ISIG(NCHN,3)=1
30176 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30177 170 CONTINUE
30178 ENDIF
30179
30180 ELSEIF(ISUB.LE.40) THEN
30181 IF(ISUB.EQ.28) THEN
30182C...f + g -> f + g (q + g -> q + g only)
30183 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30184 & UH/SH)*FACA
30185 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30186 & SH/UH)
30187 DO 190 I=MMINA,MMAXA
30188 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30189 DO 180 ISDE=1,2
30190 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30191 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30192 NCHN=NCHN+1
30193 ISIG(NCHN,ISDE)=I
30194 ISIG(NCHN,3-ISDE)=21
30195 ISIG(NCHN,3)=1
30196 SIGH(NCHN)=FACQG1
30197 NCHN=NCHN+1
30198 ISIG(NCHN,ISDE)=I
30199 ISIG(NCHN,3-ISDE)=21
30200 ISIG(NCHN,3)=2
30201 SIGH(NCHN)=FACQG2
30202 180 CONTINUE
30203 190 CONTINUE
30204
30205 ELSEIF(ISUB.EQ.29) THEN
30206C...f + g -> f + gamma (q + g -> q + gamma only)
30207 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30208 DO 210 I=MMINA,MMAXA
30209 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30210 EI=KCHG(IABS(I),1)/3D0
30211 FACGQ=FGQ*EI**2
30212 DO 200 ISDE=1,2
30213 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30214 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30215 NCHN=NCHN+1
30216 ISIG(NCHN,ISDE)=I
30217 ISIG(NCHN,3-ISDE)=21
30218 ISIG(NCHN,3)=1
30219 SIGH(NCHN)=FACGQ
30220 200 CONTINUE
30221 210 CONTINUE
30222
30223 ELSEIF(ISUB.EQ.33) THEN
30224C...f + gamma -> f + g (q + gamma -> q + g only)
30225 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30226 DO 230 I=MMINA,MMAXA
30227 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30228 EI=KCHG(IABS(I),1)/3D0
30229 FACGQ=FGQ*EI**2
30230 DO 220 ISDE=1,2
30231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30232 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30233 NCHN=NCHN+1
30234 ISIG(NCHN,ISDE)=I
30235 ISIG(NCHN,3-ISDE)=22
30236 ISIG(NCHN,3)=1
30237 SIGH(NCHN)=FACGQ
30238 220 CONTINUE
30239 230 CONTINUE
30240
30241 ELSEIF(ISUB.EQ.34) THEN
30242C...f + gamma -> f + gamma
30243 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30244 DO 250 I=MMINA,MMAXA
30245 IF(I.EQ.0) GOTO 250
30246 EI=KCHG(IABS(I),1)/3D0
30247 FACGQ=FGQ*EI**4
30248 DO 240 ISDE=1,2
30249 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30250 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30251 NCHN=NCHN+1
30252 ISIG(NCHN,ISDE)=I
30253 ISIG(NCHN,3-ISDE)=22
30254 ISIG(NCHN,3)=1
30255 SIGH(NCHN)=FACGQ
30256 240 CONTINUE
30257 250 CONTINUE
30258 ENDIF
30259
30260 ELSEIF(ISUB.LE.80) THEN
30261 IF(ISUB.EQ.53) THEN
30262C...g + g -> f + fbar (g + g -> q + qbar only)
30263 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30264 IDC0=MDCY(21,2)-1
30265C...Begin by d, u, s flavours.
30266 FLAVWT=0D0
30267 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30268 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30269 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30270 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30271 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30272 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30273 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30274 & UH2/SH2)*FLAVWT*FACA
30275 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30276 & TH2/SH2)*FLAVWT*FACA
30277 NCHN=NCHN+1
30278 ISIG(NCHN,1)=21
30279 ISIG(NCHN,2)=21
30280 ISIG(NCHN,3)=1
30281 SIGH(NCHN)=FACQQ1
30282 NCHN=NCHN+1
30283 ISIG(NCHN,1)=21
30284 ISIG(NCHN,2)=21
30285 ISIG(NCHN,3)=2
30286 SIGH(NCHN)=FACQQ2
30287C...Next c and b flavours: modified that and uhat for fixed
30288C...cos(theta-hat).
30289 DO 260 IFL=4,5
30290 SQMAVG=PMAS(IFL,1)**2
30291 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30292 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30293 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30294 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30295 THUHQ=THQ*UHQ-SQMAVG*SH
30296 IF(MSTP(34).EQ.0) THEN
30297 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30298 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30299 ELSE
30300 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30301 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30302 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30303 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30304 ENDIF
30305 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30306 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30307 NCHN=NCHN+1
30308 ISIG(NCHN,1)=21
30309 ISIG(NCHN,2)=21
30310 ISIG(NCHN,3)=1+2*(IFL-3)
30311 SIGH(NCHN)=FACQQ1
30312 NCHN=NCHN+1
30313 ISIG(NCHN,1)=21
30314 ISIG(NCHN,2)=21
30315 ISIG(NCHN,3)=2+2*(IFL-3)
30316 SIGH(NCHN)=FACQQ2
30317 ENDIF
30318 260 CONTINUE
30319 270 CONTINUE
30320
30321 ELSEIF(ISUB.EQ.54) THEN
30322C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30323 CALL PYWIDT(21,SH,WDTP,WDTE)
30324 WDTESU=0D0
30325 DO 280 I=1,MIN(8,MDCY(21,3))
30326 EF=KCHG(I,1)/3D0
30327 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30328 & WDTE(I,4))
30329 280 CONTINUE
30330 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30331 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30332 NCHN=NCHN+1
30333 ISIG(NCHN,1)=21
30334 ISIG(NCHN,2)=22
30335 ISIG(NCHN,3)=1
30336 SIGH(NCHN)=FACQQ
30337 ENDIF
30338 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30339 NCHN=NCHN+1
30340 ISIG(NCHN,1)=22
30341 ISIG(NCHN,2)=21
30342 ISIG(NCHN,3)=1
30343 SIGH(NCHN)=FACQQ
30344 ENDIF
30345
30346 ELSEIF(ISUB.EQ.58) THEN
30347C...gamma + gamma -> f + fbar
30348 CALL PYWIDT(22,SH,WDTP,WDTE)
30349 WDTESU=0D0
30350 DO 290 I=1,MIN(12,MDCY(22,3))
30351 IF(I.LE.8) EF= KCHG(I,1)/3D0
30352 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30353 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30354 & WDTE(I,4))
30355 290 CONTINUE
30356 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30357 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30358 NCHN=NCHN+1
30359 ISIG(NCHN,1)=22
30360 ISIG(NCHN,2)=22
30361 ISIG(NCHN,3)=1
30362 SIGH(NCHN)=FACFF
30363 ENDIF
30364
30365 ELSEIF(ISUB.EQ.68) THEN
30366C...g + g -> g + g
30367 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30368 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30369 & TH2/SH2)*FACA
30370 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30371 & SH2/UH2)*FACA
30372 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30373 & UH2/TH2)
30374 NCHN=NCHN+1
30375 ISIG(NCHN,1)=21
30376 ISIG(NCHN,2)=21
30377 ISIG(NCHN,3)=1
30378 SIGH(NCHN)=0.5D0*FACGG1
30379 NCHN=NCHN+1
30380 ISIG(NCHN,1)=21
30381 ISIG(NCHN,2)=21
30382 ISIG(NCHN,3)=2
30383 SIGH(NCHN)=0.5D0*FACGG2
30384 NCHN=NCHN+1
30385 ISIG(NCHN,1)=21
30386 ISIG(NCHN,2)=21
30387 ISIG(NCHN,3)=3
30388 SIGH(NCHN)=0.5D0*FACGG3
30389 300 CONTINUE
30390
30391 ELSEIF(ISUB.EQ.80) THEN
30392C...q + gamma -> q' + pi+/-
30393 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30394 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30395 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30396 DELSH=UH*SQRT(ASSH*Q2FPSH)
30397 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30398 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30399 DELUH=SH*SQRT(ASUH*Q2FPUH)
30400 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30401 IF(I.EQ.0) GOTO 320
30402 EI=KCHG(IABS(I),1)/3D0
30403 EJ=SIGN(1D0-ABS(EI),EI)
30404 DO 310 ISDE=1,2
30405 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30406 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30407 NCHN=NCHN+1
30408 ISIG(NCHN,ISDE)=I
30409 ISIG(NCHN,3-ISDE)=22
30410 ISIG(NCHN,3)=1
30411 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30412 310 CONTINUE
30413 320 CONTINUE
30414 ENDIF
30415
30416 ELSEIF(ISUB.LE.100) THEN
30417 IF(ISUB.EQ.91) THEN
30418C...Elastic scattering
30419 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30420
30421 ELSEIF(ISUB.EQ.92) THEN
30422C...Single diffractive scattering (first side, i.e. XB)
30423 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30424
30425 ELSEIF(ISUB.EQ.93) THEN
30426C...Single diffractive scattering (second side, i.e. AX)
30427 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30428
30429 ELSEIF(ISUB.EQ.94) THEN
30430C...Double diffractive scattering
30431 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30432
30433 ELSEIF(ISUB.EQ.95) THEN
30434C...Low-pT scattering
30435 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30436
30437 ELSEIF(ISUB.EQ.96) THEN
30438C...Multiple interactions: sum of QCD processes
30439 CALL PYWIDT(21,SH,WDTP,WDTE)
30440
30441C...q + q' -> q + q'
30442 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30443 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30444 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30445 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30446 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30447 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30448 DO 340 I=-5,5
30449 IF(I.EQ.0) GOTO 340
30450 DO 330 J=-5,5
30451 IF(J.EQ.0) GOTO 330
30452 NCHN=NCHN+1
30453 ISIG(NCHN,1)=I
30454 ISIG(NCHN,2)=J
30455 ISIG(NCHN,3)=111
30456 SIGH(NCHN)=FACQQ1
30457 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30458 IF(I.EQ.J) THEN
30459 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30460 NCHN=NCHN+1
30461 ISIG(NCHN,1)=I
30462 ISIG(NCHN,2)=J
30463 ISIG(NCHN,3)=112
30464 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30465 ENDIF
30466 330 CONTINUE
30467 340 CONTINUE
30468
30469C...q + qbar -> q' + qbar' or g + g
30470 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30471 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30472 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30473 & UH2/SH2)
30474 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30475 & TH2/SH2)
30476 DO 350 I=-5,5
30477 IF(I.EQ.0) GOTO 350
30478 NCHN=NCHN+1
30479 ISIG(NCHN,1)=I
30480 ISIG(NCHN,2)=-I
30481 ISIG(NCHN,3)=121
30482 SIGH(NCHN)=FACQQB
30483 NCHN=NCHN+1
30484 ISIG(NCHN,1)=I
30485 ISIG(NCHN,2)=-I
30486 ISIG(NCHN,3)=131
30487 SIGH(NCHN)=0.5D0*FACGG1
30488 NCHN=NCHN+1
30489 ISIG(NCHN,1)=I
30490 ISIG(NCHN,2)=-I
30491 ISIG(NCHN,3)=132
30492 SIGH(NCHN)=0.5D0*FACGG2
30493 350 CONTINUE
30494
30495C...q + g -> q + g
30496 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30497 & UH/SH)*FACA
30498 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30499 & SH/UH)
30500 DO 370 I=-5,5
30501 IF(I.EQ.0) GOTO 370
30502 DO 360 ISDE=1,2
30503 NCHN=NCHN+1
30504 ISIG(NCHN,ISDE)=I
30505 ISIG(NCHN,3-ISDE)=21
30506 ISIG(NCHN,3)=281
30507 SIGH(NCHN)=FACQG1
30508 NCHN=NCHN+1
30509 ISIG(NCHN,ISDE)=I
30510 ISIG(NCHN,3-ISDE)=21
30511 ISIG(NCHN,3)=282
30512 SIGH(NCHN)=FACQG2
30513 360 CONTINUE
30514 370 CONTINUE
30515
30516C...g + g -> q + qbar (only d, u, s)
30517 IDC0=MDCY(21,2)-1
30518 FLAVWT=0D0
30519 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30520 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30521 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30522 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30523 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30524 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30525 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30526 & UH2/SH2)*FLAVWT*FACA
30527 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30528 & TH2/SH2)*FLAVWT*FACA
30529 NCHN=NCHN+1
30530 ISIG(NCHN,1)=21
30531 ISIG(NCHN,2)=21
30532 ISIG(NCHN,3)=531
30533 SIGH(NCHN)=FACQQ1
30534 NCHN=NCHN+1
30535 ISIG(NCHN,1)=21
30536 ISIG(NCHN,2)=21
30537 ISIG(NCHN,3)=532
30538 SIGH(NCHN)=FACQQ2
30539
30540C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30541C...cos(theta-hat)
30542 DO 380 IFL=4,5
30543 SQMAVG=PMAS(IFL,1)**2
30544 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30545 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30546 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30547 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30548 THUHQ=THQ*UHQ-SQMAVG*SH
30549 IF(MSTP(34).EQ.0) THEN
30550 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30551 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30552 ELSE
30553 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30554 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30555 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30556 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30557 ENDIF
30558 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30559 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30560 NCHN=NCHN+1
30561 ISIG(NCHN,1)=21
30562 ISIG(NCHN,2)=21
30563 ISIG(NCHN,3)=531+2*(IFL-3)
30564 SIGH(NCHN)=FACQQ1
30565 NCHN=NCHN+1
30566 ISIG(NCHN,1)=21
30567 ISIG(NCHN,2)=21
30568 ISIG(NCHN,3)=532+2*(IFL-3)
30569 SIGH(NCHN)=FACQQ2
30570 ENDIF
30571 380 CONTINUE
30572
30573C...g + g -> g + g
30574 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30575 & 2D0*TH/SH+TH2/SH2)*FACA
30576 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30577 & 2D0*SH/UH+SH2/UH2)*FACA
30578 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30579 & 2D0*UH/TH+UH2/TH2)
30580 NCHN=NCHN+1
30581 ISIG(NCHN,1)=21
30582 ISIG(NCHN,2)=21
30583 ISIG(NCHN,3)=681
30584 SIGH(NCHN)=0.5D0*FACGG1
30585 NCHN=NCHN+1
30586 ISIG(NCHN,1)=21
30587 ISIG(NCHN,2)=21
30588 ISIG(NCHN,3)=682
30589 SIGH(NCHN)=0.5D0*FACGG2
30590 NCHN=NCHN+1
30591 ISIG(NCHN,1)=21
30592 ISIG(NCHN,2)=21
30593 ISIG(NCHN,3)=683
30594 SIGH(NCHN)=0.5D0*FACGG3
30595
30596 ELSEIF(ISUB.EQ.99) THEN
30597C...f + gamma* -> f.
30598 IF(MINT(107).EQ.4) THEN
30599 Q2GA=VINT(307)
30600 P2GA=VINT(308)
30601 ISDE=2
30602 ELSE
30603 Q2GA=VINT(308)
30604 P2GA=VINT(307)
30605 ISDE=1
30606 ENDIF
30607 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30608 PM2RHO=PMAS(PYCOMP(113),1)**2
30609 IF(MSTP(19).EQ.0) THEN
30610 COMFAC=COMFAC/Q2GA
30611 ELSEIF(MSTP(19).EQ.1) THEN
30612 COMFAC=COMFAC/(Q2GA+PM2RHO)
30613 ELSEIF(MSTP(19).EQ.2) THEN
30614 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30615 ELSE
30616 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30617 W2GA=VINT(2)
30618 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30619 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30620 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30621 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30622 ELSE
30623 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30624 & Q2GA**0.57D0)
30625 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30626 ENDIF
30627 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30628 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30629 ENDIF
30630 DO 390 I=MMINA,MMAXA
30631 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30632 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30633 EI=KCHG(IABS(I),1)/3D0
30634 NCHN=NCHN+1
30635 ISIG(NCHN,ISDE)=I
30636 ISIG(NCHN,3-ISDE)=22
30637 ISIG(NCHN,3)=1
30638 SIGH(NCHN)=COMFAC*EI**2
30639 390 CONTINUE
30640 ENDIF
30641
30642 ELSE
30643 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30644C...g + g -> gamma + gamma or g + g -> g + gamma
30645 A0STUR=0D0
30646 A0STUI=0D0
30647 A0TSUR=0D0
30648 A0TSUI=0D0
30649 A0UTSR=0D0
30650 A0UTSI=0D0
30651 A1STUR=0D0
30652 A1STUI=0D0
30653 A2STUR=0D0
30654 A2STUI=0D0
30655 ALST=LOG(-SH/TH)
30656 ALSU=LOG(-SH/UH)
30657 ALTU=LOG(TH/UH)
30658 IMAX=2*MSTP(1)
30659 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30660 DO 400 I=1,IMAX
30661 EI=KCHG(IABS(I),1)/3D0
30662 EIWT=EI**2
30663 IF(ISUB.EQ.115) EIWT=EI
30664 SQMQ=PMAS(I,1)**2
30665 EPSS=4D0*SQMQ/SH
30666 EPST=4D0*SQMQ/TH
30667 EPSU=4D0*SQMQ/UH
30668 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30669 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30670 & PARU(1)**2)
30671 B0STUI=0D0
30672 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30673 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30674 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30675 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30676 B1STUR=-1D0
30677 B1STUI=0D0
30678 B2STUR=-1D0
30679 B2STUI=0D0
30680 ELSE
30681 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30682 CALL PYWAUX(1,EPST,W1TR,W1TI)
30683 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30684 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30685 CALL PYWAUX(2,EPST,W2TR,W2TI)
30686 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30687 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30688 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30689 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30690 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30691 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30692 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30693 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30694 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30695 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30696 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30697 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30698 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30699 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30700 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30701 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30702 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30703 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30704 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30705 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30706 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30707 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30708 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30709 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30710 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30711 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30712 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30713 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30714 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30715 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30716 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30717 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30718 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30719 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30720 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30721 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30722 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30723 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30724 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30725 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30726 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30727 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30728 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30729 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30730 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30731 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30732 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30733 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30734 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30735 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30736 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30737 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30738 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30739 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30740 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30741 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30742 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30743 ENDIF
30744 A0STUR=A0STUR+EIWT*B0STUR
30745 A0STUI=A0STUI+EIWT*B0STUI
30746 A0TSUR=A0TSUR+EIWT*B0TSUR
30747 A0TSUI=A0TSUI+EIWT*B0TSUI
30748 A0UTSR=A0UTSR+EIWT*B0UTSR
30749 A0UTSI=A0UTSI+EIWT*B0UTSI
30750 A1STUR=A1STUR+EIWT*B1STUR
30751 A1STUI=A1STUI+EIWT*B1STUI
30752 A2STUR=A2STUR+EIWT*B2STUR
30753 A2STUI=A2STUI+EIWT*B2STUI
30754 400 CONTINUE
30755 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30756 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30757 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30758 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30759 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30760 NCHN=NCHN+1
30761 ISIG(NCHN,1)=21
30762 ISIG(NCHN,2)=21
30763 ISIG(NCHN,3)=1
30764 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30765 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30766 410 CONTINUE
30767
30768 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30769C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30770 PH=0D0
30771 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30772 & PH=VINT(3)**2
30773 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30774 & PH=VINT(4)**2
30775 IF(ISUB.EQ.131) THEN
30776 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30777 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30778 ELSE
30779 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30780 ENDIF
30781 DO 430 I=MMINA,MMAXA
30782 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30783 EI=KCHG(IABS(I),1)/3D0
30784 FACGQ=FGQ*EI**2
30785 DO 420 ISDE=1,2
30786 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30787 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30788 NCHN=NCHN+1
30789 ISIG(NCHN,ISDE)=I
30790 ISIG(NCHN,3-ISDE)=22
30791 ISIG(NCHN,3)=1
30792 SIGH(NCHN)=FACGQ
30793 420 CONTINUE
30794 430 CONTINUE
30795
30796 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30797C...f + gamma*_(T,L) -> f + gamma
30798 PH=0D0
30799 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30800 & PH=VINT(3)**2
30801 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30802 & PH=VINT(4)**2
30803 IF(ISUB.EQ.133) THEN
30804 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30805 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30806 ELSE
30807 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30808 ENDIF
30809 DO 450 I=MMINA,MMAXA
30810 IF(I.EQ.0) GOTO 450
30811 EI=KCHG(IABS(I),1)/3D0
30812 FACGQ=FGQ*EI**4
30813 DO 440 ISDE=1,2
30814 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30815 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30816 NCHN=NCHN+1
30817 ISIG(NCHN,ISDE)=I
30818 ISIG(NCHN,3-ISDE)=22
30819 ISIG(NCHN,3)=1
30820 SIGH(NCHN)=FACGQ
30821 440 CONTINUE
30822 450 CONTINUE
30823
30824 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30825C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30826 PH=0D0
30827 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30828 & PH=VINT(3)**2
30829 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30830 & PH=VINT(4)**2
30831 CALL PYWIDT(21,SH,WDTP,WDTE)
30832 WDTESU=0D0
30833 DO 460 I=1,MIN(8,MDCY(21,3))
30834 EF=KCHG(I,1)/3D0
30835 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30836 & WDTE(I,4))
30837 460 CONTINUE
30838 IF(ISUB.EQ.135) THEN
30839 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30840 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30841 ELSE
30842 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30843 ENDIF
30844 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30845 NCHN=NCHN+1
30846 ISIG(NCHN,1)=21
30847 ISIG(NCHN,2)=22
30848 ISIG(NCHN,3)=1
30849 SIGH(NCHN)=FACQQ
30850 ENDIF
30851 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30852 NCHN=NCHN+1
30853 ISIG(NCHN,1)=22
30854 ISIG(NCHN,2)=21
30855 ISIG(NCHN,3)=1
30856 SIGH(NCHN)=FACQQ
30857 ENDIF
30858
30859 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30860C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30861 PH1=0D0
30862 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30863 PH2=0D0
30864 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30865 CALL PYWIDT(22,SH,WDTP,WDTE)
30866 WDTESU=0D0
30867 DO 470 I=1,MIN(12,MDCY(22,3))
30868 IF(I.LE.8) EF= KCHG(I,1)/3D0
30869 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30870 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30871 & WDTE(I,4))
30872 470 CONTINUE
30873 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30874 IF(ISUB.EQ.137) THEN
30875 FPARAM=-SH*(TH+UH)/DLAMB2
30876 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30877 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30878 & 2D0*PH1*PH2*FPARAM**2)
30879 ELSEIF(ISUB.EQ.138) THEN
30880 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30881 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30882 & 2D0*PH1**2*(TH-UH)**2)
30883 ELSEIF(ISUB.EQ.139) THEN
30884 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30885 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30886 & 2D0*PH2**2*(TH-UH)**2)
30887 ELSE
30888 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30889 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30890 ENDIF
30891 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30892 NCHN=NCHN+1
30893 ISIG(NCHN,1)=22
30894 ISIG(NCHN,2)=22
30895 ISIG(NCHN,3)=1
30896 SIGH(NCHN)=FACFF
30897 ENDIF
30898
30899 ENDIF
30900 ENDIF
30901
30902 RETURN
30903 END
30904
30905C*********************************************************************
30906
30907C...PYSGHF
30908C...Subprocess cross sections for heavy flavour production,
30909C...open and closed.
30910C...Auxiliary to PYSIGH.
30911
30912 SUBROUTINE PYSGHF(NCHN,SIGS)
30913
30914C...Double precision and integer declarations
30915 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30916 IMPLICIT INTEGER(I-N)
30917 INTEGER PYK,PYCHGE,PYCOMP
30918C...Parameter statement to help give large particle numbers.
30919 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30920 &KEXCIT=4000000,KDIMEN=5000000)
30921C...Commonblocks
30922 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30923 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30924 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30925 COMMON/PYINT1/MINT(400),VINT(400)
30926 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30927 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30928 COMMON/PYINT4/MWID(500),WIDS(500,5)
30929 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30930 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30931 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30932 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30933 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30934 &/PYINT4/,/PYSGCM/
30935C...Local arrays
30936 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30937
30938C...Determine where are charmonium/bottomonium wave function parameters.
30939 IONIUM=140
30940 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30941
30942C...Convert bottomonium process into equivalent charmonium ones.
30943 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30944
30945C...Differential cross section expressions.
30946
30947 IF(ISUB.LE.100) THEN
30948 IF(ISUB.EQ.81) THEN
30949C...q + qbar -> Q + Qbar
30950 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30951 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30952 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30953 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30954 & 2D0*SQMAVG/SH)
30955 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30956 WID2=1D0
30957 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30958 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30959 FACQQB=FACQQB*WID2
30960 DO 100 I=MMINA,MMAXA
30961 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30962 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30963 NCHN=NCHN+1
30964 ISIG(NCHN,1)=I
30965 ISIG(NCHN,2)=-I
30966 ISIG(NCHN,3)=1
30967 SIGH(NCHN)=FACQQB
30968 100 CONTINUE
30969
30970 ELSEIF(ISUB.EQ.82) THEN
30971C...g + g -> Q + Qbar
30972 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30973 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30974 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30975 THUHQ=THQ*UHQ-SQMAVG*SH
30976 IF(MSTP(34).EQ.0) THEN
30977 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30978 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30979 ELSE
30980 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30981 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30982 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30983 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30984 ENDIF
30985 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30986 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30987 IF(MSTP(35).GE.1) THEN
30988 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30989 FACQQ1=FACQQ1*FATRE
30990 FACQQ2=FACQQ2*FATRE
30991 ENDIF
30992 WID2=1D0
30993 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30994 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30995 FACQQ1=FACQQ1*WID2
30996 FACQQ2=FACQQ2*WID2
30997 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
30998 NCHN=NCHN+1
30999 ISIG(NCHN,1)=21
31000 ISIG(NCHN,2)=21
31001 ISIG(NCHN,3)=1
31002 SIGH(NCHN)=FACQQ1
31003 NCHN=NCHN+1
31004 ISIG(NCHN,1)=21
31005 ISIG(NCHN,2)=21
31006 ISIG(NCHN,3)=2
31007 SIGH(NCHN)=FACQQ2
31008 110 CONTINUE
31009
31010 ELSEIF(ISUB.EQ.83) THEN
31011C...f + q -> f' + Q
31012 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31013 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31014 DO 130 I=MMIN1,MMAX1
31015 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31016 DO 120 J=MMIN2,MMAX2
31017 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31018 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31019 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31020 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31021 & THEN
31022 NCHN=NCHN+1
31023 ISIG(NCHN,1)=I
31024 ISIG(NCHN,2)=J
31025 ISIG(NCHN,3)=1
31026 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31027 & (IABS(I)+1)/2)*VINT(180+J)
31028 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31029 & (MINT(55)+1)/2)*VINT(180+J)
31030 WID2=1D0
31031 IF(I.GT.0) THEN
31032 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31033 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31034 & WIDS(MINT(55),2)
31035 ELSE
31036 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31037 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31038 & WIDS(MINT(55),3)
31039 ENDIF
31040 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31041 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31042 ENDIF
31043 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31044 & THEN
31045 NCHN=NCHN+1
31046 ISIG(NCHN,1)=I
31047 ISIG(NCHN,2)=J
31048 ISIG(NCHN,3)=2
31049 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31050 & (IABS(J)+1)/2)*VINT(180+I)
31051 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31052 & (MINT(55)+1)/2)*VINT(180+I)
31053 WID2=1D0
31054 IF(J.GT.0) THEN
31055 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31056 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31057 & WIDS(MINT(55),2)
31058 ELSE
31059 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31060 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31061 & WIDS(MINT(55),3)
31062 ENDIF
31063 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31064 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31065 ENDIF
31066 120 CONTINUE
31067 130 CONTINUE
31068
31069 ELSEIF(ISUB.EQ.84) THEN
31070C...g + gamma -> Q + Qbar
31071 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31072 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31073 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31074 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31075 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31076 & (THQ*UHQ)
31077 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31078 WID2=1D0
31079 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31080 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31081 FACQQ=FACQQ*WID2
31082 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31083 NCHN=NCHN+1
31084 ISIG(NCHN,1)=21
31085 ISIG(NCHN,2)=22
31086 ISIG(NCHN,3)=1
31087 SIGH(NCHN)=FACQQ
31088 ENDIF
31089 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31090 NCHN=NCHN+1
31091 ISIG(NCHN,1)=22
31092 ISIG(NCHN,2)=21
31093 ISIG(NCHN,3)=1
31094 SIGH(NCHN)=FACQQ
31095 ENDIF
31096
31097 ELSEIF(ISUB.EQ.85) THEN
31098C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31099 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31100 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31101 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31102 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31103 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31104 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31105 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31106 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31107 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31108 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31109 WID2=1D0
31110 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31111 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31112 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31113 FACFF=FACFF*WID2
31114 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31115 NCHN=NCHN+1
31116 ISIG(NCHN,1)=22
31117 ISIG(NCHN,2)=22
31118 ISIG(NCHN,3)=1
31119 SIGH(NCHN)=FACFF
31120 ENDIF
31121
31122 ELSEIF(ISUB.EQ.86) THEN
31123C...g + g -> J/Psi + g
31124 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31125 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31126 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31127 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31128 NCHN=NCHN+1
31129 ISIG(NCHN,1)=21
31130 ISIG(NCHN,2)=21
31131 ISIG(NCHN,3)=1
31132 SIGH(NCHN)=FACQQG
31133 ENDIF
31134
31135 ELSEIF(ISUB.EQ.87) THEN
31136C...g + g -> chi_0c + g
31137 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31138 QGTW=(SH*TH*UH)/SH**3
31139 RGTW=SQM3/SH
31140 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31141 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31142 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31143 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31144 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31145 & (QGTW*(QGTW-RGTW*PGTW)**4)
31146 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31147 NCHN=NCHN+1
31148 ISIG(NCHN,1)=21
31149 ISIG(NCHN,2)=21
31150 ISIG(NCHN,3)=1
31151 SIGH(NCHN)=FACQQG
31152 ENDIF
31153
31154 ELSEIF(ISUB.EQ.88) THEN
31155C...g + g -> chi_1c + g
31156 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31157 QGTW=(SH*TH*UH)/SH**3
31158 RGTW=SQM3/SH
31159 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31160 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31161 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31162 & (QGTW-RGTW*PGTW)**4
31163 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31164 NCHN=NCHN+1
31165 ISIG(NCHN,1)=21
31166 ISIG(NCHN,2)=21
31167 ISIG(NCHN,3)=1
31168 SIGH(NCHN)=FACQQG
31169 ENDIF
31170
31171 ELSEIF(ISUB.EQ.89) THEN
31172C...g + g -> chi_2c + g
31173 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31174 QGTW=(SH*TH*UH)/SH**3
31175 RGTW=SQM3/SH
31176 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31177 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31178 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31179 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31180 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31181 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
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
31188 ENDIF
31189 ENDIF
31190
31191 ELSEIF(ISUB.LE.200) THEN
31192 IF(ISUB.EQ.104) THEN
31193C...g + g -> chi_c0.
31194 KC=PYCOMP(10441)
31195 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31196 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31197 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31198 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31199 NCHN=NCHN+1
31200 ISIG(NCHN,1)=21
31201 ISIG(NCHN,2)=21
31202 ISIG(NCHN,3)=1
31203 SIGH(NCHN)=FACBW
31204 ENDIF
31205
31206 ELSEIF(ISUB.EQ.105) THEN
31207C...g + g -> chi_c2.
31208 KC=PYCOMP(445)
31209 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31210 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31211 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31212 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31213 NCHN=NCHN+1
31214 ISIG(NCHN,1)=21
31215 ISIG(NCHN,2)=21
31216 ISIG(NCHN,3)=1
31217 SIGH(NCHN)=FACBW
31218 ENDIF
31219
31220 ELSEIF(ISUB.EQ.106) THEN
31221C...g + g -> J/Psi + gamma.
31222 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31223 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31224 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31225 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31226 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31227 NCHN=NCHN+1
31228 ISIG(NCHN,1)=21
31229 ISIG(NCHN,2)=21
31230 ISIG(NCHN,3)=1
31231 SIGH(NCHN)=FACQQG
31232 ENDIF
31233
31234 ELSEIF(ISUB.EQ.107) THEN
31235C...g + gamma -> J/Psi + g.
31236 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31237 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31238 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31239 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31240 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31241 NCHN=NCHN+1
31242 ISIG(NCHN,1)=21
31243 ISIG(NCHN,2)=22
31244 ISIG(NCHN,3)=1
31245 SIGH(NCHN)=FACQQG
31246 ENDIF
31247 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31248 NCHN=NCHN+1
31249 ISIG(NCHN,1)=22
31250 ISIG(NCHN,2)=21
31251 ISIG(NCHN,3)=1
31252 SIGH(NCHN)=FACQQG
31253 ENDIF
31254
31255 ELSEIF(ISUB.EQ.108) THEN
31256C...gamma + gamma -> J/Psi + gamma.
31257 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31258 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31259 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31260 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31261 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31262 NCHN=NCHN+1
31263 ISIG(NCHN,1)=22
31264 ISIG(NCHN,2)=22
31265 ISIG(NCHN,3)=1
31266 SIGH(NCHN)=FACQQG
31267 ENDIF
31268 ENDIF
31269
31270C...QUARKONIA+++
31271C...Additional code by Stefan Wolf
31272 ELSE
31273
31274C...Common code for quarkonium production.
31275 SHTH=SH+TH
31276 THUH=TH+UH
31277 UHSH=UH+SH
31278 SHTH2=SHTH**2
31279 THUH2=THUH**2
31280 UHSH2=UHSH**2
31281 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31282 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31283 SQMQQ=SQM3
31284 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31285 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31286 SQMQQ=SQM4
31287 ENDIF
31288 SQMQQR=SQRT(SQMQQ)
31289 IF(MSTP(145).EQ.1) THEN
31290 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31291 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31292 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31293 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31294 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31295 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31296 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31297 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31298 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31299 & ISUB.GE.437) THEN
31300 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31301 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31302 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31303 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31304 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31305 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31306 ENDIF
31307 AQ2=AQ**2
31308 BQ2=BQ**2
31309 SMQQ2=SQMQQ*VINT(2)
31310C...Polarisation frames
31311 IF(MSTP(146).EQ.1) THEN
31312C...Recoil frame
31313 POLH1=SQRT(AQ2-SMQQ2)
31314 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31315 AZ=-SQMQQR/POLH1
31316 BZ=0D0
31317 AX=AQ*BQ/(POLH1*POLH2)
31318 BX=-POLH1/POLH2
31319 ELSEIF(MSTP(146).EQ.2) THEN
31320C...Gottfried Jackson frame
31321 POLH1=AQ+BQ
31322 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31323 AZ=SQMQQR/POLH1
31324 BZ=AZ
31325 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31326 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31327 ELSEIF(MSTP(146).EQ.3) THEN
31328C...Target frame
31329 POLH1=AQ-BQ
31330 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31331 AZ=-SQMQQR/POLH1
31332 BZ=-AZ
31333 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31334 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31335 ELSEIF(MSTP(146).EQ.4) THEN
31336C...Collins Soper frame
31337 POLH1=AQ2-BQ2
31338 POLH2=SQRT(VINT(2)*POLH1)
31339 AZ=-BQ/POLH2
31340 BZ=AQ/POLH2
31341 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31342 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31343 ENDIF
31344C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31345 EL1K10=AZ*ATILK1+BZ*BTILK1
31346 EL1K20=AZ*ATILK2+BZ*BTILK2
31347 EL2K10=EL1K10
31348 EL2K20=EL1K20
31349 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31350 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31351 EL2K11=EL1K11
31352 EL2K21=EL1K21
31353 ENDIF
31354
31355 IF(ISUB.EQ.421) THEN
31356C...g + g -> QQ~[3S11] + g
31357 IF(MSTP(145).EQ.0) THEN
31358* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31359* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31360 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31361 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31362* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31363* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31364 ELSE
31365 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31366 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31367 BB=2D0*(SH2+TH2)
31368 CC=2D0*(SH2+UH2)
31369 DD=2D0*SH2
31370 IF(MSTP(147).EQ.0) THEN
31371 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31372 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31373 ELSEIF(MSTP(147).EQ.1) THEN
31374 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31375 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31376 ELSEIF(MSTP(147).EQ.3) THEN
31377 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31378 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31379 ELSEIF(MSTP(147).EQ.4) THEN
31380 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31381 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31382 ELSEIF(MSTP(147).EQ.5) THEN
31383 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31384 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31385 ELSEIF(MSTP(147).EQ.6) THEN
31386 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31387 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31388 ENDIF
31389 FACQQG=COMFAC*FF*FACQQG
31390 ENDIF
31391 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31392 NCHN=NCHN+1
31393 ISIG(NCHN,1)=21
31394 ISIG(NCHN,2)=21
31395 ISIG(NCHN,3)=1
31396 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31397 ENDIF
31398
31399 ELSEIF(ISUB.EQ.422) THEN
31400C...g + g -> QQ~[3S18] + g
31401 IF(MSTP(145).EQ.0) THEN
31402 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31403 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31404 & (SQMQQ*SQMQQR)*
31405 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31406 ELSE
31407 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31408 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31409 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31410 BB=2D0*(SH2+TH2)
31411 CC=2D0*(SH2+UH2)
31412 DD=2D0*SH2
31413 IF(MSTP(147).EQ.0) THEN
31414 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31415 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31416 ELSEIF(MSTP(147).EQ.1) THEN
31417 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31418 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31419 ELSEIF(MSTP(147).EQ.3) THEN
31420 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31421 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31422 ELSEIF(MSTP(147).EQ.4) THEN
31423 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31424 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31425 ELSEIF(MSTP(147).EQ.5) THEN
31426 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31427 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31428 ELSEIF(MSTP(147).EQ.6) THEN
31429 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31430 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31431 ENDIF
31432 FACQQG=COMFAC*FF*FACQQG
31433 ENDIF
31434C...Split total contribution into different colour flows just like
31435C...in g g -> g g (recalculate kinematics for massless partons).
31436 THP=-0.5D0*SH*(1D0-CTH)
31437 UHP=-0.5D0*SH*(1D0+CTH)
31438 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31439 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31440 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31441 FACGGS=FACGG1+FACGG2+FACGG3
31442 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31443 NCHN=NCHN+1
31444 ISIG(NCHN,1)=21
31445 ISIG(NCHN,2)=21
31446 ISIG(NCHN,3)=1
31447 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31448 NCHN=NCHN+1
31449 ISIG(NCHN,1)=21
31450 ISIG(NCHN,2)=21
31451 ISIG(NCHN,3)=2
31452 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31453 NCHN=NCHN+1
31454 ISIG(NCHN,1)=21
31455 ISIG(NCHN,2)=21
31456 ISIG(NCHN,3)=3
31457 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31458 ENDIF
31459
31460 ELSEIF(ISUB.EQ.423) THEN
31461C...g + g -> QQ~[1S08] + g
31462 IF(MSTP(145).EQ.0) THEN
31463* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31464* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31465* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31466* & (SHTH2*THUH2*UHSH2)
31467 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31468 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31469 & TH2/(SHTH2*THUH2))*
31470 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31471 ELSE
31472 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31473 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31474 & TH2/(SHTH2*THUH2))*
31475 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31476 IF(MSTP(147).EQ.0) THEN
31477 FACQQG=COMFAC*FA
31478 ELSEIF(MSTP(147).EQ.1) THEN
31479 FACQQG=COMFAC*2D0*FA
31480 ELSEIF(MSTP(147).EQ.3) THEN
31481 FACQQG=COMFAC*FA
31482 ELSEIF(MSTP(147).EQ.4) THEN
31483 FACQQG=COMFAC*FA
31484 ELSEIF(MSTP(147).EQ.5) THEN
31485 FACQQG=0D0
31486 ELSEIF(MSTP(147).EQ.6) THEN
31487 FACQQG=0D0
31488 ENDIF
31489 ENDIF
31490C...Split total contribution into different colour flows just like
31491C...in g g -> g g (recalculate kinematics for massless partons).
31492 THP=-0.5D0*SH*(1D0-CTH)
31493 UHP=-0.5D0*SH*(1D0+CTH)
31494 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31495 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31496 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31497 FACGGS=FACGG1+FACGG2+FACGG3
31498 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31499 NCHN=NCHN+1
31500 ISIG(NCHN,1)=21
31501 ISIG(NCHN,2)=21
31502 ISIG(NCHN,3)=1
31503 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31504 NCHN=NCHN+1
31505 ISIG(NCHN,1)=21
31506 ISIG(NCHN,2)=21
31507 ISIG(NCHN,3)=2
31508 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31509 NCHN=NCHN+1
31510 ISIG(NCHN,1)=21
31511 ISIG(NCHN,2)=21
31512 ISIG(NCHN,3)=3
31513 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31514 ENDIF
31515
31516 ELSEIF(ISUB.EQ.424) THEN
31517C...g + g -> QQ~[3PJ8] + g
31518 POLY=SH2+SH*TH+TH2
31519 IF(MSTP(145).EQ.0) THEN
31520 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31521 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31522 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31523 & +7D0*TH**6)
31524 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31525 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31526 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31527 & +35D0*TH**8)
31528 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31529 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31530 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31531 & +84D0*TH**8)
31532 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31533 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31534 & +451D0*SH*TH**5+126D0*TH**6)
31535 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31536 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31537 & +171D0*SH*TH**5+42D0*TH**6)
31538 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31539 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31540 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31541 & +99D0*SH*TH**3+35D0*TH**4)
31542 & +7D0*SQMQQ**8*SHTH*POLY)/
31543 & (SH*TH*UH*SQMQQR*SQMQQ*
31544 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31545 ELSE
31546 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31547 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31548 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31549 & -SQMQQ*SHTH2*POLY**2*
31550 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31551 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31552 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31553 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31554 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31555 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31556 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31557 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31558 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31559 & +145D0*SH*TH**5+34D0*TH**6)
31560 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31561 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31562 & +44D0*TH**6)
31563 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31564 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31565 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31566 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31567 & +3D0*SQMQQ**8*SHTH*POLY)
31568 BB=4D0*SHTH2*POLY**3
31569 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31570 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31571 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31572 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31573 & +84D0*SH*TH**9+20D0*TH**10)
31574 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31575 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31576 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31577 & +40D0*TH**8)
31578 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31579 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31580 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31581 & +40D0*TH**8)
31582 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31583 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31584 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31585 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31586 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31587 & +4D0*TH**6)
31588 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31589 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31590 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31591 CC=4D0*TH2*POLY**3
31592 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31593 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31594 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31595 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31596 & +28D0*TH**9)
31597 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31598 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31599 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31600 & +394D0*SH*TH**9+84D0*TH**10)
31601 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31602 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31603 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31604 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31605 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31606 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31607 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31608 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31609 & +266D0*SH*TH**6+84D0*TH**7)
31610 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31611 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31612 & +28D0*TH**6)
31613 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31614 & +7D0*SH*TH**3+4*TH**4)
31615 & +SQMQQ**8*SH*(SH-TH)**2*TH
31616 DD=2D0*TH2*SHTH2*POLY**3
31617 & *(-SH2+2*SH*TH+2*TH2)
31618 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31619 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31620 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31621 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31622 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31623 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31624 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31625 & -210D0*SH*TH**8-60D0*TH**9)
31626 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31627 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31628 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31629 & -80D0*TH**8)
31630 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31631 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31632 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31633 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31634 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31635 & -30D0*SH*TH**6-24D0*TH**7)
31636 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31637 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31638 & -4D0*TH**6)
31639 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31640 IF(MSTP(147).EQ.0) THEN
31641 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31642 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31643 ELSEIF(MSTP(147).EQ.1) THEN
31644 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31645 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31646 ELSEIF(MSTP(147).EQ.3) THEN
31647 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31648 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31649 ELSEIF(MSTP(147).EQ.4) THEN
31650 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31651 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31652 ELSEIF(MSTP(147).EQ.5) THEN
31653 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31654 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31655 ELSEIF(MSTP(147).EQ.6) THEN
31656 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31657 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31658 ENDIF
31659 FACQQG=COMFAC*FF*FACQQG
31660 ENDIF
31661C...Split total contribution into different colour flows just like
31662C...in g g -> g g (recalculate kinematics for massless partons).
31663 THP=-0.5D0*SH*(1D0-CTH)
31664 UHP=-0.5D0*SH*(1D0+CTH)
31665 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31666 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31667 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31668 FACGGS=FACGG1+FACGG2+FACGG3
31669 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31670 NCHN=NCHN+1
31671 ISIG(NCHN,1)=21
31672 ISIG(NCHN,2)=21
31673 ISIG(NCHN,3)=1
31674 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31675 NCHN=NCHN+1
31676 ISIG(NCHN,1)=21
31677 ISIG(NCHN,2)=21
31678 ISIG(NCHN,3)=2
31679 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31680 NCHN=NCHN+1
31681 ISIG(NCHN,1)=21
31682 ISIG(NCHN,2)=21
31683 ISIG(NCHN,3)=3
31684 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31685 ENDIF
31686
31687 ELSEIF(ISUB.EQ.425) THEN
31688C...q + g -> q + QQ~[3S18]
31689 IF(MSTP(145).EQ.0) THEN
31690 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31691 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31692 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31693 ELSE
31694 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31695 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31696 AA=SHTH2+THUH2
31697 BB=4D0
31698 CC=8D0
31699 DD=4D0
31700 IF(MSTP(147).EQ.0) THEN
31701 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31702 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31703 ELSEIF(MSTP(147).EQ.1) THEN
31704 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31705 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31706 ELSEIF(MSTP(147).EQ.3) THEN
31707 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31708 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31709 ELSEIF(MSTP(147).EQ.4) THEN
31710 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31711 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31712 ELSEIF(MSTP(147).EQ.5) THEN
31713 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31714 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31715 ELSEIF(MSTP(147).EQ.6) THEN
31716 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31717 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31718 ENDIF
31719 FACQQG=COMFAC*FF*FACQQG
31720 ENDIF
31721C...Split total contribution into different colour flows just like
31722C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31723C...(recalculate kinematics for massless partons).
31724 THP=-0.5D0*SH*(1D0-CTH)
31725 UHP=-0.5D0*SH*(1D0+CTH)
31726 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31727 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31728 FACQGS=FACQG1+FACQG2
31729 DO 2442 I=MMINA,MMAXA
31730 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31731 DO 2441 ISDE=1,2
31732 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31733 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31734 NCHN=NCHN+1
31735 ISIG(NCHN,ISDE)=I
31736 ISIG(NCHN,3-ISDE)=21
31737 ISIG(NCHN,3)=1
31738 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31739 NCHN=NCHN+1
31740 ISIG(NCHN,ISDE)=I
31741 ISIG(NCHN,3-ISDE)=21
31742 ISIG(NCHN,3)=2
31743 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31744 2441 CONTINUE
31745 2442 CONTINUE
31746
31747 ELSEIF(ISUB.EQ.426) THEN
31748C...q + g -> q + QQ~[1S08]
31749 IF(MSTP(145).EQ.0) THEN
31750 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31751 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31752 ELSE
31753 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31754 IF(MSTP(147).EQ.0) THEN
31755 FACQQG=COMFAC*FA
31756 ELSEIF(MSTP(147).EQ.1) THEN
31757 FACQQG=COMFAC*2D0*FA
31758 ELSEIF(MSTP(147).EQ.3) THEN
31759 FACQQG=COMFAC*FA
31760 ELSEIF(MSTP(147).EQ.4) THEN
31761 FACQQG=COMFAC*FA
31762 ELSEIF(MSTP(147).EQ.5) THEN
31763 FACQQG=0D0
31764 ELSEIF(MSTP(147).EQ.6) THEN
31765 FACQQG=0D0
31766 ENDIF
31767 ENDIF
31768C...Split total contribution into different colour flows just like
31769C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31770C...(recalculate kinematics for massless partons).
31771 THP=-0.5D0*SH*(1D0-CTH)
31772 UHP=-0.5D0*SH*(1D0+CTH)
31773 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31774 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31775 FACQGS=FACQG1+FACQG2
31776 DO 2444 I=MMINA,MMAXA
31777 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31778 DO 2443 ISDE=1,2
31779 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31780 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31781 NCHN=NCHN+1
31782 ISIG(NCHN,ISDE)=I
31783 ISIG(NCHN,3-ISDE)=21
31784 ISIG(NCHN,3)=1
31785 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31786 NCHN=NCHN+1
31787 ISIG(NCHN,ISDE)=I
31788 ISIG(NCHN,3-ISDE)=21
31789 ISIG(NCHN,3)=2
31790 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31791 2443 CONTINUE
31792 2444 CONTINUE
31793
31794 ELSEIF(ISUB.EQ.427) THEN
31795C...q + g -> q + QQ~[3PJ8]
31796 IF(MSTP(145).EQ.0) THEN
31797 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31798 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31799 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31800 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31801 ELSE
31802 FF=10D0*PARU(1)*AS**3/
31803 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31804 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31805 BB=8D0*(SHTH2+TH*UH)
31806 CC=8D0*UHSH*(SHTH+THUH)
31807 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31808 IF(MSTP(147).EQ.0) THEN
31809 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31810 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31811 ELSEIF(MSTP(147).EQ.1) THEN
31812 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31813 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31814 ELSEIF(MSTP(147).EQ.3) THEN
31815 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31816 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31817 ELSEIF(MSTP(147).EQ.4) THEN
31818 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31819 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31820 ELSEIF(MSTP(147).EQ.5) THEN
31821 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31822 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31823 ELSEIF(MSTP(147).EQ.6) THEN
31824 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31825 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31826 ENDIF
31827 FACQQG=COMFAC*FF*FACQQG
31828 ENDIF
31829C...Split total contribution into different colour flows just like
31830C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31831C...(recalculate kinematics for massless partons).
31832 THP=-0.5D0*SH*(1D0-CTH)
31833 UHP=-0.5D0*SH*(1D0+CTH)
31834 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31835 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31836 FACQGS=FACQG1+FACQG2
31837 DO 2446 I=MMINA,MMAXA
31838 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31839 DO 2445 ISDE=1,2
31840 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31841 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31842 NCHN=NCHN+1
31843 ISIG(NCHN,ISDE)=I
31844 ISIG(NCHN,3-ISDE)=21
31845 ISIG(NCHN,3)=1
31846 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31847 NCHN=NCHN+1
31848 ISIG(NCHN,ISDE)=I
31849 ISIG(NCHN,3-ISDE)=21
31850 ISIG(NCHN,3)=2
31851 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31852 2445 CONTINUE
31853 2446 CONTINUE
31854
31855 ELSEIF(ISUB.EQ.428) THEN
31856C...q + q~ -> g + QQ~[3S18]
31857 IF(MSTP(145).EQ.0) THEN
31858 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31859 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31860 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31861 ELSE
31862 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31863 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31864 AA=SHTH2+UHSH2
31865 BB=4D0
31866 CC=4D0
31867 DD=0D0
31868 IF(MSTP(147).EQ.0) THEN
31869 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31870 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31871 ELSEIF(MSTP(147).EQ.1) THEN
31872 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31873 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31874 ELSEIF(MSTP(147).EQ.3) THEN
31875 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31876 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31877 ELSEIF(MSTP(147).EQ.4) THEN
31878 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31879 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31880 ELSEIF(MSTP(147).EQ.5) THEN
31881 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31882 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31883 ELSEIF(MSTP(147).EQ.6) THEN
31884 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31885 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31886 ENDIF
31887 FACQQG=COMFAC*FF*FACQQG
31888 ENDIF
31889C...Split total contribution into different colour flows just like
31890C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31891C...(recalculate kinematics for massless partons).
31892 THP=-0.5D0*SH*(1D0-CTH)
31893 UHP=-0.5D0*SH*(1D0+CTH)
31894 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31895 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31896 FACGGS=FACGG1+FACGG2
31897 DO 2447 I=MMINA,MMAXA
31898 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31899 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31900 NCHN=NCHN+1
31901 ISIG(NCHN,1)=I
31902 ISIG(NCHN,2)=-I
31903 ISIG(NCHN,3)=1
31904 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31905 NCHN=NCHN+1
31906 ISIG(NCHN,1)=I
31907 ISIG(NCHN,2)=-I
31908 ISIG(NCHN,3)=2
31909 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31910 2447 CONTINUE
31911
31912 ELSEIF(ISUB.EQ.429) THEN
31913C...q + q~ -> g + QQ~[1S08]
31914 IF(MSTP(145).EQ.0) THEN
31915 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31916 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31917 ELSE
31918 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31919 IF(MSTP(147).EQ.0) THEN
31920 FACQQG=COMFAC*FA
31921 ELSEIF(MSTP(147).EQ.1) THEN
31922 FACQQG=COMFAC*2D0*FA
31923 ELSEIF(MSTP(147).EQ.3) THEN
31924 FACQQG=COMFAC*FA
31925 ELSEIF(MSTP(147).EQ.4) THEN
31926 FACQQG=COMFAC*FA
31927 ELSEIF(MSTP(147).EQ.5) THEN
31928 FACQQG=0D0
31929 ELSEIF(MSTP(147).EQ.6) THEN
31930 FACQQG=0D0
31931 ENDIF
31932 ENDIF
31933C...Split total contribution into different colour flows just like
31934C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31935C...(recalculate kinematics for massless partons).
31936 THP=-0.5D0*SH*(1D0-CTH)
31937 UHP=-0.5D0*SH*(1D0+CTH)
31938 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31939 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31940 FACGGS=FACGG1+FACGG2
31941 DO 2448 I=MMINA,MMAXA
31942 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31943 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31944 NCHN=NCHN+1
31945 ISIG(NCHN,1)=I
31946 ISIG(NCHN,2)=-I
31947 ISIG(NCHN,3)=1
31948 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31949 NCHN=NCHN+1
31950 ISIG(NCHN,1)=I
31951 ISIG(NCHN,2)=-I
31952 ISIG(NCHN,3)=2
31953 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31954 2448 CONTINUE
31955
31956 ELSEIF(ISUB.EQ.430) THEN
31957C...q + q~ -> g + QQ~[3PJ8]
31958 IF(MSTP(145).EQ.0) THEN
31959 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31960 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31961 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31962 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31963 ELSE
31964 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31965 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31966 BB=8D0*(UHSH2+SH*TH)
31967 CC=8D0*(SHTH2+SH*UH)
31968 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31969 IF(MSTP(147).EQ.0) THEN
31970 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31971 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31972 ELSEIF(MSTP(147).EQ.1) THEN
31973 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31974 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31975 ELSEIF(MSTP(147).EQ.3) THEN
31976 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31977 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31978 ELSEIF(MSTP(147).EQ.4) THEN
31979 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31980 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31981 ELSEIF(MSTP(147).EQ.5) THEN
31982 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31983 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31984 ELSEIF(MSTP(147).EQ.6) THEN
31985 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31986 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31987 ENDIF
31988 FACQQG=COMFAC*FF*FACQQG
31989 ENDIF
31990C...Split total contribution into different colour flows just like
31991C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31992C...(recalculate kinematics for massless partons).
31993 THP=-0.5D0*SH*(1D0-CTH)
31994 UHP=-0.5D0*SH*(1D0+CTH)
31995 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31996 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31997 FACGGS=FACGG1+FACGG2
31998 DO 2449 I=MMINA,MMAXA
31999 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32000 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32001 NCHN=NCHN+1
32002 ISIG(NCHN,1)=I
32003 ISIG(NCHN,2)=-I
32004 ISIG(NCHN,3)=1
32005 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32006 NCHN=NCHN+1
32007 ISIG(NCHN,1)=I
32008 ISIG(NCHN,2)=-I
32009 ISIG(NCHN,3)=2
32010 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32011 2449 CONTINUE
32012
32013 ELSEIF(ISUB.EQ.431) THEN
32014C...g + g -> QQ~[3P01] + g
32015 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32016 QGTW=(SH*TH*UH)/SH**3
32017 RGTW=SQMQQ/SH
32018 IF(MSTP(145).EQ.0) THEN
32019 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32020 & (9D0*RGTW**2*PGTW**4*
32021 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32022 & -6D0*RGTW*PGTW**3*QGTW*
32023 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32024 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32025 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32026 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32027 ELSE
32028 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32029 & (9D0*RGTW**2*PGTW**4*
32030 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32031 & -6D0*RGTW*PGTW**3*QGTW*
32032 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32033 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32034 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32035 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32036 IF(MSTP(147).EQ.0) THEN
32037 FACQQG=COMFAC*FC1
32038 ELSEIF(MSTP(147).EQ.1) THEN
32039 FACQQG=COMFAC*2D0*FC1
32040 ELSEIF(MSTP(147).EQ.3) THEN
32041 FACQQG=COMFAC*FC1
32042 ELSEIF(MSTP(147).EQ.4) THEN
32043 FACQQG=COMFAC*FC1
32044 ELSEIF(MSTP(147).EQ.5) THEN
32045 FACQQG=0D0
32046 ELSEIF(MSTP(147).EQ.6) THEN
32047 FACQQG=0D0
32048 ENDIF
32049 ENDIF
32050 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32051 NCHN=NCHN+1
32052 ISIG(NCHN,1)=21
32053 ISIG(NCHN,2)=21
32054 ISIG(NCHN,3)=1
32055 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32056 ENDIF
32057
32058 ELSEIF(ISUB.EQ.432) THEN
32059C...g + g -> QQ~[3P11] + g
32060 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32061 QGTW=(SH*TH*UH)/SH**3
32062 RGTW=SQMQQ/SH
32063 IF(MSTP(145).EQ.0) THEN
32064 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32065 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32066 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32067 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32068 ELSE
32069 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32070 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32071 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32072 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32073 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32074 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32075 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32076 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32077 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32078 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32079 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32080 C4=-4D0*THUH*(TH-UH)**2*
32081 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32082 & -SH2*TH*UH*(TH2+UH2))
32083 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32084 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32085 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32086 IF(MSTP(147).EQ.0) THEN
32087 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32088 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32089 ELSEIF(MSTP(147).EQ.1) THEN
32090 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32091 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32092 ELSEIF(MSTP(147).EQ.3) THEN
32093 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32094 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32095 ELSEIF(MSTP(147).EQ.4) THEN
32096 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32097 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32098 ELSEIF(MSTP(147).EQ.5) THEN
32099 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32100 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32101 ELSEIF(MSTP(147).EQ.6) THEN
32102 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32103 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32104 ENDIF
32105 FACQQG=COMFAC*FF*FACQQG
32106 ENDIF
32107 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32108 NCHN=NCHN+1
32109 ISIG(NCHN,1)=21
32110 ISIG(NCHN,2)=21
32111 ISIG(NCHN,3)=1
32112 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32113 ENDIF
32114
32115 ELSEIF(ISUB.EQ.433) THEN
32116C...g + g -> QQ~[3P21] + g
32117 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32118 QGTW=(SH*TH*UH)/SH**3
32119 RGTW=SQMQQ/SH
32120 IF(MSTP(145).EQ.0) THEN
32121 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32122 & (12D0*RGTW**2*PGTW**4*
32123 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32124 & -3D0*RGTW*PGTW**3*QGTW*
32125 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32126 & +2D0*PGTW**2*QGTW**2*
32127 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32128 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32129 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32130 ELSE
32131 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32132 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32133 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32134 & *SH*SH2**7
32135 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32136 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32137 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32138 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32139 & +10D0*(SH2**2+TH2**2))
32140 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32141 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32142 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32143 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32144 & +4D0*SH*TH*UH2**4*SHTH2)
32145 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32146 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32147 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32148 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32149 & +10D0*(SH2**2+UH2**2))
32150 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32151 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32152 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32153 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32154 & +4D0*SH*UH*TH2**4*UHSH2)
32155 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32156 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32157 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32158 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32159 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32160 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32161 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32162 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32163 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32164 & +3D0*(TH2**3+UH2**3)))
32165 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32166 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32167 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32168 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32169 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32170 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32171 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32172 & 82D0*TH**3)
32173 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32174 & +45D0*TH**3)
32175 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32176 & 8D0*TH**3)
32177 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32178 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32179 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32180 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32181 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32182 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32183 & 82D0*UH**3)
32184 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32185 & +45D0*UH**3)
32186 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32187 & 8D0*UH**3)
32188 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32189 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32190 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32191 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32192 & +4D0*SH*TH2**2*UH2**2*THUH2
32193 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32194 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32195 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32196 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32197 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32198 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32199 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32200 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32201 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32202 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32203 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32204 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32205 & +2D0*(TH2**3+UH2**3))
32206 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32207 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32208 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32209 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32210 IF(MSTP(147).EQ.0) THEN
32211 FACQQG=1D0/3D0*(C1*3D0
32212 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32213 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32214 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32215 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32216 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32217 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32218 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32219 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32220 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32221 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32222 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32223 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32224 ELSEIF(MSTP(147).EQ.1) THEN
32225 FACQQG=C1*2D0
32226 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32227 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32228 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32229 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32230 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32231 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32232 & +EL1K10*EL2K20*EL1K11*EL2K11)
32233 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32234 & +EL1K10*EL2K20*EL1K21*EL2K21)
32235 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32236 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32237 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32238 & +EL1K20*EL2K20*EL1K11*EL2K11)
32239 ELSEIF(MSTP(147).EQ.2) THEN
32240 FACQQG=2D0*(C1
32241 & -C2*EL1K11*EL2K11
32242 & -C3*EL1K21*EL2K21
32243 & -C4*EL1K11*EL2K21
32244 & +C5*(EL1K11*EL2K11)**2
32245 & +C6*(EL1K21*EL2K21)**2
32246 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32247 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32248 & +(C9+C0)*(EL1K11*EL2K21)**2)
32249 ENDIF
32250 FACQQG=COMFAC*FF*FACQQG
32251 ENDIF
32252 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32253 NCHN=NCHN+1
32254 ISIG(NCHN,1)=21
32255 ISIG(NCHN,2)=21
32256 ISIG(NCHN,3)=1
32257 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32258 ENDIF
32259
32260 ELSEIF(ISUB.EQ.434) THEN
32261C...q + g -> q + QQ~[3P01]
32262 IF(MSTP(145).EQ.0) THEN
32263 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32264 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32265 ELSE
32266 FA=-PARU(1)*AS**3*(16D0/243D0)*
32267 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32268 IF(MSTP(147).EQ.0) THEN
32269 FACQQG=COMFAC*FA
32270 ELSEIF(MSTP(147).EQ.1) THEN
32271 FACQQG=COMFAC*2D0*FA
32272 ELSEIF(MSTP(147).EQ.3) THEN
32273 FACQQG=COMFAC*FA
32274 ELSEIF(MSTP(147).EQ.4) THEN
32275 FACQQG=COMFAC*FA
32276 ELSEIF(MSTP(147).EQ.5) THEN
32277 FACQQG=0D0
32278 ELSEIF(MSTP(147).EQ.6) THEN
32279 FACQQG=0D0
32280 ENDIF
32281 ENDIF
32282 DO 2452 I=MMINA,MMAXA
32283 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32284 DO 2451 ISDE=1,2
32285 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32286 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32287 NCHN=NCHN+1
32288 ISIG(NCHN,ISDE)=I
32289 ISIG(NCHN,3-ISDE)=21
32290 ISIG(NCHN,3)=1
32291 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32292 2451 CONTINUE
32293 2452 CONTINUE
32294
32295 ELSEIF(ISUB.EQ.435) THEN
32296C...q + g -> q + QQ~[3P11]
32297 IF(MSTP(145).EQ.0) THEN
32298 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32299 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32300 ELSE
32301 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32302 C1=SH*UH
32303 C2=2D0*SH
32304 C3=0D0
32305 C4=2D0*(SH-UH)
32306 IF(MSTP(147).EQ.0) THEN
32307 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32308 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32309 ELSEIF(MSTP(147).EQ.1) THEN
32310 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32311 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32312 ELSEIF(MSTP(147).EQ.3) THEN
32313 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32314 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32315 ELSEIF(MSTP(147).EQ.4) THEN
32316 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32317 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32318 ELSEIF(MSTP(147).EQ.5) THEN
32319 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32320 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32321 ELSEIF(MSTP(147).EQ.6) THEN
32322 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32323 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32324 ENDIF
32325 FACQQG=COMFAC*FF*FACQQG
32326 ENDIF
32327 DO 2454 I=MMINA,MMAXA
32328 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32329 DO 2453 ISDE=1,2
32330 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32331 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32332 NCHN=NCHN+1
32333 ISIG(NCHN,ISDE)=I
32334 ISIG(NCHN,3-ISDE)=21
32335 ISIG(NCHN,3)=1
32336 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32337 2453 CONTINUE
32338 2454 CONTINUE
32339
32340 ELSEIF(ISUB.EQ.436) THEN
32341C...q + g -> q + QQ~[3P21]
32342 IF(MSTP(145).EQ.0) THEN
32343 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32344 & ((6D0*SQMQQ**2+TH2)*UHSH2
32345 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32346 & (SQMQQR*TH*UHSH2**2)
32347 ELSE
32348 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32349 C1=TH*UHSH2
32350 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32351 C3=4D0*UHSH2
32352 C4=8D0*SH*UHSH
32353 C5=8D0*TH
32354 C6=0D0
32355 C7=16D0*TH
32356 C8=0D0
32357 C9=-16D0*UHSH
32358 C0=16D0*SQMQQ
32359 IF(MSTP(147).EQ.0) THEN
32360 FACQQG=1D0/3D0*(C1*3D0
32361 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32362 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32363 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32364 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32365 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32366 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32367 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32368 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32369 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32370 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32371 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32372 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32373 ELSEIF(MSTP(147).EQ.1) THEN
32374 FACQQG=C1*2D0
32375 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32376 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32377 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32378 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32379 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32380 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32381 & +EL1K10*EL2K20*EL1K11*EL2K11)
32382 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32383 & +EL1K10*EL2K20*EL1K21*EL2K21)
32384 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32385 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32386 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32387 & +EL1K20*EL2K20*EL1K11*EL2K11)
32388 ELSEIF(MSTP(147).EQ.2) THEN
32389 FACQQG=2D0*(C1
32390 & -C2*EL1K11*EL2K11
32391 & -C3*EL1K21*EL2K21
32392 & -C4*EL1K11*EL2K21
32393 & +C5*(EL1K11*EL2K11)**2
32394 & +C6*(EL1K21*EL2K21)**2
32395 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32396 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32397 & +(C9+C0)*(EL1K11*EL2K21)**2)
32398 ENDIF
32399 FACQQG=COMFAC*FF*FACQQG
32400 ENDIF
32401 DO 2456 I=MMINA,MMAXA
32402 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32403 DO 2455 ISDE=1,2
32404 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32405 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32406 NCHN=NCHN+1
32407 ISIG(NCHN,ISDE)=I
32408 ISIG(NCHN,3-ISDE)=21
32409 ISIG(NCHN,3)=1
32410 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32411 2455 CONTINUE
32412 2456 CONTINUE
32413
32414 ELSEIF(ISUB.EQ.437) THEN
32415C...q + q~ -> g + QQ~[3P01]
32416 IF(MSTP(145).EQ.0) THEN
32417 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32418 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32419 ELSE
32420 FA=PARU(1)*AS**3*(128D0/729D0)*
32421 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32422 IF(MSTP(147).EQ.0) THEN
32423 FACQQG=COMFAC*FA
32424 ELSEIF(MSTP(147).EQ.1) THEN
32425 FACQQG=COMFAC*2D0*FA
32426 ELSEIF(MSTP(147).EQ.3) THEN
32427 FACQQG=COMFAC*FA
32428 ELSEIF(MSTP(147).EQ.4) THEN
32429 FACQQG=COMFAC*FA
32430 ELSEIF(MSTP(147).EQ.5) THEN
32431 FACQQG=0D0
32432 ELSEIF(MSTP(147).EQ.6) THEN
32433 FACQQG=0D0
32434 ENDIF
32435 ENDIF
32436 DO 2457 I=MMINA,MMAXA
32437 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32438 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32439 NCHN=NCHN+1
32440 ISIG(NCHN,1)=I
32441 ISIG(NCHN,2)=-I
32442 ISIG(NCHN,3)=1
32443 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32444 2457 CONTINUE
32445
32446 ELSEIF(ISUB.EQ.438) THEN
32447C...q + q~ -> g + QQ~[3P11]
32448 IF(MSTP(145).EQ.0) THEN
32449 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32450 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32451 ELSE
32452 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32453 C1=TH*UH
32454 C2=2D0*UH
32455 C3=2D0*TH
32456 C4=2D0*THUH
32457 IF(MSTP(147).EQ.0) THEN
32458 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32459 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32460 ELSEIF(MSTP(147).EQ.1) THEN
32461 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32462 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32463 ELSEIF(MSTP(147).EQ.3) THEN
32464 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32465 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32466 ELSEIF(MSTP(147).EQ.4) THEN
32467 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32468 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32469 ELSEIF(MSTP(147).EQ.5) THEN
32470 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32471 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32472 ELSEIF(MSTP(147).EQ.6) THEN
32473 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32474 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32475 ENDIF
32476 FACQQG=COMFAC*FF*FACQQG
32477 ENDIF
32478 DO 2458 I=MMINA,MMAXA
32479 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32480 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32481 NCHN=NCHN+1
32482 ISIG(NCHN,1)=I
32483 ISIG(NCHN,2)=-I
32484 ISIG(NCHN,3)=1
32485 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32486 2458 CONTINUE
32487
32488 ELSEIF(ISUB.EQ.439) THEN
32489C...q + q~ -> g + QQ~[3P21]
32490 IF(MSTP(145).EQ.0) THEN
32491 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32492 & ((6D0*SQMQQ**2+SH2)*THUH2
32493 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32494 & (SQMQQR*SH*THUH2**2)
32495 ELSE
32496 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32497 C1=SH*THUH2
32498 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32499 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32500 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32501 C5=8D0*SH
32502 C6=C5
32503 C7=16D0*SH
32504 C8=C7
32505 C9=-16D0*THUH
32506 C0=16D0*SQMQQ
32507 IF(MSTP(147).EQ.0) THEN
32508 FACQQG=1D0/3D0*(C1*3D0
32509 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32510 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32511 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32512 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32513 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32514 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32515 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32516 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32517 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32518 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32519 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32520 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32521 ELSEIF(MSTP(147).EQ.1) THEN
32522 FACQQG=C1*2D0
32523 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32524 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32525 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32526 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32527 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32528 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32529 & +EL1K10*EL2K20*EL1K11*EL2K11)
32530 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32531 & +EL1K10*EL2K20*EL1K21*EL2K21)
32532 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32533 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32534 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32535 & +EL1K20*EL2K20*EL1K11*EL2K11)
32536 ELSEIF(MSTP(147).EQ.2) THEN
32537 FACQQG=2D0*(C1
32538 & -C2*EL1K11*EL2K11
32539 & -C3*EL1K21*EL2K21
32540 & -C4*EL1K11*EL2K21
32541 & +C5*(EL1K11*EL2K11)**2
32542 & +C6*(EL1K21*EL2K21)**2
32543 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32544 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32545 & +(C9+C0)*(EL1K11*EL2K21)**2)
32546 ENDIF
32547 FACQQG=COMFAC*FF*FACQQG
32548 ENDIF
32549 DO 2459 I=MMINA,MMAXA
32550 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32551 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32552 NCHN=NCHN+1
32553 ISIG(NCHN,1)=I
32554 ISIG(NCHN,2)=-I
32555 ISIG(NCHN,3)=1
32556 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32557 2459 CONTINUE
32558 ENDIF
32559C...QUARKONIA---
32560
32561 ENDIF
32562
32563 RETURN
32564 END
32565
32566C*********************************************************************
32567
32568C...PYSGWZ
32569C...Subprocess cross sections for W/Z processes,
32570C...except that longitudinal WW scattering is in Higgs sector.
32571C...Auxiliary to PYSIGH.
32572
32573 SUBROUTINE PYSGWZ(NCHN,SIGS)
32574
32575C...Double precision and integer declarations
32576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32577 IMPLICIT INTEGER(I-N)
32578 INTEGER PYK,PYCHGE,PYCOMP
32579C...Parameter statement to help give large particle numbers.
32580 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32581 &KEXCIT=4000000,KDIMEN=5000000)
32582C...Commonblocks
32583 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32584 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32585 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32586 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32587 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32588 COMMON/PYINT1/MINT(400),VINT(400)
32589 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32590 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32591 COMMON/PYINT4/MWID(500),WIDS(500,5)
32592 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32593 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32594 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32595 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32596 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32597 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32598 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32599C...Local arrays and complex numbers
32600 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32601 &HL4(3),HR4(3)
32602 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32603
32604C...Differential cross section expressions.
32605
32606 IF(ISUB.LE.20) THEN
32607 IF(ISUB.EQ.1) THEN
32608C...f + fbar -> gamma*/Z0
32609 MINT(61)=2
32610 CALL PYWIDT(23,SH,WDTP,WDTE)
32611 HS=SHR*WDTP(0)
32612 FACZ=4D0*COMFAC*3D0
32613 HP0=AEM/3D0*SH
32614 HP1=AEM/3D0*XWC*SH
32615 DO 100 I=MMINA,MMAXA
32616 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32617 EI=KCHG(IABS(I),1)/3D0
32618 AI=SIGN(1D0,EI)
32619 VI=AI-4D0*EI*XWV
32620 HI0=HP0
32621 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32622 HI1=HP1
32623 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32624 NCHN=NCHN+1
32625 ISIG(NCHN,1)=I
32626 ISIG(NCHN,2)=-I
32627 ISIG(NCHN,3)=1
32628 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32629 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32630 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32631 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32632 100 CONTINUE
32633
32634 ELSEIF(ISUB.EQ.2) THEN
32635C...f + fbar' -> W+/-
32636 CALL PYWIDT(24,SH,WDTP,WDTE)
32637 HS=SHR*WDTP(0)
32638 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32639 HP=AEM/(24D0*XW)*SH
32640 DO 120 I=MMIN1,MMAX1
32641 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32642 IA=IABS(I)
32643 DO 110 J=MMIN2,MMAX2
32644 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32645 JA=IABS(J)
32646 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32647 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32648 & GOTO 110
32649 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32650 HI=HP*2D0
32651 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32652 NCHN=NCHN+1
32653 ISIG(NCHN,1)=I
32654 ISIG(NCHN,2)=J
32655 ISIG(NCHN,3)=1
32656 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32657 SIGH(NCHN)=HI*FACBW*HF
32658 110 CONTINUE
32659 120 CONTINUE
32660
32661 ELSEIF(ISUB.EQ.15) THEN
32662C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32663 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32664C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32665 HFGG=0D0
32666 HFGZ=0D0
32667 HFZZ=0D0
32668 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32669 DO 130 I=1,MIN(16,MDCY(23,3))
32670 IDC=I+MDCY(23,2)-1
32671 IF(MDME(IDC,1).LT.0) GOTO 130
32672 IMDM=0
32673 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32674 & IMDM=1
32675 IF(I.LE.8) THEN
32676 EF=KCHG(I,1)/3D0
32677 AF=SIGN(1D0,EF+0.1D0)
32678 VF=AF-4D0*EF*XWV
32679 ELSEIF(I.LE.16) THEN
32680 EF=KCHG(I+2,1)/3D0
32681 AF=SIGN(1D0,EF+0.1D0)
32682 VF=AF-4D0*EF*XWV
32683 ENDIF
32684 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32685 IF(4D0*RM1.LT.1D0) THEN
32686 FCOF=1D0
32687 IF(I.LE.8) FCOF=3D0*RADC4
32688 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32689 IF(IMDM.EQ.1) THEN
32690 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32691 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32692 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32693 & AF**2*(1D0-4D0*RM1))*BE34
32694 ENDIF
32695 ENDIF
32696 130 CONTINUE
32697C...Propagators: as simulated in PYOFSH and as desired
32698 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32699 MINT15=MINT(15)
32700 MINT(15)=1
32701 MINT(61)=1
32702 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32703 MINT(15)=MINT15
32704 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32705 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32706 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32707 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32708C...Loop over flavours; consider full gamma/Z structure
32709 DO 140 I=MMINA,MMAXA
32710 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32711 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32712 EI=KCHG(IABS(I),1)/3D0
32713 AI=SIGN(1D0,EI)
32714 VI=AI-4D0*EI*XWV
32715 NCHN=NCHN+1
32716 ISIG(NCHN,1)=I
32717 ISIG(NCHN,2)=-I
32718 ISIG(NCHN,3)=1
32719 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32720 & (VI**2+AI**2)*HFZZ)/HBW4
32721 140 CONTINUE
32722
32723 ELSEIF(ISUB.EQ.16) THEN
32724C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32725 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32726C...Propagators: as simulated in PYOFSH and as desired
32727 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32728 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32729 GMMWC=SQRT(SQM4)*WDTP(0)
32730 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32731 FACWG=FACWG*HBW4C/HBW4
32732 DO 160 I=MMIN1,MMAX1
32733 IA=IABS(I)
32734 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32735 DO 150 J=MMIN2,MMAX2
32736 JA=IABS(J)
32737 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32738 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32739 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32740 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32741 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32742 NCHN=NCHN+1
32743 ISIG(NCHN,1)=I
32744 ISIG(NCHN,2)=J
32745 ISIG(NCHN,3)=1
32746 SIGH(NCHN)=FACWG*FCKM*WIDSC
32747 150 CONTINUE
32748 160 CONTINUE
32749
32750 ELSEIF(ISUB.EQ.19) THEN
32751C...f + fbar -> gamma + (gamma*/Z0)
32752 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32753C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32754 HFGG=0D0
32755 HFGZ=0D0
32756 HFZZ=0D0
32757 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32758 DO 170 I=1,MIN(16,MDCY(23,3))
32759 IDC=I+MDCY(23,2)-1
32760 IF(MDME(IDC,1).LT.0) GOTO 170
32761 IMDM=0
32762 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32763 & IMDM=1
32764 IF(I.LE.8) THEN
32765 EF=KCHG(I,1)/3D0
32766 AF=SIGN(1D0,EF+0.1D0)
32767 VF=AF-4D0*EF*XWV
32768 ELSEIF(I.LE.16) THEN
32769 EF=KCHG(I+2,1)/3D0
32770 AF=SIGN(1D0,EF+0.1D0)
32771 VF=AF-4D0*EF*XWV
32772 ENDIF
32773 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32774 IF(4D0*RM1.LT.1D0) THEN
32775 FCOF=1D0
32776 IF(I.LE.8) FCOF=3D0*RADC4
32777 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32778 IF(IMDM.EQ.1) THEN
32779 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32780 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32781 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32782 & AF**2*(1D0-4D0*RM1))*BE34
32783 ENDIF
32784 ENDIF
32785 170 CONTINUE
32786C...Propagators: as simulated in PYOFSH and as desired
32787 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32788 MINT15=MINT(15)
32789 MINT(15)=1
32790 MINT(61)=1
32791 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32792 MINT(15)=MINT15
32793 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32794 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32795 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32796 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32797C...Loop over flavours; consider full gamma/Z structure
32798 DO 180 I=MMINA,MMAXA
32799 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32800 EI=KCHG(IABS(I),1)/3D0
32801 AI=SIGN(1D0,EI)
32802 VI=AI-4D0*EI*XWV
32803 FCOI=1D0
32804 IF(IABS(I).LE.10) FCOI=FACA/3D0
32805 NCHN=NCHN+1
32806 ISIG(NCHN,1)=I
32807 ISIG(NCHN,2)=-I
32808 ISIG(NCHN,3)=1
32809 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32810 & (VI**2+AI**2)*HFZZ)/HBW4
32811 180 CONTINUE
32812
32813 ELSEIF(ISUB.EQ.20) THEN
32814C...f + fbar' -> gamma + W+/-
32815 FACGW=COMFAC*0.5D0*AEM**2/XW
32816C...Propagators: as simulated in PYOFSH and as desired
32817 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32818 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32819 GMMWC=SQRT(SQM4)*WDTP(0)
32820 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32821 FACGW=FACGW*HBW4C/HBW4
32822C...Anomalous couplings
32823 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32824 TERM2=0D0
32825 TERM3=0D0
32826 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32827 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32828 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32829 & (4D0*SQMW))/(TH+UH)**2
32830 ENDIF
32831 DO 200 I=MMIN1,MMAX1
32832 IA=IABS(I)
32833 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32834 DO 190 J=MMIN2,MMAX2
32835 JA=IABS(J)
32836 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32837 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32838 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32839 & GOTO 190
32840 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32841 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32842 IF(IA.LE.10) THEN
32843 FACWR=UH/(TH+UH)-1D0/3D0
32844 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32845 FCOI=FACA/3D0
32846 ELSE
32847 FACWR=-TH/(TH+UH)
32848 FCKM=1D0
32849 FCOI=1D0
32850 ENDIF
32851 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32852 NCHN=NCHN+1
32853 ISIG(NCHN,1)=I
32854 ISIG(NCHN,2)=J
32855 ISIG(NCHN,3)=1
32856 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32857 190 CONTINUE
32858 200 CONTINUE
32859 ENDIF
32860
32861 ELSEIF(ISUB.LE.40) THEN
32862 IF(ISUB.EQ.22) THEN
32863C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32864C...Kinematics dependence
32865 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32866 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32867C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32868 DO 220 I=1,6
32869 DO 210 J=1,3
32870 HGZ(I,J)=0D0
32871 210 CONTINUE
32872 220 CONTINUE
32873 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32874 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32875 DO 230 I=1,MIN(16,MDCY(23,3))
32876 IDC=I+MDCY(23,2)-1
32877 IF(MDME(IDC,1).LT.0) GOTO 230
32878 IMDM=0
32879 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32880 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32881 IF(I.LE.8) THEN
32882 EF=KCHG(I,1)/3D0
32883 AF=SIGN(1D0,EF+0.1D0)
32884 VF=AF-4D0*EF*XWV
32885 ELSEIF(I.LE.16) THEN
32886 EF=KCHG(I+2,1)/3D0
32887 AF=SIGN(1D0,EF+0.1D0)
32888 VF=AF-4D0*EF*XWV
32889 ENDIF
32890 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32891 IF(4D0*RM1.LT.1D0) THEN
32892 FCOF=1D0
32893 IF(I.LE.8) FCOF=3D0*RADC3
32894 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32895 IF(IMDM.GE.1) THEN
32896 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32897 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32898 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32899 & AF**2*(1D0-4D0*RM1))*BE34
32900 ENDIF
32901 ENDIF
32902 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32903 IF(4D0*RM1.LT.1D0) THEN
32904 FCOF=1D0
32905 IF(I.LE.8) FCOF=3D0*RADC4
32906 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32907 IF(IMDM.GE.1) THEN
32908 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32909 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32910 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32911 & AF**2*(1D0-4D0*RM1))*BE34
32912 ENDIF
32913 ENDIF
32914 230 CONTINUE
32915C...Propagators: as simulated in PYOFSH and as desired
32916 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32917 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32918 MINT15=MINT(15)
32919 MINT(15)=1
32920 MINT(61)=1
32921 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32922 MINT(15)=MINT15
32923 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32924 DO 240 J=1,3
32925 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32926 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32927 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32928 240 CONTINUE
32929 MINT15=MINT(15)
32930 MINT(15)=1
32931 MINT(61)=1
32932 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32933 MINT(15)=MINT15
32934 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32935 DO 250 J=1,3
32936 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32937 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32938 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32939 250 CONTINUE
32940C...Loop over flavours; separate left- and right-handed couplings
32941 DO 270 I=MMINA,MMAXA
32942 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32943 EI=KCHG(IABS(I),1)/3D0
32944 AI=SIGN(1D0,EI)
32945 VI=AI-4D0*EI*XWV
32946 VALI=VI-AI
32947 VARI=VI+AI
32948 FCOI=1D0
32949 IF(IABS(I).LE.10) FCOI=FACA/3D0
32950 DO 260 J=1,3
32951 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32952 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32953 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32954 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32955 260 CONTINUE
32956 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32957 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32958 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32959 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32960 NCHN=NCHN+1
32961 ISIG(NCHN,1)=I
32962 ISIG(NCHN,2)=-I
32963 ISIG(NCHN,3)=1
32964 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32965 270 CONTINUE
32966
32967 ELSEIF(ISUB.EQ.23) THEN
32968C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32969 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32970 FACZW=FACZW*WIDS(23,2)
32971 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32972 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32973 DO 290 I=MMIN1,MMAX1
32974 IA=IABS(I)
32975 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32976 DO 280 J=MMIN2,MMAX2
32977 JA=IABS(J)
32978 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32979 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32980 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32981 & GOTO 280
32982 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32983 EI=KCHG(IA,1)/3D0
32984 AI=SIGN(1D0,EI+0.1D0)
32985 VI=AI-4D0*EI*XWV
32986 EJ=KCHG(JA,1)/3D0
32987 AJ=SIGN(1D0,EJ+0.1D0)
32988 VJ=AJ-4D0*EJ*XWV
32989 IF(VI+AI.GT.0) THEN
32990 VISAV=VI
32991 AISAV=AI
32992 VI=VJ
32993 AI=AJ
32994 VJ=VISAV
32995 AJ=AISAV
32996 ENDIF
32997 FCKM=1D0
32998 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
32999 FCOI=1D0
33000 IF(IA.LE.10) FCOI=FACA/3D0
33001 NCHN=NCHN+1
33002 ISIG(NCHN,1)=I
33003 ISIG(NCHN,2)=J
33004 ISIG(NCHN,3)=1
33005 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33006 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33007 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33008 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33009 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33010 & WIDS(24,(5-KCHW)/2)
33011C***Protect against slightly negative cross sections. (Reason yet to be
33012C***sorted out. One possibility: addition of width to the W propagator.)
33013 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33014 280 CONTINUE
33015 290 CONTINUE
33016
33017 ELSEIF(ISUB.EQ.25) THEN
33018C...f + fbar -> W+ + W-
33019C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33020 GMMZC=GMMZ
33021 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33022 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33023 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33024 GMMW3=SQRT(SQM3)*WDTP(0)
33025 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33026 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33027 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33028 GMMW4=SQRT(SQM4)*WDTP(0)
33029 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33030C...Kinematical functions
33031 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33032 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33033 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33034 GT=THUH34+4D0*THUH/TH2
33035 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33036 GU=THUH34+4D0*THUH/UH2
33037 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33038C...Common factors and couplings
33039 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33040 FACWW=FACWW*WIDS(24,1)
33041 CGG=AEM**2/2D0
33042 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33043 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33044 CNG=AEM**2/(4D0*XW)
33045 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33046 CNN=AEM**2/(16D0*XW**2)
33047C...Coulomb factor for W+W- pair
33048 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33049 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33050 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33051 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33052 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33053 & PMAS(24,2)**2)-COULE))
33054 ELSE
33055 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33056 ENDIF
33057 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33058 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33059 & PMAS(24,2)**2)+COULE))
33060 ELSE
33061 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33062 & ABS(COULE)))
33063 ENDIF
33064 IF(MSTP(40).EQ.1) THEN
33065 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33066 & MAX(1D-10,2D0*COULP*COULP1))
33067 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33068 ELSEIF(MSTP(40).EQ.2) THEN
33069 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33070 COULCP=DCMPLX(0D0,DBLE(COULP))
33071 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33072 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33073 & (4D0*COULCP)*LOG(COULCD)
33074 COULCS=DCMPLX(0D0,0D0)
33075 NSTP=100
33076 DO 300 ISTP=1,NSTP
33077 COULXX=(ISTP-0.5)/NSTP
33078 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33079 & (1D0+COULXX/COULCD))
33080 300 CONTINUE
33081 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33082 & (COULCS/NSTP)
33083 FACCOU=ABS(COULCR)**2
33084 ELSEIF(MSTP(40).EQ.3) THEN
33085 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33086 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33087 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33088 ENDIF
33089 ELSEIF(MSTP(40).EQ.4) THEN
33090 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33091 ELSE
33092 FACCOU=1D0
33093 ENDIF
33094 VINT(95)=FACCOU
33095 FACWW=FACWW*FACCOU
33096C...Loop over allowed flavours
33097 DO 310 I=MMINA,MMAXA
33098 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33099 EI=KCHG(IABS(I),1)/3D0
33100 AI=SIGN(1D0,EI+0.1D0)
33101 VI=AI-4D0*EI*XWV
33102 FCOI=1D0
33103 IF(IABS(I).LE.10) FCOI=FACA/3D0
33104 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33105 IF(AI.LT.0D0) THEN
33106 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33107 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33108 ELSE
33109 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33110 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33111 ENDIF
33112 ELSE
33113 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33114 BET=SQRT(1D0-4D0*XMW02/SH)
33115 GAT=1D0/SQRT(1D0-BET**2)
33116 STHE2=1D0-CTH**2
33117 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33118 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33119 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33120 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33121 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33122 & (1D0-2D0*BET*CTH+BET**2))
33123 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33124 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33125 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33126 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33127 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33128 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33129 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33130 DSIGWW=ATOT
33131 ENDIF
33132 NCHN=NCHN+1
33133 ISIG(NCHN,1)=I
33134 ISIG(NCHN,2)=-I
33135 ISIG(NCHN,3)=1
33136 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33137 310 CONTINUE
33138
33139 ELSEIF(ISUB.EQ.30) THEN
33140C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33141 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33142 & (-SH*UH)
33143C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33144 HFGG=0D0
33145 HFGZ=0D0
33146 HFZZ=0D0
33147 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33148 DO 320 I=1,MIN(16,MDCY(23,3))
33149 IDC=I+MDCY(23,2)-1
33150 IF(MDME(IDC,1).LT.0) GOTO 320
33151 IMDM=0
33152 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33153 & IMDM=1
33154 IF(I.LE.8) THEN
33155 EF=KCHG(I,1)/3D0
33156 AF=SIGN(1D0,EF+0.1D0)
33157 VF=AF-4D0*EF*XWV
33158 ELSEIF(I.LE.16) THEN
33159 EF=KCHG(I+2,1)/3D0
33160 AF=SIGN(1D0,EF+0.1D0)
33161 VF=AF-4D0*EF*XWV
33162 ENDIF
33163 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33164 IF(4D0*RM1.LT.1D0) THEN
33165 FCOF=1D0
33166 IF(I.LE.8) FCOF=3D0*RADC4
33167 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33168 IF(IMDM.EQ.1) THEN
33169 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33170 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33171 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33172 & AF**2*(1D0-4D0*RM1))*BE34
33173 ENDIF
33174 ENDIF
33175 320 CONTINUE
33176C...Propagators: as simulated in PYOFSH and as desired
33177 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33178 MINT15=MINT(15)
33179 MINT(15)=1
33180 MINT(61)=1
33181 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33182 MINT(15)=MINT15
33183 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33184 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33185 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33186 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33187C...Loop over flavours; consider full gamma/Z structure
33188 DO 340 I=MMINA,MMAXA
33189 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33190 EI=KCHG(IABS(I),1)/3D0
33191 AI=SIGN(1D0,EI)
33192 VI=AI-4D0*EI*XWV
33193 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33194 & (VI**2+AI**2)*HFZZ)/HBW4
33195 DO 330 ISDE=1,2
33196 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33197 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33198 NCHN=NCHN+1
33199 ISIG(NCHN,ISDE)=I
33200 ISIG(NCHN,3-ISDE)=21
33201 ISIG(NCHN,3)=1
33202 SIGH(NCHN)=FACZQ
33203 330 CONTINUE
33204 340 CONTINUE
33205
33206 ELSEIF(ISUB.EQ.31) THEN
33207C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33208 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33209 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33210C...Propagators: as simulated in PYOFSH and as desired
33211 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33212 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33213 GMMWC=SQRT(SQM4)*WDTP(0)
33214 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33215 FACWQ=FACWQ*HBW4C/HBW4
33216 DO 360 I=MMINA,MMAXA
33217 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33218 IA=IABS(I)
33219 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33220 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33221 DO 350 ISDE=1,2
33222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33223 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33224 NCHN=NCHN+1
33225 ISIG(NCHN,ISDE)=I
33226 ISIG(NCHN,3-ISDE)=21
33227 ISIG(NCHN,3)=1
33228 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33229 350 CONTINUE
33230 360 CONTINUE
33231
33232 ELSEIF(ISUB.EQ.35) THEN
33233C...f + gamma -> f + (gamma*/Z0)
33234 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33235 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33236 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33237 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33238 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33239 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33240 ELSE
33241 FZQN=SH2+UH2+2D0*SQM4*TH
33242 FZQDTM=-SH*UH
33243 ENDIF
33244 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33245C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33246 HFGG=0D0
33247 HFGZ=0D0
33248 HFZZ=0D0
33249 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33250 DO 370 I=1,MIN(16,MDCY(23,3))
33251 IDC=I+MDCY(23,2)-1
33252 IF(MDME(IDC,1).LT.0) GOTO 370
33253 IMDM=0
33254 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33255 & IMDM=1
33256 IF(I.LE.8) THEN
33257 EF=KCHG(I,1)/3D0
33258 AF=SIGN(1D0,EF+0.1D0)
33259 VF=AF-4D0*EF*XWV
33260 ELSEIF(I.LE.16) THEN
33261 EF=KCHG(I+2,1)/3D0
33262 AF=SIGN(1D0,EF+0.1D0)
33263 VF=AF-4D0*EF*XWV
33264 ENDIF
33265 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33266 IF(4D0*RM1.LT.1D0) THEN
33267 FCOF=1D0
33268 IF(I.LE.8) FCOF=3D0*RADC4
33269 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33270 IF(IMDM.EQ.1) THEN
33271 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33272 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33273 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33274 & AF**2*(1D0-4D0*RM1))*BE34
33275 ENDIF
33276 ENDIF
33277 370 CONTINUE
33278C...Propagators: as simulated in PYOFSH and as desired
33279 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33280 MINT15=MINT(15)
33281 MINT(15)=1
33282 MINT(61)=1
33283 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33284 MINT(15)=MINT15
33285 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33286 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33287 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33288 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33289C...Loop over flavours; consider full gamma/Z structure
33290 DO 390 I=MMINA,MMAXA
33291 IF(I.EQ.0) GOTO 390
33292 EI=KCHG(IABS(I),1)/3D0
33293 AI=SIGN(1D0,EI)
33294 VI=AI-4D0*EI*XWV
33295 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33296 & (VI**2+AI**2)*HFZZ)/HBW4
33297 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33298 DO 380 ISDE=1,2
33299 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33300 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33301 NCHN=NCHN+1
33302 ISIG(NCHN,ISDE)=I
33303 ISIG(NCHN,3-ISDE)=22
33304 ISIG(NCHN,3)=1
33305 SIGH(NCHN)=FACZQ*FZQN/FZQD
33306 380 CONTINUE
33307 390 CONTINUE
33308
33309 ELSEIF(ISUB.EQ.36) THEN
33310C...f + gamma -> f' + W+/-
33311 FWQ=COMFAC*AEM**2/(2D0*XW)*
33312 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33313C...Propagators: as simulated in PYOFSH and as desired
33314 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33315 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33316 GMMWC=SQRT(SQM4)*WDTP(0)
33317 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33318 FWQ=FWQ*HBW4C/HBW4
33319 DO 410 I=MMINA,MMAXA
33320 IF(I.EQ.0) GOTO 410
33321 IA=IABS(I)
33322 EIA=ABS(KCHG(IABS(I),1)/3D0)
33323 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33324 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33325 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33326 DO 400 ISDE=1,2
33327 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33328 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33329 NCHN=NCHN+1
33330 ISIG(NCHN,ISDE)=I
33331 ISIG(NCHN,3-ISDE)=22
33332 ISIG(NCHN,3)=1
33333 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33334 400 CONTINUE
33335 410 CONTINUE
33336 ENDIF
33337
33338 ELSEIF(ISUB.LE.100) THEN
33339 IF(ISUB.EQ.69) THEN
33340C...gamma + gamma -> W+ + W-
33341 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33342 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33343 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33344 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33345 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33346 NCHN=NCHN+1
33347 ISIG(NCHN,1)=22
33348 ISIG(NCHN,2)=22
33349 ISIG(NCHN,3)=1
33350 SIGH(NCHN)=FACWW
33351 420 CONTINUE
33352
33353 ELSEIF(ISUB.EQ.70) THEN
33354C...gamma + W+/- -> Z0 + W+/-
33355 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33356 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33357 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33358 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33359 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33360 DO 440 KCHW=1,-1,-2
33361 DO 430 ISDE=1,2
33362 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33363 NCHN=NCHN+1
33364 ISIG(NCHN,ISDE)=22
33365 ISIG(NCHN,3-ISDE)=24*KCHW
33366 ISIG(NCHN,3)=1
33367 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33368 430 CONTINUE
33369 440 CONTINUE
33370 ENDIF
33371 ENDIF
33372
33373 RETURN
33374 END
33375
33376C*********************************************************************
33377
33378C...PYSGHG
33379C...Subprocess cross sections for Higgs processes,
33380C...except Higgs pairs in PYSGSU, but including WW scattering.
33381C...Auxiliary to PYSIGH.
33382
33383 SUBROUTINE PYSGHG(NCHN,SIGS)
33384
33385C...Double precision and integer declarations
33386 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33387 IMPLICIT INTEGER(I-N)
33388 INTEGER PYK,PYCHGE,PYCOMP
33389C...Parameter statement to help give large particle numbers.
33390 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33391 &KEXCIT=4000000,KDIMEN=5000000)
33392C...Commonblocks
33393 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33394 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33395 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33396 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33397 COMMON/PYINT1/MINT(400),VINT(400)
33398 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33399 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33400 COMMON/PYINT4/MWID(500),WIDS(500,5)
33401 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33402 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33403 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33404 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33405 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33406 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33407 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33408 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33409C...Local arrays and complex variables
33410 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33411 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33412 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33413
33414C...Convert H or A process into equivalent h one
33415 IHIGG=1
33416 KFHIGG=25
33417 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33418 KFHIGG=KFPR(ISUB,1)
33419 END IF
33420 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33421 &ISUB.LE.190)) THEN
33422 IHIGG=2
33423 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33424 KFHIGG=33+IHIGG
33425 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33426 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33427 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33428 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33429 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33430 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33431 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33432 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33433 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33434 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33435 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33436 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33437 ENDIF
33438 SQMH=PMAS(KFHIGG,1)**2
33439 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33440
33441C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33442 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33443 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33444C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33445 IF(MSTP(46).LE.4) THEN
33446 HDTLH=LOG(PMAS(25,1)/PARP(44))
33447 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33448 HDTNR=-1D0/18D0+HDTLH/6D0
33449 ELSE
33450 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33451 HDTLQ=LOG(PARP(45)/PARP(44))
33452 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33453 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33454 ENDIF
33455
33456C...Calculate lowest and next-to-lowest order partial wave amplitudes
33457 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33458 A00L=DBLE(HDTV*SH)
33459 A20L=-0.5D0*A00L
33460 A11L=A00L/6D0
33461 HDTLS=LOG(SH/PARP(44)**2)
33462 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33463 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33464 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33465 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33466 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33467 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33468 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33469 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33470
33471C...Unitarize partial wave amplitudes with Pade or K-matrix method
33472 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33473 A00U=A00L/(1D0-A004/A00L)
33474 A20U=A20L/(1D0-A204/A20L)
33475 A11U=A11L/(1D0-A114/A11L)
33476 ELSE
33477 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33478 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33479 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33480 ENDIF
33481 ENDIF
33482
33483C...Differential cross section expressions.
33484
33485 IF(ISUB.LE.60) THEN
33486 IF(ISUB.EQ.3) THEN
33487C...f + fbar -> h0 (or H0, or A0)
33488 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33489 HS=SHR*WDTP(0)
33490 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33491 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33492 & FACBW=0D0
33493 HP=AEM/(8D0*XW)*SH/SQMW*SH
33494 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33495 DO 100 I=MMINA,MMAXA
33496 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33497 IA=IABS(I)
33498 RMQ=PYMRUN(IA,SH)**2/SH
33499 HI=HP*RMQ
33500 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33501 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33502 IKFI=1
33503 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33504 IF(IA.GT.10) IKFI=3
33505 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33506 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33507 HI=HI/(1D0+RMSS(41))**2
33508 IF(IHIGG.NE.3) THEN
33509 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33510 & PARU(151+10*IHIGG))**2
33511 ENDIF
33512 ENDIF
33513 ENDIF
33514 NCHN=NCHN+1
33515 ISIG(NCHN,1)=I
33516 ISIG(NCHN,2)=-I
33517 ISIG(NCHN,3)=1
33518 SIGH(NCHN)=HI*FACBW*HF
33519 100 CONTINUE
33520
33521 ELSEIF(ISUB.EQ.5) THEN
33522C...Z0 + Z0 -> h0
33523 CALL PYWIDT(25,SH,WDTP,WDTE)
33524 HS=SHR*WDTP(0)
33525 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33526 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33527 HP=AEM/(8D0*XW)*SH/SQMW*SH
33528 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33529 HI=HP/4D0
33530 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33531 DO 120 I=MMIN1,MMAX1
33532 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33533 DO 110 J=MMIN2,MMAX2
33534 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33535 EI=KCHG(IABS(I),1)/3D0
33536 AI=SIGN(1D0,EI)
33537 VI=AI-4D0*EI*XWV
33538 EJ=KCHG(IABS(J),1)/3D0
33539 AJ=SIGN(1D0,EJ)
33540 VJ=AJ-4D0*EJ*XWV
33541 NCHN=NCHN+1
33542 ISIG(NCHN,1)=I
33543 ISIG(NCHN,2)=J
33544 ISIG(NCHN,3)=1
33545 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33546 110 CONTINUE
33547 120 CONTINUE
33548
33549 ELSEIF(ISUB.EQ.8) THEN
33550C...W+ + W- -> h0
33551 CALL PYWIDT(25,SH,WDTP,WDTE)
33552 HS=SHR*WDTP(0)
33553 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33554 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33555 HP=AEM/(8D0*XW)*SH/SQMW*SH
33556 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33557 HI=HP/2D0
33558 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33559 DO 140 I=MMIN1,MMAX1
33560 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33561 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33562 DO 130 J=MMIN2,MMAX2
33563 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33564 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33565 IF(EI*EJ.GT.0D0) GOTO 130
33566 NCHN=NCHN+1
33567 ISIG(NCHN,1)=I
33568 ISIG(NCHN,2)=J
33569 ISIG(NCHN,3)=1
33570 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33571 130 CONTINUE
33572 140 CONTINUE
33573
33574 ELSEIF(ISUB.EQ.24) THEN
33575C...f + fbar -> Z0 + h0 (or H0, or A0)
33576C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33577 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33578 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33579 GMMZ3=SQRT(SQM3)*WDTP(0)
33580 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33581 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33582 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33583 GMMH4=SQRT(SQM4)*WDTP(0)
33584 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33585 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33586 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33587 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33588 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33589 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33590 & PARU(154+10*IHIGG)**2
33591 DO 150 I=MMINA,MMAXA
33592 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33593 EI=KCHG(IABS(I),1)/3D0
33594 AI=SIGN(1D0,EI)
33595 VI=AI-4D0*EI*XWV
33596 FCOI=1D0
33597 IF(IABS(I).LE.10) FCOI=FACA/3D0
33598 NCHN=NCHN+1
33599 ISIG(NCHN,1)=I
33600 ISIG(NCHN,2)=-I
33601 ISIG(NCHN,3)=1
33602 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33603 150 CONTINUE
33604
33605 ELSEIF(ISUB.EQ.26) THEN
33606C...f + fbar' -> W+/- + h0 (or H0, or A0)
33607C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33608 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33609 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33610 GMMW3=SQRT(SQM3)*WDTP(0)
33611 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33612 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33613 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33614 GMMH4=SQRT(SQM4)*WDTP(0)
33615 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33616 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33617 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33618 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33619 FACHW=FACHW*WIDS(KFHIGG,2)
33620 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33621 & PARU(155+10*IHIGG)**2
33622 DO 170 I=MMIN1,MMAX1
33623 IA=IABS(I)
33624 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33625 DO 160 J=MMIN2,MMAX2
33626 JA=IABS(J)
33627 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33628 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33629 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33630 & GOTO 160
33631 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33632 FCKM=1D0
33633 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33634 FCOI=1D0
33635 IF(IA.LE.10) FCOI=FACA/3D0
33636 NCHN=NCHN+1
33637 ISIG(NCHN,1)=I
33638 ISIG(NCHN,2)=J
33639 ISIG(NCHN,3)=1
33640 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33641 160 CONTINUE
33642 170 CONTINUE
33643
33644 ELSEIF(ISUB.EQ.32) THEN
33645C...f + g -> f + h0 (q + g -> q + h0 only)
33646 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33647C...H propagator: as simulated in PYOFSH and as desired
33648 SQMHC=PMAS(25,1)**2
33649 GMMHC=PMAS(25,1)*PMAS(25,2)
33650 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33651 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33652 GMMHCC=SQRT(SQM4)*WDTP(0)
33653 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33654 FHCQ=FHCQ*HBW4C/HBW4
33655 DO 190 I=MMINA,MMAXA
33656 IA=IABS(I)
33657 IF(IA.NE.5) GOTO 190
33658 SQML=PYMRUN(IA,SH)**2
33659 SQMQ=PMAS(IA,1)**2
33660 FACHCQ=FHCQ*SQML/SQMW*
33661 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33662 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33663 & (SQM4-SQMQ-SH)/SH)
33664 DO 180 ISDE=1,2
33665 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33666 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33667 NCHN=NCHN+1
33668 ISIG(NCHN,ISDE)=I
33669 ISIG(NCHN,3-ISDE)=21
33670 ISIG(NCHN,3)=1
33671 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33672 180 CONTINUE
33673 190 CONTINUE
33674 ENDIF
33675
33676 ELSEIF(ISUB.LE.80) THEN
33677 IF(ISUB.EQ.71) THEN
33678C...Z0 + Z0 -> Z0 + Z0
33679 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33680
33681 IF(MSTP(46).LE.2) THEN
33682C...Exact scattering ME:s for on-mass-shell gauge bosons
33683 BE2=1D0-4D0*SQMZ/SH
33684 TH=-0.5D0*SH*BE2*(1D0-CTH)
33685 UH=-0.5D0*SH*BE2*(1D0+CTH)
33686 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33687 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33688 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33689 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33690 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33691 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33692 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33693 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33694 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33695 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33696 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33697 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33698 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33699 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33700 & (ASHIM+ATHIM+AUHIM)**2)
33701 IF(MSTP(46).EQ.2) FACZZ=0D0
33702
33703 ELSE
33704C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33705 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33706 & ABS(A00U+2D0*A20U)**2
33707 ENDIF
33708 FACZZ=FACZZ*WIDS(23,1)
33709
33710 DO 210 I=MMIN1,MMAX1
33711 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33712 EI=KCHG(IABS(I),1)/3D0
33713 AI=SIGN(1D0,EI)
33714 VI=AI-4D0*EI*XWV
33715 AVI=AI**2+VI**2
33716 DO 200 J=MMIN2,MMAX2
33717 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33718 EJ=KCHG(IABS(J),1)/3D0
33719 AJ=SIGN(1D0,EJ)
33720 VJ=AJ-4D0*EJ*XWV
33721 AVJ=AJ**2+VJ**2
33722 NCHN=NCHN+1
33723 ISIG(NCHN,1)=I
33724 ISIG(NCHN,2)=J
33725 ISIG(NCHN,3)=1
33726 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33727 200 CONTINUE
33728 210 CONTINUE
33729 220 CONTINUE
33730
33731 ELSEIF(ISUB.EQ.72) THEN
33732C...Z0 + Z0 -> W+ + W-
33733 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33734
33735 IF(MSTP(46).LE.2) THEN
33736C...Exact scattering ME:s for on-mass-shell gauge bosons
33737 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33738 CTH2=CTH**2
33739 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33740 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33741 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33742 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33743 & (1D0-2D0*SQMZ/SH)
33744 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33745 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33746 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33747 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33748 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33749 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33750 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33751 ATWIM=0D0
33752 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33753 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33754 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33755 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33756 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33757 AUWIM=0D0
33758 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33759 A4IM=0D0
33760 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33761 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33762 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33763 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33764 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33765 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33766 & (ATWIM+AUWIM+A4IM)**2)
33767
33768 ELSE
33769C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33770 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33771 & ABS(A00U-A20U)**2
33772 ENDIF
33773 FACWW=FACWW*WIDS(24,1)
33774
33775 DO 240 I=MMIN1,MMAX1
33776 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33777 EI=KCHG(IABS(I),1)/3D0
33778 AI=SIGN(1D0,EI)
33779 VI=AI-4D0*EI*XWV
33780 AVI=AI**2+VI**2
33781 DO 230 J=MMIN2,MMAX2
33782 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33783 EJ=KCHG(IABS(J),1)/3D0
33784 AJ=SIGN(1D0,EJ)
33785 VJ=AJ-4D0*EJ*XWV
33786 AVJ=AJ**2+VJ**2
33787 NCHN=NCHN+1
33788 ISIG(NCHN,1)=I
33789 ISIG(NCHN,2)=J
33790 ISIG(NCHN,3)=1
33791 SIGH(NCHN)=FACWW*AVI*AVJ
33792 230 CONTINUE
33793 240 CONTINUE
33794 250 CONTINUE
33795
33796 ELSEIF(ISUB.EQ.73) THEN
33797C...Z0 + W+/- -> Z0 + W+/-
33798 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33799
33800 IF(MSTP(46).LE.2) THEN
33801C...Exact scattering ME:s for on-mass-shell gauge bosons
33802 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33803 EP1=1D0-(SQMZ-SQMW)/SH
33804 EP2=1D0+(SQMZ-SQMW)/SH
33805 TH=-0.5D0*SH*BE2*(1D0-CTH)
33806 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33807 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33808 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33809 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33810 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33811 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33812 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33813 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33814 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33815 ASWIM=0D0
33816 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33817 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33818 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33819 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33820 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33821 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33822 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33823 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33824 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33825 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33826 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33827 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33828 AUWIM=0D0
33829 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33830 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33831 A4IM=0D0
33832 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33833 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33834 IF(MSTP(46).LE.0) FACZW=0D0
33835 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33836 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33837 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33838 & (ASWIM+AUWIM+A4IM)**2)
33839
33840 ELSE
33841C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33842 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33843 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33844 ENDIF
33845 FACZW=FACZW*WIDS(23,2)
33846
33847 DO 270 I=MMIN1,MMAX1
33848 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33849 EI=KCHG(IABS(I),1)/3D0
33850 AI=SIGN(1D0,EI)
33851 VI=AI-4D0*EI*XWV
33852 AVI=AI**2+VI**2
33853 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33854 DO 260 J=MMIN2,MMAX2
33855 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33856 EJ=KCHG(IABS(J),1)/3D0
33857 AJ=SIGN(1D0,EJ)
33858 VJ=AI-4D0*EJ*XWV
33859 AVJ=AJ**2+VJ**2
33860 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33861 NCHN=NCHN+1
33862 ISIG(NCHN,1)=I
33863 ISIG(NCHN,2)=J
33864 ISIG(NCHN,3)=1
33865 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33866 NCHN=NCHN+1
33867 ISIG(NCHN,1)=I
33868 ISIG(NCHN,2)=J
33869 ISIG(NCHN,3)=2
33870 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33871 260 CONTINUE
33872 270 CONTINUE
33873 280 CONTINUE
33874
33875 ELSEIF(ISUB.EQ.75) THEN
33876C...W+ + W- -> gamma + gamma
33877
33878 ELSEIF(ISUB.EQ.76) THEN
33879C...W+ + W- -> Z0 + Z0
33880 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33881
33882 IF(MSTP(46).LE.2) THEN
33883C...Exact scattering ME:s for on-mass-shell gauge bosons
33884 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33885 CTH2=CTH**2
33886 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33887 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33888 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33889 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33890 & (1D0-2D0*SQMZ/SH)
33891 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33892 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33893 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33894 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33895 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33896 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33897 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33898 ATWIM=0D0
33899 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33900 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33901 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33902 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33903 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33904 AUWIM=0D0
33905 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33906 A4IM=0D0
33907 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33908 & (SH/SQMW)**2*SH2
33909 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33910 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33911 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33912 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33913 & (ATWIM+AUWIM+A4IM)**2)
33914
33915 ELSE
33916C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33917 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33918 & ABS(A00U-A20U)**2
33919 ENDIF
33920 FACZZ=FACZZ*WIDS(23,1)
33921
33922 DO 300 I=MMIN1,MMAX1
33923 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33924 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33925 DO 290 J=MMIN2,MMAX2
33926 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33927 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33928 IF(EI*EJ.GT.0D0) GOTO 290
33929 NCHN=NCHN+1
33930 ISIG(NCHN,1)=I
33931 ISIG(NCHN,2)=J
33932 ISIG(NCHN,3)=1
33933 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33934 290 CONTINUE
33935 300 CONTINUE
33936 310 CONTINUE
33937
33938 ELSEIF(ISUB.EQ.77) THEN
33939C...W+/- + W+/- -> W+/- + W+/-
33940 IF(SH.LE.4.01D0*SQMW) GOTO 340
33941
33942 IF(MSTP(46).LE.2) THEN
33943C...Exact scattering ME:s for on-mass-shell gauge bosons
33944 BE2=1D0-4D0*SQMW/SH
33945 BE4=BE2**2
33946 CTH2=CTH**2
33947 CTH3=CTH**3
33948 TH=-0.5D0*SH*BE2*(1D0-CTH)
33949 UH=-0.5D0*SH*BE2*(1D0+CTH)
33950 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33951 SHANG=(1D0+BE2)**2
33952 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33953 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33954 THANG=(BE2-CTH)**2
33955 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33956 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33957 UHANG=(BE2+CTH)**2
33958 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33959 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33960 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33961 ASGRE=XW*SGZANG
33962 ASGIM=0D0
33963 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33964 ASZIM=0D0
33965 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33966 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33967 ATGRE=0.5D0*XW*SH/TH*TGZANG
33968 ATGIM=0D0
33969 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33970 ATZIM=0D0
33971 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33972 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33973 AUGRE=0.5D0*XW*SH/UH*UGZANG
33974 AUGIM=0D0
33975 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33976 AUZIM=0D0
33977 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33978 A4AIM=0D0
33979 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33980 A4SIM=0D0
33981 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33982 & (SH/SQMW)**2*SH2
33983 IF(MSTP(46).LE.0) THEN
33984 AWWARE=ASHRE
33985 AWWAIM=ASHIM
33986 AWWSRE=0D0
33987 AWWSIM=0D0
33988 ELSEIF(MSTP(46).EQ.1) THEN
33989 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33990 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33991 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33992 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33993 ELSE
33994 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33995 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
33996 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
33997 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
33998 ENDIF
33999 AWWA2=AWWARE**2+AWWAIM**2
34000 AWWS2=AWWSRE**2+AWWSIM**2
34001
34002 ELSE
34003C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34004 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34005 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34006 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34007 ENDIF
34008
34009 DO 330 I=MMIN1,MMAX1
34010 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34011 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34012 DO 320 J=MMIN2,MMAX2
34013 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34014 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34015 IF(EI*EJ.LT.0D0) THEN
34016C...W+W-
34017 IF(MSTP(45).EQ.1) GOTO 320
34018 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34019 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34020 ELSE
34021C...W+W+/W-W-
34022 IF(MSTP(45).EQ.2) GOTO 320
34023 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34024 IF(MSTP(46).GE.3) FACWW=FWWS
34025 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34026 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34027 ENDIF
34028 NCHN=NCHN+1
34029 ISIG(NCHN,1)=I
34030 ISIG(NCHN,2)=J
34031 ISIG(NCHN,3)=1
34032 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34033 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34034 320 CONTINUE
34035 330 CONTINUE
34036 340 CONTINUE
34037 ENDIF
34038
34039 ELSEIF(ISUB.LE.120) THEN
34040 IF(ISUB.EQ.102) THEN
34041C...g + g -> h0 (or H0, or A0)
34042 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34043 HS=SHR*WDTP(0)
34044 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34045 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34046 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34047 & FACBW=0D0
34048C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34049 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34050 WDTP13=0D0
34051 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34052 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34053 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34054 345 CONTINUE
34055 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34056 & '(PYSGHG:) did not find Higgs -> g g channel')
34057 HI=SHR*WDTP13/32D0
34058 ELSE
34059 HI=SHR*WDTP(13)/32D0
34060 ENDIF
34061 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34062 NCHN=NCHN+1
34063 ISIG(NCHN,1)=21
34064 ISIG(NCHN,2)=21
34065 ISIG(NCHN,3)=1
34066 SIGH(NCHN)=HI*FACBW*HF
34067 350 CONTINUE
34068
34069 ELSEIF(ISUB.EQ.103) THEN
34070C...gamma + gamma -> h0 (or H0, or A0)
34071 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34072 HS=SHR*WDTP(0)
34073 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34074 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34075 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34076 & FACBW=0D0
34077C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34078 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34079 WDTP14=0D0
34080 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34081 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34082 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34083 355 CONTINUE
34084 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34085 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34086 HI=SHR*WDTP14*2D0
34087 ELSE
34088 HI=SHR*WDTP(14)*2D0
34089 ENDIF
34090 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34091 NCHN=NCHN+1
34092 ISIG(NCHN,1)=22
34093 ISIG(NCHN,2)=22
34094 ISIG(NCHN,3)=1
34095 SIGH(NCHN)=HI*FACBW*HF
34096 360 CONTINUE
34097
34098 ELSEIF(ISUB.EQ.110) THEN
34099C...f + fbar -> gamma + h0
34100 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34101 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34102 FACHG=FACHG*WIDS(KFHIGG,2)
34103C...Calculate loop contributions for intermediate gamma* and Z0
34104 CIGTOT=DCMPLX(0D0,0D0)
34105 CIZTOT=DCMPLX(0D0,0D0)
34106 JMAX=3*MSTP(1)+1
34107 DO 370 J=1,JMAX
34108 IF(J.LE.2*MSTP(1)) THEN
34109 FNC=1D0
34110 EJ=KCHG(J,1)/3D0
34111 AJ=SIGN(1D0,EJ+0.1D0)
34112 VJ=AJ-4D0*EJ*XWV
34113 BALP=SQM4/(2D0*PMAS(J,1))**2
34114 BBET=SH/(2D0*PMAS(J,1))**2
34115 ELSEIF(J.LE.3*MSTP(1)) THEN
34116 FNC=3D0
34117 JL=2*(J-2*MSTP(1))-1
34118 EJ=KCHG(10+JL,1)/3D0
34119 AJ=SIGN(1D0,EJ+0.1D0)
34120 VJ=AJ-4D0*EJ*XWV
34121 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34122 BBET=SH/(2D0*PMAS(10+JL,1))**2
34123 ELSE
34124 BALP=SQM4/(2D0*PMAS(24,1))**2
34125 BBET=SH/(2D0*PMAS(24,1))**2
34126 ENDIF
34127 BABI=1D0/(BALP-BBET)
34128 IF(BALP.LT.1D0) THEN
34129 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34130 F1ALP=F0ALP**2
34131 ELSE
34132 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34133 & -DBLE(0.5D0*PARU(1)))
34134 F1ALP=-F0ALP**2
34135 ENDIF
34136 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34137 IF(BBET.LT.1D0) THEN
34138 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34139 F1BET=F0BET**2
34140 ELSE
34141 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34142 & -DBLE(0.5D0*PARU(1)))
34143 F1BET=-F0BET**2
34144 ENDIF
34145 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34146 IF(J.LE.3*MSTP(1)) THEN
34147 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34148 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34149 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34150 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34151 ELSE
34152 TXW=XW/XW1
34153 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34154 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34155 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34156 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34157 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34158 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34159 & (F1BET-F1ALP))
34160 ENDIF
34161 370 CONTINUE
34162 CIGTOT=CIGTOT/DBLE(SH)
34163 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34164C...Loop over initial flavours
34165 DO 380 I=MMINA,MMAXA
34166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34167 EI=KCHG(IABS(I),1)/3D0
34168 AI=SIGN(1D0,EI)
34169 VI=AI-4D0*EI*XWV
34170 FCOI=1D0
34171 IF(IABS(I).LE.10) FCOI=FACA/3D0
34172 NCHN=NCHN+1
34173 ISIG(NCHN,1)=I
34174 ISIG(NCHN,2)=-I
34175 ISIG(NCHN,3)=1
34176 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34177 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34178 380 CONTINUE
34179
34180 ELSEIF(ISUB.EQ.111) THEN
34181C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34182 IF(MSTP(38).NE.0) THEN
34183C...Simple case: only do gg <-> h exactly.
34184 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34185C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34186 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34187 WDTP13=0D0
34188 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34189 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34190 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34191 385 CONTINUE
34192 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34193 & '(PYSGHG:) did not find Higgs -> g g channel')
34194 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34195 & (TH**2+UH**2)/(SH*SQM4)
34196 ELSE
34197 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34198 & (TH**2+UH**2)/(SH*SQM4)
34199 ENDIF
34200C...Propagators: as simulated in PYOFSH and as desired
34201 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34202 GMMHC=SQRT(SQM4)*WDTP(0)
34203 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34204 & ((SQM4-SQMH)**2+GMMHC**2)
34205 FACGH=FACGH*HBW4C/HBW4
34206 ELSE
34207C...Messy case: do full loop integrals
34208 A5STUR=0D0
34209 A5STUI=0D0
34210 DO 390 I=1,2*MSTP(1)
34211 SQMQ=PMAS(I,1)**2
34212 EPSS=4D0*SQMQ/SH
34213 EPSH=4D0*SQMQ/SQMH
34214 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34215 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34216 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34217 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34218 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34219 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34220 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34221 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34222 390 CONTINUE
34223 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34224 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34225 FACGH=FACGH*WIDS(25,2)
34226 ENDIF
34227 DO 400 I=MMINA,MMAXA
34228 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34229 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34230 NCHN=NCHN+1
34231 ISIG(NCHN,1)=I
34232 ISIG(NCHN,2)=-I
34233 ISIG(NCHN,3)=1
34234 SIGH(NCHN)=FACGH
34235 400 CONTINUE
34236
34237 ELSEIF(ISUB.EQ.112) THEN
34238C...f + g -> f + h0 (q + g -> q + h0 only)
34239 IF(MSTP(38).NE.0) THEN
34240C...Simple case: only do gg <-> h exactly.
34241 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34242C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34243 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34244 WDTP13=0D0
34245 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34246 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34247 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34248 405 CONTINUE
34249 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34250 & '(PYSGHG:) did not find Higgs -> g g channel')
34251 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34252 & (SH**2+UH**2)/(-TH*SQM4)
34253 ELSE
34254 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34255 & (SH**2+UH**2)/(-TH*SQM4)
34256 ENDIF
34257C...Propagators: as simulated in PYOFSH and as desired
34258 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34259 GMMHC=SQRT(SQM4)*WDTP(0)
34260 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34261 & ((SQM4-SQMH)**2+GMMHC**2)
34262 FACQH=FACQH*HBW4C/HBW4
34263 ELSE
34264C...Messy case: do full loop integrals
34265 A5TSUR=0D0
34266 A5TSUI=0D0
34267 DO 410 I=1,2*MSTP(1)
34268 SQMQ=PMAS(I,1)**2
34269 EPST=4D0*SQMQ/TH
34270 EPSH=4D0*SQMQ/SQMH
34271 CALL PYWAUX(1,EPST,W1TR,W1TI)
34272 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34273 CALL PYWAUX(2,EPST,W2TR,W2TI)
34274 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34275 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34276 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34277 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34278 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34279 410 CONTINUE
34280 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34281 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34282 FACQH=FACQH*WIDS(25,2)
34283 ENDIF
34284 DO 430 I=MMINA,MMAXA
34285 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34286 DO 420 ISDE=1,2
34287 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34288 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34289 NCHN=NCHN+1
34290 ISIG(NCHN,ISDE)=I
34291 ISIG(NCHN,3-ISDE)=21
34292 ISIG(NCHN,3)=1
34293 SIGH(NCHN)=FACQH
34294 420 CONTINUE
34295 430 CONTINUE
34296
34297 ELSEIF(ISUB.EQ.113) THEN
34298C...g + g -> g + h0
34299 IF(MSTP(38).NE.0) THEN
34300C...Simple case: only do gg <-> h exactly.
34301 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34302C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34303 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34304 WDTP13=0D0
34305 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34306 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34307 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34308 435 CONTINUE
34309 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34310 & '(PYSGHG:) did not find Higgs -> g g channel')
34311 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34312 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34313 ELSE
34314 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34315 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34316 ENDIF
34317C...Propagators: as simulated in PYOFSH and as desired
34318 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34319 GMMHC=SQRT(SQM4)*WDTP(0)
34320 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34321 & ((SQM4-SQMH)**2+GMMHC**2)
34322 FACGH=FACGH*HBW4C/HBW4
34323 ELSE
34324C...Messy case: do full loop integrals
34325 A2STUR=0D0
34326 A2STUI=0D0
34327 A2USTR=0D0
34328 A2USTI=0D0
34329 A2TUSR=0D0
34330 A2TUSI=0D0
34331 A4STUR=0D0
34332 A4STUI=0D0
34333 DO 440 I=1,2*MSTP(1)
34334 SQMQ=PMAS(I,1)**2
34335 EPSS=4D0*SQMQ/SH
34336 EPST=4D0*SQMQ/TH
34337 EPSU=4D0*SQMQ/UH
34338 EPSH=4D0*SQMQ/SQMH
34339 IF(EPSH.LT.1D-6) GOTO 440
34340 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34341 CALL PYWAUX(1,EPST,W1TR,W1TI)
34342 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34343 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34344 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34345 CALL PYWAUX(2,EPST,W2TR,W2TI)
34346 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34347 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34348 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34349 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34350 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34351 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34352 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34353 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34354 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34355 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34356 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34357 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34358 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34359 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34360 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34361 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34362 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34363 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34364 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34365 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34366 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34367 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34368 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34369 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34370 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34371 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34372 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34373 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34374 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34375 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34376 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34377 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34378 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34379 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34380 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34381 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34382 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34383 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34384 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34385 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34386 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34387 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34388 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34389 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34390 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34391 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34392 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34393 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34394 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34395 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34396 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34397 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34398 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34399 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34400 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34401 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34402 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34403 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34404 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34405 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34406 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34407 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34408 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34409 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34410 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34411 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34412 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34413 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34414 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34415 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34416 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34417 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34418 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34419 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34420 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34421 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34422 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34423 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34424 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34425 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34426 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34427 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34428 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34429 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34430 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34431 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34432 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34433 & (W2SR-W2HR+W3STUR))
34434 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34435 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34436 & (W2TR-W2HR+W3TUSR))
34437 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34438 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34439 & (W2UR-W2HR+W3USTR))
34440 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34441 A2STUR=A2STUR+B2STUR+B2SUTR
34442 A2STUI=A2STUI+B2STUI+B2SUTI
34443 A2USTR=A2USTR+B2USTR+B2UTSR
34444 A2USTI=A2USTI+B2USTI+B2UTSI
34445 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34446 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34447 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34448 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34449 440 CONTINUE
34450 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34451 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34452 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34453 FACGH=FACGH*WIDS(25,2)
34454 ENDIF
34455 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34456 NCHN=NCHN+1
34457 ISIG(NCHN,1)=21
34458 ISIG(NCHN,2)=21
34459 ISIG(NCHN,3)=1
34460 SIGH(NCHN)=FACGH
34461 450 CONTINUE
34462 ENDIF
34463
34464 ELSEIF(ISUB.LE.170) THEN
34465 IF(ISUB.EQ.121) THEN
34466C...g + g -> Q + Qbar + h0
34467 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34468 IA=KFPR(ISUBSV,2)
34469 PMF=PYMRUN(IA,SH)
34470 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34471 & (0.5D0*PMF/PMAS(24,1))**2
34472 WID2=1D0
34473 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34474 FACQQH=FACQQH*WID2
34475 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34476 IKFI=1
34477 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34478 IF(IA.GT.10) IKFI=3
34479 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34480 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34481 FACQQH=FACQQH/(1D0+RMSS(41))**2
34482 IF(IHIGG.NE.3) THEN
34483 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34484 & PARU(151+10*IHIGG))**2
34485 ENDIF
34486 ENDIF
34487 ENDIF
34488 CALL PYQQBH(WTQQBH)
34489 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34490 HS=SHR*WDTP(0)
34491 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34492 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34493 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34494 & FACBW=0D0
34495 NCHN=NCHN+1
34496 ISIG(NCHN,1)=21
34497 ISIG(NCHN,2)=21
34498 ISIG(NCHN,3)=1
34499 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34500 460 CONTINUE
34501
34502 ELSEIF(ISUB.EQ.122) THEN
34503C...q + qbar -> Q + Qbar + h0
34504 IA=KFPR(ISUBSV,2)
34505 PMF=PYMRUN(IA,SH)
34506 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34507 & (0.5D0*PMF/PMAS(24,1))**2
34508 WID2=1D0
34509 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34510 FACQQH=FACQQH*WID2
34511 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34512 IKFI=1
34513 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34514 IF(IA.GT.10) IKFI=3
34515 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34516 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34517 FACQQH=FACQQH/(1D0+RMSS(41))**2
34518 IF(IHIGG.NE.3) THEN
34519 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34520 & PARU(151+10*IHIGG))**2
34521 ENDIF
34522 ENDIF
34523 ENDIF
34524 CALL PYQQBH(WTQQBH)
34525 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34526 HS=SHR*WDTP(0)
34527 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34528 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34529 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34530 & FACBW=0D0
34531 DO 470 I=MMINA,MMAXA
34532 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34533 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34534 NCHN=NCHN+1
34535 ISIG(NCHN,1)=I
34536 ISIG(NCHN,2)=-I
34537 ISIG(NCHN,3)=1
34538 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34539 470 CONTINUE
34540
34541 ELSEIF(ISUB.EQ.123) THEN
34542C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34543C...inner process)
34544 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34545 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34546 & PARU(154+10*IHIGG)**2
34547 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34548 & (VINT(216)-VINT(209)**2))**2
34549 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34550 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34551 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34552 HS=SHR*WDTP(0)
34553 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34554 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34555 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34556 & FACBW=0D0
34557 DO 490 I=MMIN1,MMAX1
34558 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34559 IA=IABS(I)
34560 DO 480 J=MMIN2,MMAX2
34561 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34562 JA=IABS(J)
34563 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34564 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34565 VI=AI-4D0*EI*XWV
34566 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34567 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34568 VJ=AJ-4D0*EJ*XWV
34569 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34570 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34571 NCHN=NCHN+1
34572 ISIG(NCHN,1)=I
34573 ISIG(NCHN,2)=J
34574 ISIG(NCHN,3)=1
34575 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34576 480 CONTINUE
34577 490 CONTINUE
34578
34579 ELSEIF(ISUB.EQ.124) THEN
34580C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34581C...inner process)
34582 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34583 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34584 & PARU(155+10*IHIGG)**2
34585 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34586 & (VINT(216)-VINT(209)**2))**2
34587 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34588 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34589 HS=SHR*WDTP(0)
34590 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34591 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34592 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34593 & FACBW=0D0
34594 DO 510 I=MMIN1,MMAX1
34595 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34596 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34597 DO 500 J=MMIN2,MMAX2
34598 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34599 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34600 IF(EI*EJ.GT.0D0) GOTO 500
34601 FACLR=VINT(180+I)*VINT(180+J)
34602 NCHN=NCHN+1
34603 ISIG(NCHN,1)=I
34604 ISIG(NCHN,2)=J
34605 ISIG(NCHN,3)=1
34606 SIGH(NCHN)=FACLR*FACWW*FACBW
34607 500 CONTINUE
34608 510 CONTINUE
34609
34610 ELSEIF(ISUB.EQ.143) THEN
34611C...f + fbar' -> H+/-
34612 SQMHC=PMAS(37,1)**2
34613 CALL PYWIDT(37,SH,WDTP,WDTE)
34614 HS=SHR*WDTP(0)
34615 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34616 HP=AEM/(8D0*XW)*SH/SQMW*SH
34617 DO 530 I=MMIN1,MMAX1
34618 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34619 IA=IABS(I)
34620 IM=(MOD(IA,10)+1)/2
34621 DO 520 J=MMIN2,MMAX2
34622 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34623 JA=IABS(J)
34624 JM=(MOD(JA,10)+1)/2
34625 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34626 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34627 & GOTO 520
34628 IF(MOD(IA,2).EQ.0) THEN
34629 IU=IA
34630 IL=JA
34631 ELSE
34632 IU=JA
34633 IL=IA
34634 ENDIF
34635 RML=PYMRUN(IL,SH)**2/SH
34636 RMU=PYMRUN(IU,SH)**2/SH
34637 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34638 IF(IA.LE.10) HI=HI*FACA/3D0
34639 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34640 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34641 NCHN=NCHN+1
34642 ISIG(NCHN,1)=I
34643 ISIG(NCHN,2)=J
34644 ISIG(NCHN,3)=1
34645 SIGH(NCHN)=HI*FACBW*HF
34646 520 CONTINUE
34647 530 CONTINUE
34648
34649 ELSEIF(ISUB.EQ.161) THEN
34650C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34651C...(choice of only b and t to avoid kinematics problems)
34652 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34653C...H propagator: as simulated in PYOFSH and as desired
34654 SQMHC=PMAS(37,1)**2
34655 GMMHC=PMAS(37,1)*PMAS(37,2)
34656 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34657 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34658 GMMHCC=SQRT(SQM4)*WDTP(0)
34659 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34660 FHCQ=FHCQ*HBW4C/HBW4
34661 Q2RM=SH
34662 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34663 DO 550 I=MMINA,MMAXA
34664 IA=IABS(I)
34665 IF(IA.NE.5) GOTO 550
34666 SQML=PYMRUN(IA,Q2RM)**2
34667 IUA=IA+MOD(IA,2)
34668 SQMQ=PYMRUN(IUA,Q2RM)**2
34669 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34670 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34671 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34672 & (SQMHC-SQMQ-SH)/SH)
34673 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34674 DO 540 ISDE=1,2
34675 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34676 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34677 NCHN=NCHN+1
34678 ISIG(NCHN,ISDE)=I
34679 ISIG(NCHN,3-ISDE)=21
34680 ISIG(NCHN,3)=1
34681 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34682 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34683 540 CONTINUE
34684 550 CONTINUE
34685 ENDIF
34686
34687 ELSEIF(ISUB.LE.402) THEN
34688 IF(ISUB.EQ.401) THEN
34689C... g + g -> t + bbar + H-
34690 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34691 IA=KFPR(ISUBSV,2)
34692 CALL PYSTBH(WTTBH)
34693 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34694 HS=SHR*WDTP(0)
34695 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34696 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34697 & FACBW=0D0
34698 NCHN=NCHN+1
34699 ISIG(NCHN,1)=21
34700 ISIG(NCHN,2)=21
34701 ISIG(NCHN,3)=1
34702 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34703c Since we don't know yet if H+ or H-, assume H+
34704c when calculating suppression due to closed channels.
34705 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34706 IF(ABS(WIDS(37,2)-WIDS(37,3))
34707 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34708 & ABS(WIDS(6,2)-WIDS(6,3))
34709 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34710 WRITE(*,*)'Error: Process 401 cannot handle different'
34711 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34712 WRITE(*,*)'Execution stopped.'
34713 CALL PYSTOP(108)
34714 END IF
34715 560 CONTINUE
34716
34717 ELSEIF(ISUB.EQ.402) THEN
34718C... q + qbar -> t + bbar + H-
34719 IA=KFPR(ISUBSV,2)
34720 CALL PYSTBH(WTTBH)
34721 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34722 HS=SHR*WDTP(0)
34723 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34724 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34725 & FACBW=0D0
34726 DO 570 I=MMINA,MMAXA
34727 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34728 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34729 NCHN=NCHN+1
34730 ISIG(NCHN,1)=I
34731 ISIG(NCHN,2)=-I
34732 ISIG(NCHN,3)=1
34733 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34734c Since we don't know yet if H+ or H-, assume H+
34735c when calculating suppression due to closed channels.
34736 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34737 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34738 & .GE.1D-6.OR.
34739 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34740 & .GE.1D-6) THEN
34741 WRITE(*,*)'Error: Process 402 cannot handle different'
34742 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34743 WRITE(*,*)'Execution stopped.'
34744 CALL PYSTOP(108)
34745 END IF
34746 570 CONTINUE
34747 ENDIF
34748 ENDIF
34749
34750 RETURN
34751 END
34752
34753C*********************************************************************
34754
34755C...PYSGSU
34756C...Subprocess cross sections for SUSY processes,
34757C...including Higgs pair production.
34758C...Auxiliary to PYSIGH.
34759
34760 SUBROUTINE PYSGSU(NCHN,SIGS)
34761
34762C...Double precision and integer declarations
34763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34764 IMPLICIT INTEGER(I-N)
34765 INTEGER PYK,PYCHGE,PYCOMP
34766C...Parameter statement to help give large particle numbers.
34767 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34768 &KEXCIT=4000000,KDIMEN=5000000)
34769C...Commonblocks
34770 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34771 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34772 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34773 COMMON/PYINT1/MINT(400),VINT(400)
34774 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34775 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34776 COMMON/PYINT4/MWID(500),WIDS(500,5)
34777 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34778 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34779 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34780 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34781 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34782 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34783 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34784 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34785 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34786C...Local arrays and complex variables
34787 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34788 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34789 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34790 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34791
34792CMRENNA++
34793C...Z and W width, combinations of weak mixing angle
34794 ZWID=PMAS(23,2)
34795 WWID=PMAS(24,2)
34796 TANW=SQRT(XW/XW1)
34797 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34798
34799C...Convert almost equivalent SUSY processes into each other
34800C...Extract differences in flavours and couplings
34801
34802C...Sleptons and sneutrinos
34803 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34804 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34805 ISUB=201
34806 ILR=0
34807 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34808 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34809 ISUB=201
34810 ILR=1
34811 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34812 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34813 ISUB=203
34814 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34815 IF(ISUB.EQ.210) THEN
34816 RKF=2.0D0
34817 ELSEIF(ISUB.EQ.211) THEN
34818 RKF=SFMIX(15,1)**2
34819 ELSEIF(ISUB.EQ.212) THEN
34820 RKF=SFMIX(15,2)**2
34821 ENDIF
34822 ISUB=210
34823 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34824 IF(ISUB.EQ.213) THEN
34825 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34826 RKF=2.0D0
34827 ELSEIF(ISUB.EQ.214) THEN
34828 KFID=16
34829 RKF=1.0D0
34830 ENDIF
34831 ISUB=213
34832
34833C...Neutralinos
34834 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34835 IF(ISUB.EQ.216) THEN
34836 IZID1=1
34837 IZID2=1
34838 ELSEIF(ISUB.EQ.217) THEN
34839 IZID1=2
34840 IZID2=2
34841 ELSEIF(ISUB.EQ.218) THEN
34842 IZID1=3
34843 IZID2=3
34844 ELSEIF(ISUB.EQ.219) THEN
34845 IZID1=4
34846 IZID2=4
34847 ELSEIF(ISUB.EQ.220) THEN
34848 IZID1=1
34849 IZID2=2
34850 ELSEIF(ISUB.EQ.221) THEN
34851 IZID1=1
34852 IZID2=3
34853 ELSEIF(ISUB.EQ.222) THEN
34854 IZID1=1
34855 IZID2=4
34856 ELSEIF(ISUB.EQ.223) THEN
34857 IZID1=2
34858 IZID2=3
34859 ELSEIF(ISUB.EQ.224) THEN
34860 IZID1=2
34861 IZID2=4
34862 ELSEIF(ISUB.EQ.225) THEN
34863 IZID1=3
34864 IZID2=4
34865 ENDIF
34866 ISUB=216
34867
34868C...Charginos
34869 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34870 IF(ISUB.EQ.226) THEN
34871 IZID1=1
34872 IZID2=1
34873 ELSEIF(ISUB.EQ.227) THEN
34874 IZID1=2
34875 IZID2=2
34876 ELSEIF(ISUB.EQ.228) THEN
34877 IZID1=1
34878 IZID2=2
34879 ENDIF
34880 ISUB=226
34881
34882C...Neutralino + chargino
34883 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34884 IF(ISUB.EQ.229) THEN
34885 IZID1=1
34886 IZID2=1
34887 ELSEIF(ISUB.EQ.230) THEN
34888 IZID1=1
34889 IZID2=2
34890 ELSEIF(ISUB.EQ.231) THEN
34891 IZID1=1
34892 IZID2=3
34893 ELSEIF(ISUB.EQ.232) THEN
34894 IZID1=1
34895 IZID2=4
34896 ELSEIF(ISUB.EQ.233) THEN
34897 IZID1=2
34898 IZID2=1
34899 ELSEIF(ISUB.EQ.234) THEN
34900 IZID1=2
34901 IZID2=2
34902 ELSEIF(ISUB.EQ.235) THEN
34903 IZID1=2
34904 IZID2=3
34905 ELSEIF(ISUB.EQ.236) THEN
34906 IZID1=2
34907 IZID2=4
34908 ENDIF
34909 ISUB=229
34910
34911C...Gluino + neutralino
34912 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34913 IF(ISUB.EQ.237) THEN
34914 IZID=1
34915 ELSEIF(ISUB.EQ.238) THEN
34916 IZID=2
34917 ELSEIF(ISUB.EQ.239) THEN
34918 IZID=3
34919 ELSEIF(ISUB.EQ.240) THEN
34920 IZID=4
34921 ENDIF
34922 ISUB=237
34923
34924C...Gluino + chargino
34925 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34926 IF(ISUB.EQ.241) THEN
34927 IZID=1
34928 ELSEIF(ISUB.EQ.242) THEN
34929 IZID=2
34930 ENDIF
34931 ISUB=241
34932
34933C...Squark + neutralino
34934 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34935 ILR=0
34936 IF(MOD(ISUB,2).NE.0) ILR=1
34937 IF(ISUB.LE.247) THEN
34938 IZID=1
34939 ELSEIF(ISUB.LE.249) THEN
34940 IZID=2
34941 ELSEIF(ISUB.LE.251) THEN
34942 IZID=3
34943 ELSEIF(ISUB.LE.253) THEN
34944 IZID=4
34945 ENDIF
34946 ISUB=246
34947 RKF=5D0
34948
34949C...Squark + chargino
34950 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34951 IF(ISUB.LE.255) THEN
34952 IZID=1
34953 ELSEIF(ISUB.LE.257) THEN
34954 IZID=2
34955 ENDIF
34956 IF(MOD(ISUB,2).EQ.0) THEN
34957 ILR=0
34958 ELSE
34959 ILR=1
34960 ENDIF
34961 ISUB=254
34962 RKF=5D0
34963
34964C...Squark + gluino
34965 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34966 ISUB=258
34967 RKF=4D0
34968
34969C...Stops
34970 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34971 ILR=0
34972 IF(ISUB.EQ.262) ILR=1
34973 ISUB=261
34974 ELSEIF(ISUB.EQ.265) THEN
34975 ISUB=264
34976
34977C...Squarks
34978 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34979 ILR=0
34980 IF(ISUB.LE.273) THEN
34981 IF(ISUB.EQ.273) ILR=1
34982 ISUB=271
34983 RKF=16D0
34984 ELSEIF(ISUB.LE.276) THEN
34985 IF(ISUB.EQ.276) ILR=1
34986 ISUB=274
34987 RKF=16D0
34988 ELSEIF(ISUB.LE.278) THEN
34989 IF(ISUB.EQ.278) ILR=1
34990 ISUB=277
34991 RKF=4D0
34992 ELSE
34993 IF(ISUB.EQ.280) ILR=1
34994 ISUB=279
34995 RKF=4D0
34996 ENDIF
34997C...Sbottoms
34998 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
34999 ILR=0
35000 IF(ISUB.LE.283) THEN
35001 IF(ISUB.EQ.283) ILR=1
35002 ISUB=271
35003 RKF=4D0
35004 ELSEIF(ISUB.LE.286) THEN
35005 IF(ISUB.EQ.286) ILR=1
35006 ISUB=274
35007 RKF=4D0
35008 ELSEIF(ISUB.LE.288) THEN
35009 IF(ISUB.EQ.288) ILR=1
35010 ISUB=277
35011 RKF=1D0
35012 ELSEIF(ISUB.LE.290) THEN
35013 IF(ISUB.EQ.290) ILR=1
35014 ISUB=279
35015 RKF=1D0
35016 ELSEIF(ISUB.LE.293) THEN
35017 IF(ISUB.EQ.293) ILR=1
35018 ISUB=271
35019 RKF=1D0
35020 ELSEIF(ISUB.EQ.296) THEN
35021 ILR=1
35022 ISUB=274
35023 RKF=1D0
35024C...Squark + gluino
35025 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35026 ISUB=258
35027 RKF=1D0
35028 ENDIF
35029C...H+/- + H0
35030 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35031 IF(ISUB.EQ.297) THEN
35032 RKF=.5D0*PARU(195)**2
35033 ELSEIF(ISUB.EQ.298) THEN
35034 RKF=.5D0*(1D0-PARU(195)**2)
35035 ENDIF
35036 ISUB=210
35037C...A0 + H0
35038 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35039 IF(ISUB.EQ.299) THEN
35040 RKF=PARU(186)**2
35041 KFID=25
35042 ELSEIF(ISUB.EQ.300) THEN
35043 RKF=PARU(187)**2
35044 KFID=35
35045 ENDIF
35046 ISUB=213
35047C...H+ + H-
35048 ELSEIF(ISUB.EQ.301) THEN
35049 KFID=37
35050 RKF=1D0
35051 ISUB=201
35052 ENDIF
35053
35054C...Supersymmetric processes - all of type 2 -> 2 :
35055C...correct final-state Breit-Wigners from fixed to running width.
35056 IF(MSTP(42).GT.0) THEN
35057 DO 100 I=1,2
35058 KFLW=KFPR(ISUBSV,I)
35059 KCW=PYCOMP(KFLW)
35060 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35061 IF(I.EQ.1) SQMI=SQM3
35062 IF(I.EQ.2) SQMI=SQM4
35063 SQMS=PMAS(KCW,1)**2
35064 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35065 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35066 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35067 GMMI=SQRT(SQMI)*WDTP(0)
35068 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35069 COMFAC=COMFAC*(HBWI/HBWS)
35070 100 CONTINUE
35071 ENDIF
35072
35073C...Differential cross section expressions.
35074
35075 IF(ISUB.LE.210) THEN
35076 IF(ISUB.EQ.201) THEN
35077C...f + fbar -> e_L + e_Lbar
35078 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35079 DO 130 I=MMIN1,MMAX1
35080 IA=IABS(I)
35081 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35082 EI=KCHG(IA,1)/3D0
35083 TT3I=SIGN(1D0,EI+1D-6)/2D0
35084 EJ=-1D0
35085 TT3J=-1D0/2D0
35086 FCOL=1D0
35087C...Color factor for e+ e-
35088 IF(IA.GE.11) FCOL=3D0
35089 IF(ISUBSV.EQ.301) THEN
35090 A1=1D0
35091 A2=0D0
35092 ELSEIF(ILR.EQ.1) THEN
35093 A1=SFMIX(KFID,3)**2
35094 A2=SFMIX(KFID,4)**2
35095 ELSEIF(ILR.EQ.0) THEN
35096 A1=SFMIX(KFID,1)**2
35097 A2=SFMIX(KFID,2)**2
35098 ENDIF
35099 XLQ=(TT3J-EJ*XW)*A1
35100 XRQ=(-EJ*XW)*A2
35101 XLF=(TT3I-EI*XW)
35102 XRF=(-EI*XW)
35103 TAA=(EI*EJ)**2*(POLL+POLR)
35104 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35105 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35106 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35107 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35108 TNN=0.0D0
35109 TAN=0.0D0
35110 TZN=0.0D0
35111 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35112 FAC2=SQRT(2D0)
35113 TNN1=0D0
35114 TNN2=0D0
35115 TNN3=0D0
35116 DO 120 II=1,4
35117 DK=1D0/(TH-SMZ(II)**2)
35118 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35119 & ZMIX(II,1))
35120 FREK=FAC2*TANW*EI*ZMIX(II,1)
35121 TNN1=TNN1+FLEK**2*DK
35122 TNN2=TNN2+FREK**2*DK
35123 DO 110 JJ=1,4
35124 DL=1D0/(TH-SMZ(JJ)**2)
35125 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35126 & ZMIX(JJ,1))
35127 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35128 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35129 110 CONTINUE
35130 120 CONTINUE
35131 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35132 & A2**2*TNN2**2*POLR)
35133 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35134 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35135 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35136 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35137 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35138 & (1D0-SQMZ/SH)/SH
35139 TZN=TZN/XW**2/XW1
35140 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35141 & A2*TNN2*POLR)/XW
35142 ENDIF
35143 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35144 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35145 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35146 NCHN=NCHN+1
35147 ISIG(NCHN,1)=I
35148 ISIG(NCHN,2)=-I
35149 ISIG(NCHN,3)=1
35150 SIGH(NCHN)=FACQQ1+FACQQ2
35151 130 CONTINUE
35152
35153 ELSEIF(ISUB.EQ.203) THEN
35154C...f + fbar -> e_L + e_Rbar
35155 DO 160 I=MMIN1,MMAX1
35156 IA=IABS(I)
35157 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35158 EI=KCHG(IABS(I),1)/3D0
35159 TT3I=SIGN(1D0,EI)/2D0
35160 EJ=-1
35161 TT3J=-1D0/2D0
35162 FCOL=1D0
35163C...Color factor for e+ e-
35164 IF(IA.GE.11) FCOL=3D0
35165 A1=SFMIX(KFID,1)**2
35166 A2=SFMIX(KFID,2)**2
35167 XLQ=(TT3J-EJ*XW)
35168 XRQ=(-EJ*XW)
35169 XLF=(TT3I-EI*XW)
35170 XRF=(-EI*XW)
35171 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35172 & /XW**2/XW1**2*A1*A2
35173 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35174 TNN=0.0D0
35175 TZN=0.0D0
35176 TNNA=0D0
35177 TNNB=0D0
35178 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35179 FAC2=SQRT(2D0)
35180 TNN1=0D0
35181 TNN2=0D0
35182 TNN3=0D0
35183 DO 150 II=1,4
35184 DK=1D0/(TH-SMZ(II)**2)
35185 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35186 & ZMIX(II,1))
35187 FREK=FAC2*TANW*EI*ZMIX(II,1)
35188 TNN1=TNN1+FLEK**2*DK
35189 TNN2=TNN2+FREK**2*DK
35190 DO 140 JJ=1,4
35191 DL=1D0/(TH-SMZ(JJ)**2)
35192 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35193 & ZMIX(JJ,1))
35194 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35195 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35196 140 CONTINUE
35197 150 CONTINUE
35198 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35199 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35200 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35201 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35202 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35203 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35204 & (1D0-SQMZ/SH)/SH
35205 ENDIF
35206 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35207 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35208 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35209C%%%%%%%%%%%
35210 NCHN=NCHN+1
35211 ISIG(NCHN,1)=I
35212 ISIG(NCHN,2)=-I
35213 ISIG(NCHN,3)=1
35214 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35215 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35216 NCHN=NCHN+1
35217 ISIG(NCHN,1)=I
35218 ISIG(NCHN,2)=-I
35219 ISIG(NCHN,3)=2
35220 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35221 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35222 160 CONTINUE
35223
35224 ELSEIF(ISUB.EQ.210) THEN
35225C...q + qbar' -> W*- > ~l_L + ~nu_L
35226 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35227 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35228 DO 180 I=MMIN1,MMAX1
35229 IA=IABS(I)
35230 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35231 DO 170 J=MMIN2,MMAX2
35232 JA=IABS(J)
35233 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35234 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35235 FCKM=3D0
35236 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35237 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35238 KCHW=2
35239 IF(KCHSUM.LT.0) KCHW=3
35240 NCHN=NCHN+1
35241 ISIG(NCHN,1)=I
35242 ISIG(NCHN,2)=J
35243 ISIG(NCHN,3)=1
35244 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35245 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35246 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35247 ELSE
35248 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35249 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35250 ENDIF
35251 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35252 170 CONTINUE
35253 180 CONTINUE
35254 ENDIF
35255
35256 ELSEIF(ISUB.LE.220) THEN
35257 IF(ISUB.EQ.213) THEN
35258C...f + fbar -> ~nu_L + ~nu_Lbar
35259 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35260 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35261 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35262 ELSE
35263 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35264 ENDIF
35265 COMFAC=COMFAC*FACR
35266 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35267 XLL=0.5D0
35268 XLR=0.0D0
35269 DO 190 I=MMIN1,MMAX1
35270 IA=IABS(I)
35271 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35272 EI=KCHG(IA,1)/3D0
35273 FCOL=1D0
35274C...Color factor for e+ e-
35275 IF(IA.GE.11) FCOL=3D0
35276 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35277 XRQ=-EI*XW
35278 TZC=0.0D0
35279 TCC=0.0D0
35280 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35281 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35282 & (TH-SMW(2)**2)
35283 TCC=TZC**2
35284 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35285 ENDIF
35286 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35287 FACQQ2=TZC+TCC/4D0
35288 NCHN=NCHN+1
35289 ISIG(NCHN,1)=I
35290 ISIG(NCHN,2)=-I
35291 ISIG(NCHN,3)=1
35292 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35293 & *AEM**2*FCOL/3D0/XW**2
35294 190 CONTINUE
35295
35296 ELSEIF(ISUB.EQ.216) THEN
35297C...q + qbar -> ~chi0_1 + ~chi0_1
35298 IF(IZID1.EQ.IZID2) THEN
35299 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35300 ELSE
35301 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35302 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35303 ENDIF
35304 FACXX=COMFAC*AEM**2/3D0/XW**2
35305 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35306 ZM12=SQM3
35307 ZM22=SQM4
35308 WU2 = (UH-ZM12)*(UH-ZM22)
35309 WT2 = (TH-ZM12)*(TH-ZM22)
35310 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35311 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35312 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35313 DO 200 I=1,4
35314 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35315 IF(IZID2.NE.IZID1) THEN
35316 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35317 ENDIF
35318 200 CONTINUE
35319 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35320 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35321 ORPP=DCONJG(OLPP)
35322 DO 210 I=MMINA,MMAXA
35323 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35324 EI=KCHG(IABS(I),1)/3D0
35325 T3I=SIGN(1D0,EI+1D-6)/2D0
35326 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35327 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35328 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35329 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35330 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35331 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35332 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35333 & /DCMPLX(TH-XML2)
35334 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35335 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35336 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35337 FCOL=1D0
35338 IF(IABS(I).GE.11) FCOL=3D0
35339 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35340 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35341 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35342 & QRL*DCONJG(QRR)*POLR)*WS2
35343 NCHN=NCHN+1
35344 ISIG(NCHN,1)=I
35345 ISIG(NCHN,2)=-I
35346 ISIG(NCHN,3)=1
35347 SIGH(NCHN)=FACXX*FACGG1*FCOL
35348 210 CONTINUE
35349 ENDIF
35350
35351 ELSEIF(ISUB.LE.230) THEN
35352 IF(ISUB.EQ.226) THEN
35353C...f + fbar -> ~chi+_1 + ~chi-_1
35354 FACXX=COMFAC*AEM**2/3D0
35355 ZM12=SQM3
35356 ZM22=SQM4
35357 WU2 = (UH-ZM12)*(UH-ZM22)
35358 WT2 = (TH-ZM12)*(TH-ZM22)
35359 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35360 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35361 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35362 DIFF=0D0
35363 IF(IZID1.EQ.IZID2) DIFF=1D0
35364 DO 220 I=1,2
35365 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35366 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35367 IF(IZID2.NE.IZID1) THEN
35368 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35369 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35370 ENDIF
35371 220 CONTINUE
35372 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35373 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35374 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35375 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35376 DO 230 I=MMINA,MMAXA
35377 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35378 EI=KCHG(IABS(I),1)/3D0
35379 T3I=SIGN(1D0,EI+1D-6)/2D0
35380 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35381 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35382 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35383 IF(MOD(I,2).EQ.0) THEN
35384 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35385 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35386 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35387 & DCMPLX(T3I/XW/(TH-XML2))
35388 ELSE
35389 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35390 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35391 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35392 & DCMPLX(T3I/XW/(TH-XML2))
35393 ENDIF
35394 FCOL=1D0
35395 IF(IABS(I).GE.11) FCOL=3D0
35396 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35397 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35398 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35399 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35400 NCHN=NCHN+1
35401 ISIG(NCHN,1)=I
35402 ISIG(NCHN,2)=-I
35403 ISIG(NCHN,3)=1
35404 IF(IZID1.EQ.IZID2) THEN
35405 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35406 ELSE
35407 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35408 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35409 NCHN=NCHN+1
35410 ISIG(NCHN,1)=I
35411 ISIG(NCHN,2)=-I
35412 ISIG(NCHN,3)=2
35413 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35414 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35415 ENDIF
35416 230 CONTINUE
35417
35418 ELSEIF(ISUB.EQ.229) THEN
35419C...q + qbar' -> ~chi0_1 + ~chi+-_1
35420 FACXX=COMFAC*AEM**2/6D0/XW**2
35421 ZM12=SQM3
35422 ZM22=SQM4
35423 WU2 = (UH-ZM12)*(UH-ZM22)
35424 WT2 = (TH-ZM12)*(TH-ZM22)
35425 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35426 RT2I = 1D0/SQRT(2D0)
35427 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35428 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35429 DO 240 I=1,2
35430 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35431 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35432 240 CONTINUE
35433 DO 250 I=1,4
35434 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35435 250 CONTINUE
35436 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35437 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35438 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35439 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35440
35441 DO 270 I=MMIN1,MMAX1
35442 IA=IABS(I)
35443 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35444 EI=KCHG(IA,1)/3D0
35445 T3I=SIGN(1D0,EI+1D-6)/2D0
35446 DO 260 J=MMIN2,MMAX2
35447 JA=IABS(J)
35448 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35449 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35450 EJ=KCHG(JA,1)/3D0
35451 T3J=SIGN(1D0,EJ+1D-6)/2D0
35452 FCKM=3D0
35453 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35454 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35455 KCHW=2
35456 IF(KCHSUM.LT.0) KCHW=3
35457 IF(MOD(IA,2).EQ.0) THEN
35458 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35459 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35460 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35461 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35462 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35463 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35464 & /DCMPLX(TH-ZMJ2)
35465 ELSE
35466 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35467 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35468 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35469 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35470 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35471 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35472 & /DCMPLX(TH-ZMI2)
35473 ENDIF
35474 ZINTR=DBLE(QLR*DCONJG(QLL))
35475 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35476 & 2D0*ZINTR*WS2)
35477 NCHN=NCHN+1
35478 ISIG(NCHN,1)=I
35479 ISIG(NCHN,2)=J
35480 ISIG(NCHN,3)=1
35481 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35482 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35483 260 CONTINUE
35484 270 CONTINUE
35485 ENDIF
35486
35487 ELSEIF(ISUB.LE.240) THEN
35488 IF(ISUB.EQ.237) THEN
35489C...q + qbar -> gluino + ~chi0_1
35490 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35491 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35492 ASYUK=RMSS(42)*AS
35493 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35494 GM2=SQM3
35495 ZM2=SQM4
35496 DO 280 I=MMINA,MMAXA
35497 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35498 EI=KCHG(IABS(I),1)/3D0
35499 IA=IABS(I)
35500 XLQC = -TANW*EI*ZMIX(IZID,1)
35501 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35502 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35503 XLQ2=XLQC**2
35504 XRQ2=XRQC**2
35505 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35506 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35507 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35508 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35509 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35510 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35511 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35512 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35513 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35514 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35515 NCHN=NCHN+1
35516 ISIG(NCHN,1)=I
35517 ISIG(NCHN,2)=-I
35518 ISIG(NCHN,3)=1
35519 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35520 280 CONTINUE
35521 ENDIF
35522
35523 ELSEIF(ISUB.LE.250) THEN
35524 IF(ISUB.EQ.241) THEN
35525C...q + qbar' -> ~chi+-_1 + gluino
35526 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35527 GM2=SQM3
35528 ZM2=SQM4
35529 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35530 FAC0=UMIX(IZID,1)**2
35531 FAC1=VMIX(IZID,1)**2
35532 DO 300 I=MMIN1,MMAX1
35533 IA=IABS(I)
35534 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35535 DO 290 J=MMIN2,MMAX2
35536 JA=IABS(J)
35537 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35538 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35539 FCKM=1D0
35540 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35541 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35542 KCHW=2
35543 IF(KCHSUM.LT.0) KCHW=3
35544 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35545 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35546 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35547 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35548 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35549 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35550 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35551 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35552 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35553 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35554 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35555 NCHN=NCHN+1
35556 ISIG(NCHN,1)=I
35557 ISIG(NCHN,2)=J
35558 ISIG(NCHN,3)=1
35559 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35560 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35561 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35562 290 CONTINUE
35563 300 CONTINUE
35564
35565 ELSEIF(ISUB.EQ.243) THEN
35566C...q + qbar -> gluino + gluino
35567 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35568 XMT=SQM3-TH
35569 XMU=SQM3-UH
35570 DO 310 I=MMINA,MMAXA
35571 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35572 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35573 NCHN=NCHN+1
35574 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35575 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35576 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35577 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35578 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35579 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35580 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35581 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35582 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35583 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35584 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35585 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35586 ISIG(NCHN,1)=I
35587 ISIG(NCHN,2)=-I
35588 ISIG(NCHN,3)=1
35589C...1/2 for identical particles
35590 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35591 310 CONTINUE
35592
35593 ELSEIF(ISUB.EQ.244) THEN
35594C...g + g -> gluino + gluino
35595 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35596 XMT=SQM3-TH
35597 XMU=SQM3-UH
35598 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35599 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35600 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35601 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35602 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35603 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35604 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35605 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35606 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35607 NCHN=NCHN+1
35608 ISIG(NCHN,1)=21
35609 ISIG(NCHN,2)=21
35610 ISIG(NCHN,3)=1
35611 SIGH(NCHN)=FACQQ1/2D0
35612 NCHN=NCHN+1
35613 ISIG(NCHN,1)=21
35614 ISIG(NCHN,2)=21
35615 ISIG(NCHN,3)=2
35616 SIGH(NCHN)=FACQQ2/2D0
35617 NCHN=NCHN+1
35618 ISIG(NCHN,1)=21
35619 ISIG(NCHN,2)=21
35620 ISIG(NCHN,3)=3
35621 SIGH(NCHN)=FACQQ3/2D0
35622 320 CONTINUE
35623
35624 ELSEIF(ISUB.EQ.246) THEN
35625C...g + q_j -> ~chi0_1 + ~q_j
35626 FAC0=COMFAC*AS*AEM/6D0/XW
35627 ZM2=SQM4
35628 QM2=SQM3
35629 FACZQ0=FAC0*( (ZM2-TH)/SH +
35630 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35631 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35632 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35633 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35634 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35635 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35636 EI=KCHG(IABS(I),1)/3D0
35637 IA=IABS(I)
35638 XRQZ = -TANW*EI*ZMIX(IZID,1)
35639 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35640 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35641 IF(ILR.EQ.0) THEN
35642 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35643 ELSE
35644 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35645 ENDIF
35646 FACZQ=FACZQ0*BS
35647 KCHQ=2
35648 IF(I.LT.0) KCHQ=3
35649 DO 330 ISDE=1,2
35650 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35651 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35652 NCHN=NCHN+1
35653 ISIG(NCHN,ISDE)=I
35654 ISIG(NCHN,3-ISDE)=21
35655 ISIG(NCHN,3)=1
35656 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35657 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35658 330 CONTINUE
35659 340 CONTINUE
35660 ENDIF
35661
35662 ELSEIF(ISUB.LE.260) THEN
35663 IF(ISUB.EQ.254) THEN
35664C...g + q_j -> ~chi1_1 + ~q_i
35665 FAC0=COMFAC*AS*AEM/12D0/XW
35666 ZM2=SQM4
35667 QM2=SQM3
35668 AU=UMIX(IZID,1)**2
35669 AD=VMIX(IZID,1)**2
35670 FACZQ0=FAC0*( (ZM2-TH)/SH +
35671 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35672 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35673 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35674 IF(MOD(KFNSQ1,2).EQ.0) THEN
35675 KFNSQ=KFNSQ1-1
35676 KCHW=2
35677 ELSE
35678 KFNSQ=KFNSQ1+1
35679 KCHW=3
35680 ENDIF
35681 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35682 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35684 IA=IABS(I)
35685 IF(MOD(IA,2).EQ.0) THEN
35686 FACZQ=FACZQ0*AU
35687 ELSE
35688 FACZQ=FACZQ0*AD
35689 ENDIF
35690 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35691 KCHQ=2
35692 IF(I.LT.0) KCHQ=3
35693 KCHWQ=KCHW
35694 IF(I.LT.0) KCHWQ=5-KCHW
35695 DO 350 ISDE=1,2
35696 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35697 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35698 NCHN=NCHN+1
35699 ISIG(NCHN,ISDE)=I
35700 ISIG(NCHN,3-ISDE)=21
35701 ISIG(NCHN,3)=1
35702 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35703 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35704 350 CONTINUE
35705 360 CONTINUE
35706
35707 ELSEIF(ISUB.EQ.258) THEN
35708C...g + q_j -> gluino + ~q_i
35709 XG2=SQM4
35710 XQ2=SQM3
35711 XMT=XG2-TH
35712 XMU=XG2-UH
35713 XST=XQ2-TH
35714 XSU=XQ2-UH
35715 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35716 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35717 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35718 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35719 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35720 & (SH*(UH+XG2)
35721 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35722 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35723 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35724 ASYUK=RMSS(42)*AS
35725 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35726 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35727 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35728 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35729 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35730 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35731 KCHQ=2
35732 IF(I.LT.0) KCHQ=3
35733 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35734 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35735 DO 370 ISDE=1,2
35736 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35737 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35738 NCHN=NCHN+1
35739 ISIG(NCHN,ISDE)=I
35740 ISIG(NCHN,3-ISDE)=21
35741 ISIG(NCHN,3)=1
35742 SIGH(NCHN)=FACQG1*FACSEL
35743 NCHN=NCHN+1
35744 ISIG(NCHN,ISDE)=I
35745 ISIG(NCHN,3-ISDE)=21
35746 ISIG(NCHN,3)=2
35747 SIGH(NCHN)=FACQG2*FACSEL
35748 370 CONTINUE
35749 380 CONTINUE
35750 ENDIF
35751
35752 ELSEIF(ISUB.LE.270) THEN
35753 IF(ISUB.EQ.261) THEN
35754C...q_i + q_ibar -> ~t_1 + ~t_1bar
35755 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35756 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35757 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35758 FAC0=AS**2*4D0/9D0
35759 DO 390 I=MMIN1,MMAX1
35760 IA=IABS(I)
35761 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35762 IF(IA.GE.11.AND.IA.LE.18) THEN
35763 EI=KCHG(IA,1)/3D0
35764 EJ=KCHG(KFNSQ,1)/3D0
35765 T3I=SIGN(1D0,EI)/2D0
35766 T3J=SIGN(1D0,EJ)/2D0
35767 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35768 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35769 XLF=2D0*(T3I-EI*XW)
35770 XRF=2D0*(-EI*XW)
35771 TAA=0.5D0*(EI*EJ)**2
35772 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35773 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35774 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35775 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35776 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35777 ENDIF
35778 NCHN=NCHN+1
35779 ISIG(NCHN,1)=I
35780 ISIG(NCHN,2)=-I
35781 ISIG(NCHN,3)=1
35782 SIGH(NCHN)=FACQQ1*FAC0
35783 390 CONTINUE
35784
35785 ELSEIF(ISUB.EQ.263) THEN
35786C...f + fbar -> ~t1 + ~t2bar
35787 DO 400 I=MMIN1,MMAX1
35788 IA=IABS(I)
35789 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35790 EI=KCHG(IABS(I),1)/3D0
35791 TT3I=SIGN(1D0,EI)/2D0
35792 EJ=2D0/3D0
35793 TT3J=1D0/2D0
35794 FCOL=1D0
35795C...Color factor for e+ e-
35796 IF(IA.GE.11) FCOL=3D0
35797 XLQ=2D0*(TT3J-EJ*XW)
35798 XRQ=2D0*(-EJ*XW)
35799 XLF=2D0*(TT3I-EI*XW)
35800 XRF=2D0*(-EI*XW)
35801 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35802 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35803 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35804C...Factor of 2 for t1 t2bar + t2 t1bar
35805 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35806 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35807 NCHN=NCHN+1
35808 ISIG(NCHN,1)=I
35809 ISIG(NCHN,2)=-I
35810 ISIG(NCHN,3)=1
35811 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35812 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35813 NCHN=NCHN+1
35814 ISIG(NCHN,1)=I
35815 ISIG(NCHN,2)=-I
35816 ISIG(NCHN,3)=2
35817 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35818 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35819 400 CONTINUE
35820
35821 ELSEIF(ISUB.EQ.264) THEN
35822C...g + g -> ~t_1 + ~t_1bar
35823 XSU=SQM3-UH
35824 XST=SQM3-TH
35825 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35826 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35827 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35828 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35829 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35830 NCHN=NCHN+1
35831 ISIG(NCHN,1)=21
35832 ISIG(NCHN,2)=21
35833 ISIG(NCHN,3)=1
35834 SIGH(NCHN)=FACQQ1
35835 NCHN=NCHN+1
35836 ISIG(NCHN,1)=21
35837 ISIG(NCHN,2)=21
35838 ISIG(NCHN,3)=2
35839 SIGH(NCHN)=FACQQ2
35840 410 CONTINUE
35841 ENDIF
35842
35843 ELSEIF(ISUB.LE.280) THEN
35844 IF(ISUB.EQ.271) THEN
35845C...q + q' -> ~q + ~q' (~g exchange)
35846 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35847 XMT=XMG2-TH
35848 XMU=XMG2-UH
35849 XSU1=SQM3-UH
35850 XSU2=SQM4-UH
35851 XST1=SQM3-TH
35852 XST2=SQM4-TH
35853 ASYUK=RMSS(42)*AS
35854 IF(ILR.EQ.1) THEN
35855 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35856 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35857 FACQQB=0.0D0
35858 ELSE
35859 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35860 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35861 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35862 & XMT/XMU )
35863 ENDIF
35864 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35865 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35866 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35867 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35868 IA=IABS(I)
35869 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35870 KCHQ=2
35871 IF(I.LT.0) KCHQ=3
35872 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35873 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35874 JA=IABS(J)
35875 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35876 IF(I*J.LT.0) GOTO 420
35877 NCHN=NCHN+1
35878 ISIG(NCHN,1)=I
35879 ISIG(NCHN,2)=J
35880 ISIG(NCHN,3)=1
35881 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35882 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35883 IF(I.EQ.J) THEN
35884 IF(ILR.EQ.0) THEN
35885 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35886 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35887 ELSE
35888 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35889 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35891 ENDIF
35892 NCHN=NCHN+1
35893 ISIG(NCHN,1)=I
35894 ISIG(NCHN,2)=J
35895 ISIG(NCHN,3)=2
35896 IF(ILR.EQ.0) THEN
35897 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35898 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35899 ELSE
35900 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35901 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35902 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35903 ENDIF
35904 ENDIF
35905 420 CONTINUE
35906 430 CONTINUE
35907
35908 ELSEIF(ISUB.EQ.274) THEN
35909C...q + qbar' -> ~q + ~qbar'
35910 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35911 XMT=XMG2-TH
35912 XMU=XMG2-UH
35913 IF(ILR.EQ.0) THEN
35914C...Mrenna...Normalization.and.1/XMT
35915 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35916 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35917 FACQQB=COMFAC*AS**2*4D0/9D0*(
35918 & (UH*TH-SQM3*SQM4)/SH2 )
35919 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35920 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35921 FACQQB=FACQQB+FACQQ1+FACQQI
35922 ELSE
35923 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35924 FACQQB=FACQQ1
35925 ENDIF
35926 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35927 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35928 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35929 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35930 IA=IABS(I)
35931 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35932 KCHQ=2
35933 IF(I.LT.0) KCHQ=3
35934 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35935 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35936 JA=IABS(J)
35937 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35938 IF(I*J.GT.0) GOTO 440
35939 NCHN=NCHN+1
35940 ISIG(NCHN,1)=I
35941 ISIG(NCHN,2)=J
35942 ISIG(NCHN,3)=1
35943 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35944 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35945 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35946 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35947 440 CONTINUE
35948 450 CONTINUE
35949
35950 ELSEIF(ISUB.EQ.277) THEN
35951C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35952C...if i .eq. j covered in 274
35953 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35954 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35955 FAC0=0D0
35956 DO 460 I=MMIN1,MMAX1
35957 IA=IABS(I)
35958 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35959 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35960 IF(IA.EQ.KFNSQ) GOTO 460
35961 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35962 EI=KCHG(IA,1)/3D0
35963 EJ=KCHG(KFNSQ,1)/3D0
35964 T3J=SIGN(0.5D0,EJ)
35965 T3I=SIGN(1D0,EI)/2D0
35966 IF(ILR.EQ.0) THEN
35967 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35968 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35969 ELSE
35970 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35971 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35972 ENDIF
35973 XLF=2D0*(T3I-EI*XW)
35974 XRF=2D0*(-EI*XW)
35975 IF(ILR.EQ.0) THEN
35976 XRQ=0D0
35977 ELSE
35978 XLQ=0D0
35979 ENDIF
35980 TAA=0.5D0*(EI*EJ)**2
35981 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35982 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35983 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35984 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35985 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35986 ELSEIF(IA.LE.6) THEN
35987 FAC0=AS**2*8D0/9D0/2D0
35988 ENDIF
35989 NCHN=NCHN+1
35990 ISIG(NCHN,1)=I
35991 ISIG(NCHN,2)=-I
35992 ISIG(NCHN,3)=1
35993 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35994 460 CONTINUE
35995
35996 ELSEIF(ISUB.EQ.279) THEN
35997C...g + g -> ~q_j + ~q_jbar
35998 XSU=SQM3-UH
35999 XST=SQM3-TH
36000C...5=RKF because ~t ~tbar treated separately
36001 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36002 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36003 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36004 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36005 NCHN=NCHN+1
36006 ISIG(NCHN,1)=21
36007 ISIG(NCHN,2)=21
36008 ISIG(NCHN,3)=1
36009 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36010 NCHN=NCHN+1
36011 ISIG(NCHN,1)=21
36012 ISIG(NCHN,2)=21
36013 ISIG(NCHN,3)=2
36014 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36015 470 CONTINUE
36016
36017 ENDIF
36018 ENDIF
36019CMRENNA--
36020
36021 RETURN
36022 END
36023
36024C*********************************************************************
36025
36026C...PYSGTC
36027C...Subprocess cross sections for Technicolor processes.
36028C...Auxiliary to PYSIGH.
36029
36030 SUBROUTINE PYSGTC(NCHN,SIGS)
36031
36032C...Double precision and integer declarations
36033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36034 IMPLICIT INTEGER(I-N)
36035 INTEGER PYK,PYCHGE,PYCOMP
36036C...Parameter statement to help give large particle numbers.
36037 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36038 &KEXCIT=4000000,KDIMEN=5000000)
36039C...Commonblocks
36040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36042 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36043 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36044 COMMON/PYINT1/MINT(400),VINT(400)
36045 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36046 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36047 COMMON/PYINT4/MWID(500),WIDS(500,5)
36048 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36049 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36050 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36051 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36052 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36053 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36054 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36055C...Local arrays and complex variables
36056 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36057 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36058 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36059 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36060 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36061 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36062 COMPLEX*16 DVVS,DVVT,DVVU
36063 INTEGER INDX(6)
36064
36065C...Combinations of weak mixing angle.
36066 TANW=SQRT(XW/XW1)
36067 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36068
36069C...Convert almost equivalent technicolor processes into
36070C...a few basic processes, and set distinguishing parameters.
36071 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36072 SQTV=RTCM(12)**2
36073 SQTA=RTCM(13)**2
36074 SN2W=2D0*SQRT(XW*XW1)
36075 CS2W=1D0-2D0*XW
36076 CT2W=CS2W/SN2W
36077 CSXI=COS(ASIN(RTCM(3)))
36078 CSXIP=COS(ASIN(RTCM(4)))
36079 QUPD=2D0*RTCM(2)-1D0
36080 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36081 CAB2=0D0
36082 VOGP=0D0
36083 VRGP=0D0
36084 AOGP=0D0
36085 ARGP=0D0
36086 VXGP=0D0
36087 AXGP=0D0
36088 VAGP=0D0
36089 VZGP=0D0
36090 VWGP=0D0
36091C... rho_tc0, etc. -> W_L W_L, W_L W_T
36092 IF(ISUB.EQ.361) THEN
36093 KFA=24
36094 KFB=24
36095 CAB2=RTCM(3)**4
36096 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36097 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36098 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36099C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36100 AXGP = SQRT(2D0)*AXGP
36101 ARGP = SQRT(2D0)*ARGP
36102 VOGP = SQRT(2D0)*VOGP
36103C... rho_tc0 -> W_L pi_tc-
36104 ELSEIF(ISUB.EQ.362) THEN
36105 KFA=24
36106 KFB=KTECHN+211
36107 ISUB=361
36108 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36109C... pi_tc pi_tc
36110 ELSEIF(ISUB.EQ.363) THEN
36111 KFA=KTECHN+211
36112 KFB=KTECHN+211
36113 ISUB=361
36114 CAB2=(1D0-RTCM(3)**2)**2
36115C... rho_tc0/omega_tc -> gamma pi_tc
36116 ELSEIF(ISUB.EQ.364) THEN
36117 KFA=22
36118 KFB=KTECHN+111
36119 ISUB=361
36120 VOGP=CSXI/RTCM(12)
36121 VRGP=VOGP*QUPD
36122 VAGP=2D0*QUPD*CSXI
36123 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36124C... gamma pi_tc'
36125 ELSEIF(ISUB.EQ.365) THEN
36126 KFA=22
36127 KFB=KTECHN+221
36128 ISUB=361
36129 VRGP=CSXIP/RTCM(12)
36130 VOGP=VRGP*QUPD
36131 VAGP=2D0*Q2UD*CSXIP
36132 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36133C... Z pi_tc
36134 ELSEIF(ISUB.EQ.366) THEN
36135 KFA=23
36136 KFB=KTECHN+111
36137 ISUB=361
36138 VOGP=CSXI*CT2W/RTCM(12)
36139 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36140 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36141 VZGP=-QUPD*CSXI*CS2W/XW1
36142C... Z pi_tc'
36143 ELSEIF(ISUB.EQ.367) THEN
36144 KFA=23
36145 KFB=KTECHN+221
36146 ISUB=361
36147C...RTCM(48) is the M_V for the techni-a
36148 VXGP=-CSXIP/SN2W/RTCM(48)
36149 VRGP=CSXIP*CT2W/RTCM(12)
36150 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36151 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36152 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36153C... W_T pi_tc
36154 ELSEIF(ISUB.EQ.368) THEN
36155 KFA=24
36156 KFB=KTECHN+211
36157 ISUB=361
36158C...RTCM(49) is the M_A for the techni-a
36159 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36160 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36161 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36162 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36163 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36164C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36165 ELSEIF(ISUB.EQ.370) THEN
36166 KFA=24
36167 KFB=23
36168 CAB2=RTCM(3)**4
36169 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36170 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36171C... W_L pi_tc0
36172 ELSEIF(ISUB.EQ.371) THEN
36173 KFA=24
36174 KFB=KTECHN+111
36175 ISUB=370
36176 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36177C... Z_L pi_tc+
36178 ELSEIF(ISUB.EQ.372) THEN
36179 KFA=KTECHN+211
36180 KFB=23
36181 ISUB=370
36182 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36183C... pi_tc+ pi_tc0
36184 ELSEIF(ISUB.EQ.373) THEN
36185 KFA=KTECHN+211
36186 KFB=KTECHN+111
36187 ISUB=370
36188 CAB2=(1D0-RTCM(3)**2)**2
36189C... gamma pi_tc+
36190 ELSEIF(ISUB.EQ.374) THEN
36191 KFA=KTECHN+211
36192 KFB=22
36193 ISUB=370
36194 VRGP=QUPD*CSXI/RTCM(12)
36195 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36196 AXGP=-CSXI/RTCM(49)
36197C... Z_T pi_tc+
36198 ELSEIF(ISUB.EQ.375) THEN
36199 KFA=KTECHN+211
36200 KFB=23
36201 ISUB=370
36202 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36203 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36204 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36205 AXGP=-CSXI*CT2W/RTCM(49)
36206C... W_T pi_tc0
36207 ELSEIF(ISUB.EQ.376) THEN
36208 KFA=24
36209 KFB=KTECHN+111
36210 ISUB=370
36211 VRGP=0D0
36212 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36213 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36214C... W_T pi_tc0'
36215 ELSEIF(ISUB.EQ.377) THEN
36216 KFA=24
36217 KFB=KTECHN+221
36218 ISUB=370
36219 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36220 VWGP=CSXIP/(2D0*XW)
36221 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36222C... gamma W+
36223 ELSEIF(ISUB.EQ.378) THEN
36224 KFA=24
36225 KFB=22
36226 ISUB=370
36227 VRGP=QUPD*RTCM(3)/RTCM(12)
36228 AXGP=-RTCM(3)/RTCM(49)
36229C... gamma Z
36230 ELSEIF(ISUB.EQ.379) THEN
36231 KFA=23
36232 KFB=22
36233 ISUB=361
36234 VOGP=RTCM(3)/RTCM(12)
36235 VRGP=QUPD*RTCM(3)/RTCM(12)
36236 ELSEIF(ISUB.EQ.380) THEN
36237 KFA=23
36238 KFB=23
36239 ISUB=361
36240 VOGP=RTCM(3)*CT2W/RTCM(12)
36241 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36242 ENDIF
36243 ENDIF
36244
36245C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36246 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36247 IF(ITCM(5).LE.4) THEN
36248 SQDQQS=1D0/SH2
36249 SQDQQT=1D0/TH2
36250 SQDQQU=1D0/UH2
36251 SQDGGS=SQDQQS
36252 SQDGGT=SQDQQT
36253 SQDGGU=SQDQQU
36254 REDGGS=1D0/SH
36255 REDGGT=1D0/TH
36256 REDGGU=1D0/UH
36257 REDGTU=1D0/UH/TH
36258 REDGSU=1D0/SH/UH
36259 REDGST=1D0/SH/TH
36260 REDQST=1D0/SH/TH
36261 REDQTU=1D0/UH/TH
36262 SQDLGS=0D0
36263 SQDLGT=0D0
36264 SQDQTS=SQDQQS
36265 ELSEIF(ITCM(5).EQ.5) THEN
36266 TANT3=RTCM(21)
36267 IF(ITCM(2).EQ.0) THEN
36268 IMDL=1
36269 ELSE
36270 IMDL=2
36271 ENDIF
36272 ALPRHT=2.16D0*(3D0/ITCM(1))
36273 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36274 SINT3=TANT3/SQRT(TANT3**2+1D0)
36275 XIG=SQRT(PYALPS(SH)/ALPRHT)
36276 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36277 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36278 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36279 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36280 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36281 & SINT3**2)*2D0/SIN2T
36282 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36283 & SINT3**2)*2D0/SIN2T
36284
36285 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36286 SM1112=X12*RTCM(28)**2*SIN2T
36287 SM1121=-X21*RTCM(28)**2*SIN2T
36288 SM2212=-SM1112
36289 SM2221=-SM1121
36290 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36291 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36292
36293C.........SH LOOP
36294 ZTC(1,1)=DCMPLX(SH,0D0)
36295 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36296 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36297 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36298 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36299 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36300 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36301 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36302 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36303 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36304 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36305 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36306 ZTC(1,2)=(0D0,0D0)
36307 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36308 ZTC(1,4)=ZTC(1,3)
36309 ZTC(1,5)=ZTC(1,2)
36310 ZTC(1,6)=ZTC(1,2)
36311 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36312 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36313 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36314 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36315 ZTC(3,4)=-SM1122
36316 ZTC(3,5)=-SM1112
36317 ZTC(3,6)=-SM1121
36318 ZTC(4,5)=-SM2212
36319 ZTC(4,6)=-SM2221
36320 ZTC(5,6)=-SM1221
36321
36322 DO 110 I=1,5
36323 DO 100 J=I+1,6
36324 ZTC(J,I)=ZTC(I,J)
36325 100 CONTINUE
36326 110 CONTINUE
36327 CALL PYLDCM(ZTC,6,6,INDX,D)
36328 DO 130 I=1,6
36329 DO 120 J=1,6
36330 YTC(I,J)=(0D0,0D0)
36331 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36332 120 CONTINUE
36333 130 CONTINUE
36334
36335 DO 140 I=1,6
36336 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36337 140 CONTINUE
36338 DGGS=YTC(1,1)
36339 DVVS=YTC(2,2)
36340 DGVS=YTC(1,2)
36341
36342 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36343C.........TH LOOP
36344 ZTC(1,1)=DCMPLX(TH)
36345 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36346 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36347 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36348 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36349 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36350 ZTC(1,2)=(0D0,0D0)
36351 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36352 ZTC(1,4)=ZTC(1,3)
36353 ZTC(1,5)=ZTC(1,2)
36354 ZTC(1,6)=ZTC(1,2)
36355 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36356 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36357 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36358 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36359 ZTC(3,4)=-SM1122
36360 ZTC(3,5)=-SM1112
36361 ZTC(3,6)=-SM1121
36362 ZTC(4,5)=-SM2212
36363 ZTC(4,6)=-SM2221
36364 ZTC(5,6)=-SM1221
36365 DO 160 I=1,5
36366 DO 150 J=I+1,6
36367 ZTC(J,I)=ZTC(I,J)
36368 150 CONTINUE
36369 160 CONTINUE
36370 CALL PYLDCM(ZTC,6,6,INDX,D)
36371 DO 180 I=1,6
36372 DO 170 J=1,6
36373 YTC(I,J)=(0D0,0D0)
36374 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36375 170 CONTINUE
36376 180 CONTINUE
36377 DO 190 I=1,6
36378 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36379 190 CONTINUE
36380 DGGT=YTC(1,1)
36381 DVVT=YTC(2,2)
36382 DGVT=YTC(1,2)
36383
36384 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36385C.........UH LOOP
36386 ZTC(1,1)=DCMPLX(UH,0D0)
36387 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36388 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36389 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36390 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36391 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36392 ZTC(1,2)=(0D0,0D0)
36393 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36394 ZTC(1,4)=ZTC(1,3)
36395 ZTC(1,5)=ZTC(1,2)
36396 ZTC(1,6)=ZTC(1,2)
36397 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36398 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36399 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36400 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36401 ZTC(3,4)=-SM1122
36402 ZTC(3,5)=-SM1112
36403 ZTC(3,6)=-SM1121
36404 ZTC(4,5)=-SM2212
36405 ZTC(4,6)=-SM2221
36406 ZTC(5,6)=-SM1221
36407 DO 210 I=1,5
36408 DO 200 J=I+1,6
36409 ZTC(J,I)=ZTC(I,J)
36410 200 CONTINUE
36411 210 CONTINUE
36412 CALL PYLDCM(ZTC,6,6,INDX,D)
36413 DO 230 I=1,6
36414 DO 220 J=1,6
36415 YTC(I,J)=(0D0,0D0)
36416 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36417 220 CONTINUE
36418 230 CONTINUE
36419 DO 240 I=1,6
36420 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36421 240 CONTINUE
36422 DGGU=YTC(1,1)
36423 DVVU=YTC(2,2)
36424 DGVU=YTC(1,2)
36425
36426 IF(IMDL.EQ.1) THEN
36427 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36428 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36429 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36430 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36431 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36432 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36433 ELSE
36434 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36435 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36436 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36437 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36438 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36439 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36440 ENDIF
36441
36442 SQDQTS=ABS(DQTS)**2
36443 SQDQQS=ABS(DQQS)**2
36444 SQDQQT=ABS(DQQT)**2
36445 SQDQQU=ABS(DQQU)**2
36446 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36447 REDLGS=DBLE(DQGS)
36448 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36449 REDHGS=DBLE(DTGS)
36450 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36451
36452 SQDGGS=ABS(DGGS)**2
36453 SQDGGT=ABS(DGGT)**2
36454 SQDGGU=ABS(DGGU)**2
36455 REDGGS=DBLE(DGGS)
36456 REDGGT=DBLE(DGGT)
36457 REDGGU=DBLE(DGGU)
36458 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36459 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36460 REDGST=DBLE(DGGS*DCONJG(DGGT))
36461 REDQST=DBLE(DQQS*DCONJG(DQQT))
36462 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36463 ENDIF
36464 ENDIF
36465
36466
36467C...Differential cross section expressions.
36468
36469 IF(ISUB.LE.190) THEN
36470 IF(ISUB.EQ.149) THEN
36471C...g + g -> eta_tc
36472 KCTC=PYCOMP(KTECHN+331)
36473 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36474 HS=SHR*WDTP(0)
36475 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36476 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36477 HP=SH
36478 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36479 HI=HP*WDTP(3)
36480 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36481 NCHN=NCHN+1
36482 ISIG(NCHN,1)=21
36483 ISIG(NCHN,2)=21
36484 ISIG(NCHN,3)=1
36485 SIGH(NCHN)=HI*FACBW*HF
36486 250 CONTINUE
36487
36488 ELSEIF(ISUB.EQ.165) THEN
36489C...q + qbar -> l+ + l- (including contact term for compositeness)
36490 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36491 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36492 KFF=IABS(KFPR(ISUB,1))
36493 EF=KCHG(KFF,1)/3D0
36494 AF=SIGN(1D0,EF+0.1D0)
36495 VF=AF-4D0*EF*XWV
36496 VALF=VF+AF
36497 VARF=VF-AF
36498 FCOF=1D0
36499 IF(KFF.LE.10) FCOF=3D0
36500 WID2=1D0
36501 IF(KFF.EQ.6) WID2=WIDS(6,1)
36502 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36503 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36504 DO 260 I=MMINA,MMAXA
36505 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36506 EI=KCHG(IABS(I),1)/3D0
36507 AI=SIGN(1D0,EI+0.1D0)
36508 VI=AI-4D0*EI*XWV
36509 VALI=VI+AI
36510 VARI=VI-AI
36511 FCOI=1D0
36512 IF(IABS(I).LE.10) FCOI=FACA/3D0
36513 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36514 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36515 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36516 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36517 ELSE
36518 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36519 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36520 ENDIF
36521 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36522 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36523 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36524 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36525 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36526 NCHN=NCHN+1
36527 ISIG(NCHN,1)=I
36528 ISIG(NCHN,2)=-I
36529 ISIG(NCHN,3)=1
36530 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36531 260 CONTINUE
36532
36533 ELSEIF(ISUB.EQ.166) THEN
36534C...q + q'bar -> l + nu_l (including contact term for compositeness)
36535 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36536 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36537 KFF=IABS(KFPR(ISUB,1))
36538 FCOF=1D0
36539 IF(KFF.LE.10) FCOF=3D0
36540 DO 280 I=MMIN1,MMAX1
36541 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36542 IA=IABS(I)
36543 DO 270 J=MMIN2,MMAX2
36544 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36545 JA=IABS(J)
36546 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36547 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36548 & GOTO 270
36549 FCOI=1D0
36550 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36551 WID2=1D0
36552 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36553 & MOD(J,2).EQ.0)) THEN
36554 IF(KFF.EQ.5) WID2=WIDS(6,2)
36555 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36556 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36557 ELSE
36558 IF(KFF.EQ.5) WID2=WIDS(6,3)
36559 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36560 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36561 ENDIF
36562 NCHN=NCHN+1
36563 ISIG(NCHN,1)=I
36564 ISIG(NCHN,2)=J
36565 ISIG(NCHN,3)=1
36566 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36567 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36568 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36569 270 CONTINUE
36570 280 CONTINUE
36571 ENDIF
36572
36573 ELSEIF(ISUB.LE.200) THEN
36574 IF(ISUB.EQ.191) THEN
36575C...q + qbar -> rho_tc0.
36576 KCTC=PYCOMP(KTECHN+113)
36577 SQMRHT=PMAS(KCTC,1)**2
36578 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36579 HS=SHR*WDTP(0)
36580 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36581 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36582 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36583 ALPRHT=2.16D0*(3D0/ITCM(1))
36584 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36585 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36586 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36587 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36588 DO 290 I=MMINA,MMAXA
36589 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36590 IA=IABS(I)
36591 EI=KCHG(IABS(I),1)/3D0
36592 AI=SIGN(1D0,EI+0.1D0)
36593 VI=AI-4D0*EI*XWV
36594 VALI=0.5D0*(VI+AI)
36595 VARI=0.5D0*(VI-AI)
36596 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36597 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36598 IF(IA.LE.10) HI=HI*FACA/3D0
36599 NCHN=NCHN+1
36600 ISIG(NCHN,1)=I
36601 ISIG(NCHN,2)=-I
36602 ISIG(NCHN,3)=1
36603 SIGH(NCHN)=HI*FACBW*HF
36604 290 CONTINUE
36605
36606 ELSEIF(ISUB.EQ.192) THEN
36607C...q + qbar' -> rho_tc+/-.
36608 KCTC=PYCOMP(KTECHN+213)
36609 SQMRHT=PMAS(KCTC,1)**2
36610 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36611 HS=SHR*WDTP(0)
36612 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36613 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36614 ALPRHT=2.16D0*(3D0/ITCM(1))
36615 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36616 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36617 DO 310 I=MMIN1,MMAX1
36618 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36619 IA=IABS(I)
36620 DO 300 J=MMIN2,MMAX2
36621 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36622 JA=IABS(J)
36623 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36624 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36625 & GOTO 300
36626 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36627 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36628 HI=HP
36629 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36630 NCHN=NCHN+1
36631 ISIG(NCHN,1)=I
36632 ISIG(NCHN,2)=J
36633 ISIG(NCHN,3)=1
36634 SIGH(NCHN)=HI*FACBW*HF
36635 300 CONTINUE
36636 310 CONTINUE
36637
36638 ELSEIF(ISUB.EQ.193) THEN
36639C...q + qbar -> omega_tc0.
36640 KCTC=PYCOMP(KTECHN+223)
36641 SQMOMT=PMAS(KCTC,1)**2
36642 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36643 HS=SHR*WDTP(0)
36644 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36645 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36646 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36647 ALPRHT=2.16D0*(3D0/ITCM(1))
36648 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36649 & (2D0*RTCM(2)-1D0)**2
36650 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36651 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36652 DO 320 I=MMINA,MMAXA
36653 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36654 IA=IABS(I)
36655 EI=KCHG(IABS(I),1)/3D0
36656 AI=SIGN(1D0,EI+0.1D0)
36657 VI=AI-4D0*EI*XWV
36658 VALI=0.5D0*(VI+AI)
36659 VARI=0.5D0*(VI-AI)
36660 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36661 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36662 IF(IA.LE.10) HI=HI*FACA/3D0
36663 NCHN=NCHN+1
36664 ISIG(NCHN,1)=I
36665 ISIG(NCHN,2)=-I
36666 ISIG(NCHN,3)=1
36667 SIGH(NCHN)=HI*FACBW*HF
36668 320 CONTINUE
36669
36670 ELSEIF(ISUB.EQ.194) THEN
36671C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36672C...Default final state is e+e-
36673 KFA=KFPR(ISUBSV,1)
36674 ALPRHT=2.16D0*(3D0/ITCM(1))
36675 HP=AEM**2*COMFAC
36676
36677 SN2W=2D0*SQRT(XW*XW1)
36678C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36679C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36680
36681 QUPD=2D0*RTCM(2)-1D0
36682 FAR=SQRT(AEM/ALPRHT)
36683 FAO=FAR*QUPD
36684 FZR=FAR*CT2W
36685 FZO=-FAO*TANW
36686C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36687 FZX=-FAR/SN2W*RTCM(47)
36688 SFAR=FAR**2
36689 SFAO=FAO**2
36690 SFZR=FZR**2
36691 SFZO=FZO**2
36692 SFZX=FZX**2
36693 CALL PYWIDT(23,SH,WDTP,WDTE)
36694 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36695 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36696 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36697 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36698 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36699 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36700 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36701C...Propagator including a_T^0
36702 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36703 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36704C...Add in techni-a contribution
36705 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36706 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36707 $ SFZX*SSMR*SSMO)/DETD/SH
36708 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36709 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36710
36711 XWRHT=1D0/(4D0*XW*(1D0-XW))
36712 KFF=IABS(KFPR(ISUB,1))
36713 EF=KCHG(KFF,1)/3D0
36714 AF=SIGN(1D0,EF+0.1D0)
36715 VF=AF-4D0*EF*XWV
36716 VALF=0.5D0*(VF+AF)
36717 VARF=0.5D0*(VF-AF)
36718 FCOF=1D0
36719 IF(KFF.LE.10) FCOF=3D0
36720
36721 WID2=1D0
36722 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36723 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36724 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36725 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36726
36727 DO 330 I=MMINA,MMAXA
36728 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36729 EI=KCHG(IABS(I),1)/3D0
36730 AI=SIGN(1D0,EI+0.1D0)
36731 VI=AI-4D0*EI*XWV
36732 VALI=0.5D0*(VI+AI)
36733 VARI=0.5D0*(VI-AI)
36734 FCOI=FCOF
36735 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36736 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36737 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36738 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36739 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36740 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36741 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36742 NCHN=NCHN+1
36743 ISIG(NCHN,1)=I
36744 ISIG(NCHN,2)=-I
36745 ISIG(NCHN,3)=1
36746 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36747 330 CONTINUE
36748
36749 ELSEIF(ISUB.EQ.195) THEN
36750C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36751 KFA=KFPR(ISUBSV,1)
36752 KFB=KFA+1
36753 ALPRHT=2.16D0*(3D0/ITCM(1))
36754 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36755
36756 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36757C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36758C
36759C...Propagator including a_T^+
36760 FWX=-FWR*RTCM(47)
36761 CALL PYWIDT(24,SH,WDTP,WDTE)
36762 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36763 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36764 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36765 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36766 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36767 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36768 & DCMPLX(FWX**2,0D0)*SSMR
36769 DWW=SSMR*SSMX/DETD/SH
36770 FCOF=1D0
36771 IF(KFA.LE.8) FCOF=3D0
36772 HP=FACTC*ABS(DWW)**2*FCOF
36773
36774 DO 350 I=MMIN1,MMAX1
36775 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36776 IA=IABS(I)
36777 DO 340 J=MMIN2,MMAX2
36778 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36779 JA=IABS(J)
36780 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36781 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36782 & GOTO 340
36783 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36784 HI=HP
36785 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36786 NCHN=NCHN+1
36787 ISIG(NCHN,1)=I
36788 ISIG(NCHN,2)=J
36789 ISIG(NCHN,3)=1
36790 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36791 340 CONTINUE
36792 350 CONTINUE
36793 ENDIF
36794
36795 ELSEIF(ISUB.LE.380) THEN
36796 ALPRHT=2.16D0*(3D0/ITCM(1))
36797 IF(ISUB.EQ.361) THEN
36798 FAR=SQRT(AEM/ALPRHT)
36799 FAO=FAR*QUPD
36800 FZR=FAR*CT2W
36801 FZO=-FAO*TANW
36802C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36803 FZX=-FAR/SN2W*RTCM(47)
36804 SFAR=FAR**2
36805 SFAO=FAO**2
36806 SFZR=FZR**2
36807 SFZO=FZO**2
36808 SFZX=FZX**2
36809 CALL PYWIDT(23,SH,WDTP,WDTE)
36810 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36811 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36812 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36813 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36814 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36815 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36816 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36817 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36818 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36819C...Add in techni-a contribution
36820 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36821 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36822 $ SFZX*FAR*SSMO)/DETD/SH
36823 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36824 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36825 $ SFZX*FAO*SSMR)/DETD/SH
36826 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36827 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36828 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36829 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36830 $ SFZX*SSMR*SSMO)/DETD/SH
36831 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36832 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36833
36834C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36835C...W+W-, W pi_tc, pi_T pi_T, etc.
36836 FACA=(SH**2*BE34**2-(TH-UH)**2)
36837 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36838 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36839 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36840 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36841 DO 370 I=MMINA,MMAXA
36842 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36843 IA=IABS(I)
36844 EI=KCHG(IABS(I),1)/3D0
36845 AI=SIGN(1D0,EI+0.1D0)
36846 VI=AI-4D0*EI*XWV
36847 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36848 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36849C...........Eqs. (5) and (6) in LSTC-rates.pdf
36850 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36851 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36852 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36853 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36854 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36855 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36856 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36857 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36858 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36859 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36860 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36861C...........Eqs. (5) and (7) in LSTC-rates.pdf
36862 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36863 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36864 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36865 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36866 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36867 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36868 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36869C
36870C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36871C
36872c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36873c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36874c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36875c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36876 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36877 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36878 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36879 HI=HI+HJ+HK
36880 IF(IA.LE.10) HI=HI/3D0
36881 NCHN=NCHN+1
36882 ISIG(NCHN,1)=I
36883 ISIG(NCHN,2)=-I
36884 ISIG(NCHN,3)=1
36885 IF(KFA.EQ.KFB) THEN
36886 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36887 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36888 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36889 NCHN=NCHN+1
36890 ISIG(NCHN,1)=I
36891 ISIG(NCHN,2)=-I
36892 ISIG(NCHN,3)=2
36893 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36894 ELSE
36895 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36896 ENDIF
36897 370 CONTINUE
36898
36899 ELSEIF(ISUB.EQ.370) THEN
36900C...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
36901C...f + fbar' -> gamma pi_tc, etc.
36902 FACA=(SH**2*BE34**2-(TH-UH)**2)
36903 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36904 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36905 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36906 ALPRHT=2.16D0*(3D0/ITCM(1))
36907 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36908 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36909C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36910 FWX=-FWR*RTCM(47)
36911 CALL PYWIDT(24,SH,WDTP,WDTE)
36912 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36913 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36914 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36915 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36916 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36917 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36918 & DCMPLX(FWX**2,0D0)*SSMR
36919 DWW=SSMR*SSMX/DETD/SH
36920 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36921 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36922 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36923 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36924C
36925C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36926C
36927c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36928 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36929C...Add in W_L Z_T axial and vector contributions.
36930 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36931 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36932 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36933 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36934 DO 410 I=MMIN1,MMAX1
36935 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36936 IA=IABS(I)
36937 DO 400 J=MMIN2,MMAX2
36938 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36939 JA=IABS(J)
36940 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36941 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36942 & GOTO 400
36943 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36944 HI=HP
36945 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36946 NCHN=NCHN+1
36947 ISIG(NCHN,1)=I
36948 ISIG(NCHN,2)=J
36949 ISIG(NCHN,3)=1
36950 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36951 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36952 ELSE
36953 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36954 & WIDS(PYCOMP(KFB),2)
36955 ENDIF
36956 400 CONTINUE
36957 410 CONTINUE
36958 ENDIF
36959
36960 ELSEIF(ISUB.LE.390) THEN
36961 IF(ISUB.EQ.381) THEN
36962C...f + f' -> f + f' (g exchange)
36963 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36964 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36965 & MSTP(34)*2D0/3D0*UH2*REDQST)
36966 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36967 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36968 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36969 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36970C...Modifications from contact interactions (compositeness)
36971 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36972 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36973 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36974 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36975 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36976 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36977 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36978 ELSEIF(ITCM(5).EQ.5) THEN
36979 FACCI1=FACQQ1
36980 FACCIB=FACQQB
36981 FACCI2=FACQQ2
36982 FACCI3=FACQQ1
36983CSM.......Check this change from
36984CSM RATCII=1D0
36985 RATCII=RATQQI
36986 ENDIF
36987 DO 430 I=MMIN1,MMAX1
36988 IA=IABS(I)
36989 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36990 DO 420 J=MMIN2,MMAX2
36991 JA=IABS(J)
36992 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36993 NCHN=NCHN+1
36994 ISIG(NCHN,1)=I
36995 ISIG(NCHN,2)=J
36996 ISIG(NCHN,3)=1
36997 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
36998 & JA.GE.3))) THEN
36999 SIGH(NCHN)=FACQQ1
37000 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37001 ELSE
37002 SIGH(NCHN)=FACCI1
37003 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37004 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37005 ENDIF
37006 IF(I.EQ.J) THEN
37007 NCHN=NCHN+1
37008 ISIG(NCHN,1)=I
37009 ISIG(NCHN,2)=J
37010 ISIG(NCHN,3)=2
37011 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37012 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37013 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37014 ELSE
37015 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37016 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37017 ENDIF
37018 ENDIF
37019 420 CONTINUE
37020 430 CONTINUE
37021
37022 ELSEIF(ISUB.EQ.382) THEN
37023C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37024 CALL PYWIDT(21,SH,WDTP,WDTE)
37025 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37026 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37027 IF(ITCM(5).EQ.1) THEN
37028C...Modifications from contact interactions (compositeness)
37029 FACCIB=FACQQB
37030 DO 440 I=1,2
37031 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37032 & WDTE(I,2)+WDTE(I,4))
37033 440 CONTINUE
37034 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37035 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37036 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37037 ELSEIF(ITCM(5).EQ.5) THEN
37038 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37039 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37040 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37041 ENDIF
37042 DO 450 I=MMINA,MMAXA
37043 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37044 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37045 NCHN=NCHN+1
37046 ISIG(NCHN,1)=I
37047 ISIG(NCHN,2)=-I
37048 ISIG(NCHN,3)=1
37049 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37050 SIGH(NCHN)=FACQQB
37051 ELSEIF(ITCM(5).EQ.5) THEN
37052 SIGH(NCHN)=FACQQB
37053 NCHN=NCHN+1
37054 ISIG(NCHN,1)=I
37055 ISIG(NCHN,2)=-I
37056 ISIG(NCHN,3)=2
37057 SIGH(NCHN)=FACCIB
37058 ELSE
37059 SIGH(NCHN)=FACCIB
37060 ENDIF
37061 450 CONTINUE
37062
37063 ELSEIF(ISUB.EQ.383) THEN
37064C...f + fbar -> g + g (q + qbar -> g + g only)
37065 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37066 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37067 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37068 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37069 IF(ITCM(5).EQ.5) THEN
37070 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37071 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37072 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37073 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37074 ENDIF
37075 DO 460 I=MMINA,MMAXA
37076 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37077 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37078 NCHN=NCHN+1
37079 ISIG(NCHN,1)=I
37080 ISIG(NCHN,2)=-I
37081 ISIG(NCHN,3)=1
37082 SIGH(NCHN)=0.5D0*FACGG1
37083 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37084 NCHN=NCHN+1
37085 ISIG(NCHN,1)=I
37086 ISIG(NCHN,2)=-I
37087 ISIG(NCHN,3)=2
37088 SIGH(NCHN)=0.5D0*FACGG2
37089 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37090 460 CONTINUE
37091
37092 ELSEIF(ISUB.EQ.384) THEN
37093C...f + g -> f + g (q + g -> q + g only)
37094 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37095 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37096 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37097 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37098 DO 480 I=MMINA,MMAXA
37099 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37100 DO 470 ISDE=1,2
37101 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37102 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37103 NCHN=NCHN+1
37104 ISIG(NCHN,ISDE)=I
37105 ISIG(NCHN,3-ISDE)=21
37106 ISIG(NCHN,3)=1
37107 SIGH(NCHN)=FACQG1
37108 NCHN=NCHN+1
37109 ISIG(NCHN,ISDE)=I
37110 ISIG(NCHN,3-ISDE)=21
37111 ISIG(NCHN,3)=2
37112 SIGH(NCHN)=FACQG2
37113 470 CONTINUE
37114 480 CONTINUE
37115
37116 ELSEIF(ISUB.EQ.385) THEN
37117C...g + g -> f + fbar (g + g -> q + qbar only)
37118 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37119 IDC0=MDCY(21,2)-1
37120C...Begin by d, u, s flavours.
37121 FLAVWT=0D0
37122 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37123 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37124 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37125 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37126 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37127 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37128 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37129 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37130 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37131 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37132 NCHN=NCHN+1
37133 ISIG(NCHN,1)=21
37134 ISIG(NCHN,2)=21
37135 ISIG(NCHN,3)=1
37136 SIGH(NCHN)=FACQQ1
37137 NCHN=NCHN+1
37138 ISIG(NCHN,1)=21
37139 ISIG(NCHN,2)=21
37140 ISIG(NCHN,3)=2
37141 SIGH(NCHN)=FACQQ2
37142C...Next c and b flavours: modified that and uhat for fixed
37143C...cos(theta-hat).
37144 DO 490 IFL=4,5
37145 SQMAVG=PMAS(IFL,1)**2
37146 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37147 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37148 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37149 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37150 THUHQ=THQ*UHQ-SQMAVG*SH
37151 IF(MSTP(34).EQ.0) THEN
37152 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37153 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37154 ELSE
37155 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37156 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37157 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37158 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37159 ENDIF
37160 IF(ITCM(5).GE.5) THEN
37161 IF(IFL.EQ.4) THEN
37162 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37163 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37164 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37165 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37166 ELSE
37167 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37168 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37169 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37170 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37171 ENDIF
37172 ENDIF
37173 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37174 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37175 NCHN=NCHN+1
37176 ISIG(NCHN,1)=21
37177 ISIG(NCHN,2)=21
37178 ISIG(NCHN,3)=1+2*(IFL-3)
37179 SIGH(NCHN)=FACQQ1
37180 NCHN=NCHN+1
37181 ISIG(NCHN,1)=21
37182 ISIG(NCHN,2)=21
37183 ISIG(NCHN,3)=2+2*(IFL-3)
37184 SIGH(NCHN)=FACQQ2
37185 ENDIF
37186 490 CONTINUE
37187 500 CONTINUE
37188
37189 ELSEIF(ISUB.EQ.386) THEN
37190C...g + g -> g + g
37191 IF(ITCM(5).LE.4) THEN
37192 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37193 & 2D0*TH/SH+TH2/SH2)*FACA
37194 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37195 & 2D0*SH/UH+SH2/UH2)*FACA
37196 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37197 & 2D0*UH/TH+UH2/TH2)
37198 ELSE
37199 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37200 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37201 & 4D0*REDGST*(SH + 2D0*TH)*
37202 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37203 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37204 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37205 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37206 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37207 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37208 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37209 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37210 & 4D0*REDGSU*(SH + 2D0*UH)*
37211 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37212 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37213 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37214 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37215 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37216 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37217 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37218 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37219 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37220 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37221 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37222 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37223 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37224 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37225 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37226 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37227 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37228 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37229 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37230 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37231 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37232 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37233 ENDIF
37234 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37235 NCHN=NCHN+1
37236 ISIG(NCHN,1)=21
37237 ISIG(NCHN,2)=21
37238 ISIG(NCHN,3)=1
37239 SIGH(NCHN)=0.5D0*FACGG1
37240 NCHN=NCHN+1
37241 ISIG(NCHN,1)=21
37242 ISIG(NCHN,2)=21
37243 ISIG(NCHN,3)=2
37244 SIGH(NCHN)=0.5D0*FACGG2
37245 NCHN=NCHN+1
37246 ISIG(NCHN,1)=21
37247 ISIG(NCHN,2)=21
37248 ISIG(NCHN,3)=3
37249 SIGH(NCHN)=0.5D0*FACGG3
37250 510 CONTINUE
37251
37252 ELSEIF(ISUB.EQ.387) THEN
37253C...q + qbar -> Q + Qbar
37254 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37255 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37256 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37257 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37258 & 2D0*SQMAVG/SH)
37259 IF(ITCM(5).GE.5) THEN
37260 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37261 FACQQB=FACQQB*SH2*SQDQTS
37262 ELSE
37263 FACQQB=FACQQB*SH2*SQDQQS
37264 ENDIF
37265 ENDIF
37266 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37267 WID2=1D0
37268 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37269 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37270 FACQQB=FACQQB*WID2
37271 DO 520 I=MMINA,MMAXA
37272 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37273 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37274 NCHN=NCHN+1
37275 ISIG(NCHN,1)=I
37276 ISIG(NCHN,2)=-I
37277 ISIG(NCHN,3)=1
37278 SIGH(NCHN)=FACQQB
37279 520 CONTINUE
37280
37281 ELSEIF(ISUB.EQ.388) THEN
37282C...g + g -> Q + Qbar
37283 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37284 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37285 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37286 THUHQ=THQ*UHQ-SQMAVG*SH
37287 IF(MSTP(34).EQ.0) THEN
37288 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37289 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37290 ELSE
37291 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37292 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37293 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37294 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37295 ENDIF
37296 IF(ITCM(5).GE.5) THEN
37297 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37298 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37299 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37300 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37301 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37302 ELSE
37303 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37304 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37305 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37306 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37307 ENDIF
37308 ENDIF
37309 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37310 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37311 IF(MSTP(35).GE.1) THEN
37312 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37313 FACQQ1=FACQQ1*FATRE
37314 FACQQ2=FACQQ2*FATRE
37315 ENDIF
37316 WID2=1D0
37317 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37318 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37319 FACQQ1=FACQQ1*WID2
37320 FACQQ2=FACQQ2*WID2
37321 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37322 NCHN=NCHN+1
37323 ISIG(NCHN,1)=21
37324 ISIG(NCHN,2)=21
37325 ISIG(NCHN,3)=1
37326 SIGH(NCHN)=FACQQ1
37327 NCHN=NCHN+1
37328 ISIG(NCHN,1)=21
37329 ISIG(NCHN,2)=21
37330 ISIG(NCHN,3)=2
37331 SIGH(NCHN)=FACQQ2
37332 530 CONTINUE
37333 ENDIF
37334 ENDIF
37335
37336CMRENNA--
37337
37338 RETURN
37339 END
37340
37341C*********************************************************************
37342
37343C...PYSGEX
37344C...Subprocess cross sections for assorted exotic processes,
37345C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37346C...Auxiliary to PYSIGH.
37347
37348 SUBROUTINE PYSGEX(NCHN,SIGS)
37349
37350C...Double precision and integer declarations
37351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37352 IMPLICIT INTEGER(I-N)
37353 INTEGER PYK,PYCHGE,PYCOMP
37354C...Parameter statement to help give large particle numbers.
37355 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37356 &KEXCIT=4000000,KDIMEN=5000000)
37357C...Commonblocks
37358 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37359 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37360 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37361 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37362 COMMON/PYINT1/MINT(400),VINT(400)
37363 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37364 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37365 COMMON/PYINT4/MWID(500),WIDS(500,5)
37366 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37367 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37368 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37369 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37370 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37371 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37372 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37373C...Local arrays
37374 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37375
37376C...Differential cross section expressions.
37377
37378 IF(ISUB.LE.160) THEN
37379 IF(ISUB.EQ.141) THEN
37380C...f + fbar -> gamma*/Z0/Z'0
37381 SQMZP=PMAS(32,1)**2
37382 MINT(61)=2
37383 CALL PYWIDT(32,SH,WDTP,WDTE)
37384 HP0=AEM/3D0*SH
37385 HP1=AEM/3D0*XWC*SH
37386 HP2=HP1
37387 HS=SHR*VINT(117)
37388 HSP=SHR*WDTP(0)
37389 FACZP=4D0*COMFAC*3D0
37390 DO 100 I=MMINA,MMAXA
37391 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37392 EI=KCHG(IABS(I),1)/3D0
37393 AI=SIGN(1D0,EI)
37394 VI=AI-4D0*EI*XWV
37395 IA=IABS(I)
37396 IF(IA.LT.10) THEN
37397 IF(IA.LE.2) THEN
37398 VPI=PARU(123-2*MOD(IABS(I),2))
37399 API=PARU(124-2*MOD(IABS(I),2))
37400 ELSEIF(IA.LE.4) THEN
37401 VPI=PARJ(182-2*MOD(IABS(I),2))
37402 API=PARJ(183-2*MOD(IABS(I),2))
37403 ELSE
37404 VPI=PARJ(190-2*MOD(IABS(I),2))
37405 API=PARJ(191-2*MOD(IABS(I),2))
37406 ENDIF
37407 ELSE
37408 IF(IA.LE.12) THEN
37409 VPI=PARU(127-2*MOD(IABS(I),2))
37410 API=PARU(128-2*MOD(IABS(I),2))
37411 ELSEIF(IA.LE.14) THEN
37412 VPI=PARJ(186-2*MOD(IABS(I),2))
37413 API=PARJ(187-2*MOD(IABS(I),2))
37414 ELSE
37415 VPI=PARJ(194-2*MOD(IABS(I),2))
37416 API=PARJ(195-2*MOD(IABS(I),2))
37417 ENDIF
37418 ENDIF
37419 HI0=HP0
37420 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37421 HI1=HP1
37422 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37423 HI2=HP2
37424 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37425 NCHN=NCHN+1
37426 ISIG(NCHN,1)=I
37427 ISIG(NCHN,2)=-I
37428 ISIG(NCHN,3)=1
37429C...Special case: if only branching ratios known then use them.
37430 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37431 HI=0D0
37432 IF(IA.LT.10) THEN
37433 HI=SHR*WDTP(IA)*FACA/9D0
37434 ELSEIF(IA.LT.20) THEN
37435 HI=SHR*WDTP(IA-2)
37436 ENDIF
37437 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37438 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37439 ELSE
37440C...Normal cross section.
37441 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37442 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37443 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37444 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37445 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37446 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37447 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37448 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37449 ENDIF
37450 100 CONTINUE
37451
37452 ELSEIF(ISUB.EQ.142) THEN
37453C...f + fbar' -> W'+/-
37454 SQMWP=PMAS(34,1)**2
37455 CALL PYWIDT(34,SH,WDTP,WDTE)
37456 HS=SHR*WDTP(0)
37457 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37458 HP=AEM/(24D0*XW)*SH
37459 DO 120 I=MMIN1,MMAX1
37460 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37461 IA=IABS(I)
37462 DO 110 J=MMIN2,MMAX2
37463 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37464 JA=IABS(J)
37465 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37466 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37467 & GOTO 110
37468 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37469C...Special case: if only branching ratios known then use them.
37470 IF(MWID(34).EQ.2) THEN
37471 HI=0D0
37472 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37473 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37474 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37475 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37476 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37477 105 CONTINUE
37478 IF(IA.LT.10) HI=HI*FACA/9D0
37479 ELSE
37480C...Normal cross section.
37481 HI=HP*(PARU(133)**2+PARU(134)**2)
37482 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37483 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37484 ENDIF
37485 NCHN=NCHN+1
37486 ISIG(NCHN,1)=I
37487 ISIG(NCHN,2)=J
37488 ISIG(NCHN,3)=1
37489 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37490 SIGH(NCHN)=HI*FACBW*HF
37491 110 CONTINUE
37492 120 CONTINUE
37493
37494 ELSEIF(ISUB.EQ.144) THEN
37495C...f + fbar' -> R
37496 SQMR=PMAS(41,1)**2
37497 CALL PYWIDT(41,SH,WDTP,WDTE)
37498 HS=SHR*WDTP(0)
37499 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37500 HP=AEM/(12D0*XW)*SH
37501 DO 140 I=MMIN1,MMAX1
37502 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37503 IA=IABS(I)
37504 DO 130 J=MMIN2,MMAX2
37505 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37506 JA=IABS(J)
37507 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37508 HI=HP
37509 IF(IA.LE.10) HI=HI*FACA/3D0
37510 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37511 NCHN=NCHN+1
37512 ISIG(NCHN,1)=I
37513 ISIG(NCHN,2)=J
37514 ISIG(NCHN,3)=1
37515 SIGH(NCHN)=HI*FACBW*HF
37516 130 CONTINUE
37517 140 CONTINUE
37518
37519 ELSEIF(ISUB.EQ.145) THEN
37520C...q + l -> LQ (leptoquark)
37521 SQMLQ=PMAS(42,1)**2
37522 CALL PYWIDT(42,SH,WDTP,WDTE)
37523 HS=SHR*WDTP(0)
37524 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37525 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37526 HP=AEM/4D0*SH
37527 KFLQQ=KFDP(MDCY(42,2),1)
37528 KFLQL=KFDP(MDCY(42,2),2)
37529 DO 160 I=MMIN1,MMAX1
37530 IF(KFAC(1,I).EQ.0) GOTO 160
37531 IA=IABS(I)
37532 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37533 DO 150 J=MMIN2,MMAX2
37534 IF(KFAC(2,J).EQ.0) GOTO 150
37535 JA=IABS(J)
37536 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37537 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37538 IF(JA.EQ.IA) GOTO 150
37539 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37540 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37541 HI=HP*PARU(151)
37542 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37543 NCHN=NCHN+1
37544 ISIG(NCHN,1)=I
37545 ISIG(NCHN,2)=J
37546 ISIG(NCHN,3)=1
37547 SIGH(NCHN)=HI*FACBW*HF
37548 150 CONTINUE
37549 160 CONTINUE
37550
37551 ELSEIF(ISUB.EQ.146) THEN
37552C...e + gamma* -> e* (excited lepton)
37553 KFQSTR=KFPR(ISUB,1)
37554 KCQSTR=PYCOMP(KFQSTR)
37555 KFQEXC=MOD(KFQSTR,KEXCIT)
37556 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37557 HS=SHR*WDTP(0)
37558 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37559 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37560 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37561 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37562 & FACBW=0D0
37563 HP=SH
37564 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37565 DO 170 ISDE=1,2
37566 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37567 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37568 HI=HP
37569 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37570 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37571 NCHN=NCHN+1
37572 ISIG(NCHN,ISDE)=I
37573 ISIG(NCHN,3-ISDE)=22
37574 ISIG(NCHN,3)=1
37575 SIGH(NCHN)=HI*FACBW*HF
37576 170 CONTINUE
37577 180 CONTINUE
37578
37579 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37580C...d + g -> d* and u + g -> u* (excited quarks)
37581 KFQSTR=KFPR(ISUB,1)
37582 KCQSTR=PYCOMP(KFQSTR)
37583 KFQEXC=MOD(KFQSTR,KEXCIT)
37584 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37585 HS=SHR*WDTP(0)
37586 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37587 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37588 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37589 & FACBW=0D0
37590 HP=SH
37591 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37592 DO 190 ISDE=1,2
37593 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37594 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37595 HI=HP
37596 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37597 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37598 NCHN=NCHN+1
37599 ISIG(NCHN,ISDE)=I
37600 ISIG(NCHN,3-ISDE)=21
37601 ISIG(NCHN,3)=1
37602 SIGH(NCHN)=HI*FACBW*HF
37603 190 CONTINUE
37604 200 CONTINUE
37605 ENDIF
37606
37607 ELSEIF(ISUB.LE.190) THEN
37608 IF(ISUB.EQ.162) THEN
37609C...q + g -> LQ + lbar; LQ=leptoquark
37610 SQMLQ=PMAS(42,1)**2
37611 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37612 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37613 KFLQQ=KFDP(MDCY(42,2),1)
37614 DO 220 I=MMINA,MMAXA
37615 IF(IABS(I).NE.KFLQQ) GOTO 220
37616 KCHLQ=ISIGN(1,I)
37617 DO 210 ISDE=1,2
37618 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37619 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37620 NCHN=NCHN+1
37621 ISIG(NCHN,ISDE)=I
37622 ISIG(NCHN,3-ISDE)=21
37623 ISIG(NCHN,3)=1
37624 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37625 210 CONTINUE
37626 220 CONTINUE
37627
37628 ELSEIF(ISUB.EQ.163) THEN
37629C...g + g -> LQ + LQbar; LQ=leptoquark
37630 SQMLQ=PMAS(42,1)**2
37631 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37632 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37633 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37634 & ((TH-SQMLQ)*(UH-SQMLQ)))
37635 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37636 NCHN=NCHN+1
37637 ISIG(NCHN,1)=21
37638 ISIG(NCHN,2)=21
37639C...Since don't know proper colour flow, randomize between alternatives
37640 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37641 SIGH(NCHN)=FACLQ
37642 230 CONTINUE
37643
37644 ELSEIF(ISUB.EQ.164) THEN
37645C...q + qbar -> LQ + LQbar; LQ=leptoquark
37646 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37647 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37648 TH=TH-DELTA
37649 UH=UH-DELTA
37650C SQMLQ=PMAS(42,1)**2
37651 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37652 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37653 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37654 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37655 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37656 KFLQQ=KFDP(MDCY(42,2),1)
37657 DO 240 I=MMINA,MMAXA
37658 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37659 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37660 NCHN=NCHN+1
37661 ISIG(NCHN,1)=I
37662 ISIG(NCHN,2)=-I
37663 ISIG(NCHN,3)=1
37664 SIGH(NCHN)=FACLQA
37665 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37666 240 CONTINUE
37667
37668 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37669C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37670 KFQSTR=KFPR(ISUB,2)
37671 KCQSTR=PYCOMP(KFQSTR)
37672 KFQEXC=MOD(KFQSTR,KEXCIT)
37673 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37674 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37675 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37676C...Propagators: as simulated in PYOFSH and as desired
37677 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37678 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37679 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37680 GMMQC=SQRT(SQM4)*WDTP(0)
37681 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37682 FACQSA=FACQSA*HBW4C/HBW4
37683 FACQSB=FACQSB*HBW4C/HBW4
37684C...Branching ratios.
37685 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37686 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37687 DO 260 I=MMIN1,MMAX1
37688 IA=IABS(I)
37689 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37690 DO 250 J=MMIN2,MMAX2
37691 JA=IABS(J)
37692 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37693 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37694 NCHN=NCHN+1
37695 ISIG(NCHN,1)=I
37696 ISIG(NCHN,2)=J
37697 ISIG(NCHN,3)=1
37698 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37699 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37700 NCHN=NCHN+1
37701 ISIG(NCHN,1)=I
37702 ISIG(NCHN,2)=J
37703 ISIG(NCHN,3)=2
37704 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37705 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37706 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37707 NCHN=NCHN+1
37708 ISIG(NCHN,1)=I
37709 ISIG(NCHN,2)=J
37710 ISIG(NCHN,3)=1
37711 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37712 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37713 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37714 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37715 NCHN=NCHN+1
37716 ISIG(NCHN,1)=I
37717 ISIG(NCHN,2)=J
37718 ISIG(NCHN,3)=1
37719 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37720 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37721 NCHN=NCHN+1
37722 ISIG(NCHN,1)=I
37723 ISIG(NCHN,2)=J
37724 ISIG(NCHN,3)=2
37725 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37726 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37727 ELSEIF(I.EQ.-J) THEN
37728 NCHN=NCHN+1
37729 ISIG(NCHN,1)=I
37730 ISIG(NCHN,2)=J
37731 ISIG(NCHN,3)=1
37732 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37733 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37734 NCHN=NCHN+1
37735 ISIG(NCHN,1)=I
37736 ISIG(NCHN,2)=J
37737 ISIG(NCHN,3)=2
37738 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37739 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37740 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37741 NCHN=NCHN+1
37742 ISIG(NCHN,1)=I
37743 ISIG(NCHN,2)=J
37744 ISIG(NCHN,3)=1
37745 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37746 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37747 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37748 ENDIF
37749 250 CONTINUE
37750 260 CONTINUE
37751
37752 ELSEIF(ISUB.EQ.169) THEN
37753C...q + qbar -> e + e* (excited lepton)
37754 KFQSTR=KFPR(ISUB,2)
37755 KCQSTR=PYCOMP(KFQSTR)
37756 KFQEXC=MOD(KFQSTR,KEXCIT)
37757 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37758 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37759C...Propagators: as simulated in PYOFSH and as desired
37760 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37761 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37762 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37763 GMMQC=SQRT(SQM4)*WDTP(0)
37764 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37765 FACQSB=FACQSB*HBW4C/HBW4
37766C...Branching ratios.
37767 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37768 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37769 DO 270 I=MMIN1,MMAX1
37770 IA=IABS(I)
37771 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37772 J=-I
37773 JA=IABS(J)
37774 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37775 NCHN=NCHN+1
37776 ISIG(NCHN,1)=I
37777 ISIG(NCHN,2)=J
37778 ISIG(NCHN,3)=1
37779 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37780 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37781 NCHN=NCHN+1
37782 ISIG(NCHN,1)=I
37783 ISIG(NCHN,2)=J
37784 ISIG(NCHN,3)=2
37785 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37786 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37787 270 CONTINUE
37788 ENDIF
37789
37790 ELSEIF(ISUB.LE.360) THEN
37791 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37792C...l + l -> H_L++/-- or H_R++/--.
37793 KFRES=KFPR(ISUB,1)
37794 KFREC=PYCOMP(KFRES)
37795 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37796 HS=SHR*WDTP(0)
37797 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37798 DO 290 I=MMIN1,MMAX1
37799 IA=IABS(I)
37800 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37801 & GOTO 290
37802 DO 280 J=MMIN2,MMAX2
37803 JA=IABS(J)
37804 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37805 & GOTO 280
37806 IF(I*J.LT.0) GOTO 280
37807 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37808 NCHN=NCHN+1
37809 ISIG(NCHN,1)=I
37810 ISIG(NCHN,2)=J
37811 ISIG(NCHN,3)=1
37812 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37813 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37814 SIGH(NCHN)=HI*FACBW*HF
37815 280 CONTINUE
37816 290 CONTINUE
37817
37818 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37819C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37820 KFRES=KFPR(ISUB,1)
37821 KFREC=PYCOMP(KFRES)
37822C...Propagators: as simulated in PYOFSH and as desired
37823 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37824 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37825 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37826 GMMC=SQRT(SQM3)*WDTP(0)
37827 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37828 FHCC=COMFAC*AEM*HBW3C/HBW3
37829 DO 310 I=MMINA,MMAXA
37830 IA=IABS(I)
37831 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37832 SQML=PMAS(IA,1)**2
37833 J=ISIGN(KFPR(ISUB,2),-I)
37834 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37835 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37836 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37837 & (UH-SQM3)**2
37838 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37839 & (TH-SQM4)*SH)/(TH-SQM4)**2
37840 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37841 & SH)/(SH-SQML)**2
37842 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37843 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37844 & ((UH-SQM3)*(TH-SQM4))
37845 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37846 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37847 & ((UH-SQM3)*(SH-SQML))
37848 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37849 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37850 & ((SH-SQML)*(TH-SQM4))
37851 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37852 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37853 DO 300 ISDE=1,2
37854 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37855 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37856 NCHN=NCHN+1
37857 ISIG(NCHN,ISDE)=I
37858 ISIG(NCHN,3-ISDE)=22
37859 ISIG(NCHN,3)=0
37860 SIGH(NCHN)=FHCC*SMM*WIDSC
37861 300 CONTINUE
37862 310 CONTINUE
37863
37864 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37865C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37866 KFRES=KFPR(ISUB,1)
37867 KFREC=PYCOMP(KFRES)
37868 SQMH=PMAS(KFREC,1)**2
37869 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37870C...Propagators: H++/-- as simulated in PYOFSH and as desired
37871 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37872 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37873 GMMH3=SQRT(SQM3)*WDTP(0)
37874 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37875 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37876 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37877 GMMH4=SQRT(SQM4)*WDTP(0)
37878 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37879C...Kinematical and coupling functions
37880 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37881 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37882C...Loop over allowed flavours
37883 DO 320 I=MMINA,MMAXA
37884 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37885 EI=KCHG(IABS(I),1)/3D0
37886 AI=SIGN(1D0,EI+0.1D0)
37887 VI=AI-4D0*EI*XWV
37888 FCOI=1D0
37889 IF(IABS(I).LE.10) FCOI=FACA/3D0
37890 IF(ISUB.EQ.349) THEN
37891 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37892 IF(IABS(I).LT.10) THEN
37893 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37894 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37895 & (VI**2+AI**2)*XWHH**2*HBWZ)
37896 ELSE
37897 IAOFF=181+3*((IABS(I)-11)/2)
37898 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37899 & (4D0*PARU(1))
37900 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37901 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37902 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37903 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37904 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37905 & 4D0*HSUM**2/TH2
37906 ENDIF
37907 ELSE
37908 IF(IABS(I).LT.10) THEN
37909 DSIGHH=8D0*AEM**2*EI**2/SH2
37910 ELSE
37911 IAOFF=181+3*((IABS(I)-11)/2)
37912 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37913 & (4D0*PARU(1))
37914 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37915 & 4D0*HSUM**2/TH2
37916 ENDIF
37917 ENDIF
37918 NCHN=NCHN+1
37919 ISIG(NCHN,1)=I
37920 ISIG(NCHN,2)=-I
37921 ISIG(NCHN,3)=1
37922 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37923 320 CONTINUE
37924
37925 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37926C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37927 KFRES=KFPR(ISUB,1)
37928 KFREC=PYCOMP(KFRES)
37929 SQMH=PMAS(KFREC,1)**2
37930 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37931 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37932 & PMAS(PYCOMP(9900024),1)**2
37933 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37934 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37935 & (VINT(209)**2-VINT(216)))
37936 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37937 & (VINT(209)**2+2D0*VINT(218)))
37938 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37939 HS=SHR*WDTP(0)
37940 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37941 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37942 & FACBW=0D0
37943 DO 340 I=MMIN1,MMAX1
37944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37945 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37946 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37947 DO 330 J=MMIN2,MMAX2
37948 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37949 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37950 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37951 KCHH=KCHWI+KCHWJ
37952 IF(IABS(KCHH).NE.2) GOTO 330
37953 FACLR=VINT(180+I)*VINT(180+J)
37954 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37955 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37956 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37957 ELSE
37958 FACPRP=FACPRT**2
37959 ENDIF
37960 NCHN=NCHN+1
37961 ISIG(NCHN,1)=I
37962 ISIG(NCHN,2)=J
37963 ISIG(NCHN,3)=1
37964 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37965 330 CONTINUE
37966 340 CONTINUE
37967
37968 ELSEIF(ISUB.EQ.353) THEN
37969C...f + fbar -> Z_R0
37970 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37971 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37972 HS=SHR*WDTP(0)
37973 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37974 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37975 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37976 DO 350 I=MMINA,MMAXA
37977 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37978 IF(IABS(I).LE.8) THEN
37979 EI=KCHG(IABS(I),1)/3D0
37980 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37981 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37982 ELSE
37983 AI=-(1D0-2D0*XW)
37984 VI=-1D0+4D0*XW
37985 ENDIF
37986 HI=HP*(VI**2+AI**2)
37987 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37988 NCHN=NCHN+1
37989 ISIG(NCHN,1)=I
37990 ISIG(NCHN,2)=-I
37991 ISIG(NCHN,3)=1
37992 SIGH(NCHN)=HI*FACBW*HF
37993 350 CONTINUE
37994
37995 ELSEIF(ISUB.EQ.354) THEN
37996C...f + fbar' -> W_R+/-
37997 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37998 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37999 HS=SHR*WDTP(0)
38000 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38001 HP=AEM/(24D0*XW)*SH
38002 DO 370 I=MMIN1,MMAX1
38003 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38004 IA=IABS(I)
38005 DO 360 J=MMIN2,MMAX2
38006 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38007 JA=IABS(J)
38008 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38009 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38010 & GOTO 360
38011 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38012 HI=HP*2D0
38013 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38014 NCHN=NCHN+1
38015 ISIG(NCHN,1)=I
38016 ISIG(NCHN,2)=J
38017 ISIG(NCHN,3)=1
38018 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38019 SIGH(NCHN)=HI*FACBW*HF
38020 360 CONTINUE
38021 370 CONTINUE
38022 ENDIF
38023
38024 ELSEIF(ISUB.LE.400) THEN
38025 IF(ISUB.EQ.391) THEN
38026C...f + fbar -> G*.
38027 KFGSTR=KFPR(ISUB,1)
38028 KCGSTR=PYCOMP(KFGSTR)
38029 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38030 HS=SHR*WDTP(0)
38031 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38032 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38033 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38034C...Modify cross section in wings of peak.
38035 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38036 DO 380 I=MMINA,MMAXA
38037 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38038 HI=1D0
38039 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38040 NCHN=NCHN+1
38041 ISIG(NCHN,1)=I
38042 ISIG(NCHN,2)=-I
38043 ISIG(NCHN,3)=1
38044 SIGH(NCHN)=FACG*HI
38045 380 CONTINUE
38046
38047 ELSEIF(ISUB.EQ.392) THEN
38048C...g + g -> G*.
38049 KFGSTR=KFPR(ISUB,1)
38050 KCGSTR=PYCOMP(KFGSTR)
38051 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38052 HS=SHR*WDTP(0)
38053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38054 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38055 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38056C...Modify cross section in wings of peak.
38057 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38058 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38059 NCHN=NCHN+1
38060 ISIG(NCHN,1)=21
38061 ISIG(NCHN,2)=21
38062 ISIG(NCHN,3)=1
38063 SIGH(NCHN)=FACG
38064 390 CONTINUE
38065
38066 ELSEIF(ISUB.EQ.393) THEN
38067C...q + qbar -> g + G*.
38068 KFGSTR=KFPR(ISUB,2)
38069 KCGSTR=PYCOMP(KFGSTR)
38070 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38071 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38072 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38073 & 2D0*SH2/(TH*UH))
38074C...Propagators: as simulated in PYOFSH and as desired
38075 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38076 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38077 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38078 HS=SQRT(SQM4)*WDTP(0)
38079 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38080 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38081 FACG=FACG*HBW4C/HBW4
38082 DO 400 I=MMINA,MMAXA
38083 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38084 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38085 NCHN=NCHN+1
38086 ISIG(NCHN,1)=I
38087 ISIG(NCHN,2)=-I
38088 ISIG(NCHN,3)=1
38089 SIGH(NCHN)=FACG
38090 400 CONTINUE
38091
38092 ELSEIF(ISUB.EQ.394) THEN
38093C...q + g -> q + G*.
38094 KFGSTR=KFPR(ISUB,2)
38095 KCGSTR=PYCOMP(KFGSTR)
38096 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38097 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38098 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38099 & 2D0*TH2*TH/(UH*SH2))
38100C...Propagators: as simulated in PYOFSH and as desired
38101 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38102 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38103 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38104 HS=SQRT(SQM4)*WDTP(0)
38105 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38106 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38107 FACG=FACG*HBW4C/HBW4
38108 DO 420 I=MMINA,MMAXA
38109 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38110 DO 410 ISDE=1,2
38111 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38112 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38113 NCHN=NCHN+1
38114 ISIG(NCHN,ISDE)=I
38115 ISIG(NCHN,3-ISDE)=21
38116 ISIG(NCHN,3)=1
38117 SIGH(NCHN)=FACG
38118 410 CONTINUE
38119 420 CONTINUE
38120
38121 ELSEIF(ISUB.EQ.395) THEN
38122C...g + g -> g + G*.
38123 KFGSTR=KFPR(ISUB,2)
38124 KCGSTR=PYCOMP(KFGSTR)
38125 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38126 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38127 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38128C...Propagators: as simulated in PYOFSH and as desired
38129 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38130 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38131 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38132 HS=SQRT(SQM4)*WDTP(0)
38133 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38134 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38135 FACG=FACG*HBW4C/HBW4
38136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38137 NCHN=NCHN+1
38138 ISIG(NCHN,1)=21
38139 ISIG(NCHN,2)=21
38140 ISIG(NCHN,3)=1
38141 SIGH(NCHN)=FACG
38142 ENDIF
38143 ENDIF
38144 ENDIF
38145
38146 RETURN
38147 END
38148
38149C*********************************************************************
38150
38151C...PYPDFU
38152C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38153C...parton distributions according to a few different parametrizations.
38154C...Note that what is coded is x times the probability distribution,
38155C...i.e. xq(x,Q2) etc.
38156
38157 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38158
38159C...Double precision and integer declarations.
38160 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38161 IMPLICIT INTEGER(I-N)
38162 INTEGER PYK,PYCHGE,PYCOMP
38163C...Commonblocks.
38164 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38166 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38167 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38168 COMMON/PYINT1/MINT(400),VINT(400)
38169 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38170 &XPDIR(-6:6)
38171 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38172 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38173 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38174 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38175 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38176 &/PYINT9/,/PYINTM/
38177C...Local arrays.
38178 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38179 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38180 SAVE PPAR
38181
38182C...Interface to PDFLIB.
38183 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38184 SAVE /W50513/
38185 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38186 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38187 CHARACTER*20 PARM(20)
38188 DATA VALUE/20*0D0/,PARM/20*' '/
38189
38190C...Data related to Schuler-Sjostrand photon distributions.
38191 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38192
38193C...Valence PDF momentum integral parametrizations PER PARTON!
38194 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38195 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38196 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38197 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38198
38199C...Reset parton distributions.
38200 MINT(92)=0
38201 DO 100 KFL=-25,25
38202 XPQ(KFL)=0D0
38203 100 CONTINUE
38204 DO 110 KFL=-6,6
38205 XPVAL(KFL)=0D0
38206 110 CONTINUE
38207
38208C...Check x and particle species.
38209 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38210 WRITE(MSTU(11),5000) X
38211 GOTO 9999
38212 ENDIF
38213 KFA=IABS(KF)
38214 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38215 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38216 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38217 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38218 &KFA.NE.310.AND.KFA.NE.130) THEN
38219 WRITE(MSTU(11),5100) KF
38220 GOTO 9999
38221 ENDIF
38222
38223C...Electron (or muon or tau) parton distribution call.
38224 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38225 CALL PYPDEL(KFA,X,Q2,XPEL)
38226 DO 120 KFL=-25,25
38227 XPQ(KFL)=XPEL(KFL)
38228 120 CONTINUE
38229
38230C...Photon parton distribution call (VDM+anomalous).
38231 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38232 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38233 CALL PYPDGA(X,Q2,XPGA)
38234 DO 130 KFL=-6,6
38235 XPQ(KFL)=XPGA(KFL)
38236 130 CONTINUE
38237 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38238 XPVAL(1)=XPVU/4D0
38239 XPVAL(2)=XPVU
38240 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38241 XPVAL(4)=MIN(XPQ(4),XPVU)
38242 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38243 XPVAL(-1)=XPVAL(1)
38244 XPVAL(-2)=XPVAL(2)
38245 XPVAL(-3)=XPVAL(3)
38246 XPVAL(-4)=XPVAL(4)
38247 XPVAL(-5)=XPVAL(5)
38248 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38249 Q2MX=Q2
38250 P2MX=0.36D0
38251 IF(MSTP(55).GE.7) P2MX=4.0D0
38252 IF(MSTP(57).EQ.0) Q2MX=P2MX
38253 P2=0D0
38254 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38255 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38256 DO 140 KFL=-6,6
38257 XPQ(KFL)=XPGA(KFL)
38258 XPVAL(KFL)=VXPDGM(KFL)
38259 140 CONTINUE
38260 VINT(231)=P2MX
38261 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38262 Q2MX=Q2
38263 P2MX=0.36D0
38264 IF(MSTP(55).GE.11) P2MX=4.0D0
38265 IF(MSTP(57).EQ.0) Q2MX=P2MX
38266 P2=0D0
38267 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38268 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38269 DO 150 KFL=-6,6
38270 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38271 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38272 150 CONTINUE
38273 VINT(231)=P2MX
38274 ELSEIF(MSTP(56).EQ.2) THEN
38275C...Call PDFLIB parton distributions.
38276 PARM(1)='NPTYPE'
38277 VALUE(1)=3
38278 PARM(2)='NGROUP'
38279 VALUE(2)=MSTP(55)/1000
38280 PARM(3)='NSET'
38281 VALUE(3)=MOD(MSTP(55),1000)
38282 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38283 CALL PDFSET_ALICE(PARM,VALUE)
38284 MINT(93)=3000000+MSTP(55)
38285 ENDIF
38286 XX=X
38287 QQ2=MAX(0D0,Q2MIN,Q2)
38288 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38289 P2=0D0
38290 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38291 IP2=MSTP(60)
38292 IF(MSTP(55).EQ.5004) THEN
38293 IF(5D0*P2.LT.QQ2.AND.
38294 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38295 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38296 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38297 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38298 & BOT,TOP,GLU)
38299 ELSE
38300 UPV=0D0
38301 DNV=0D0
38302 USEA=0D0
38303 DSEA=0D0
38304 STR=0D0
38305 CHM=0D0
38306 BOT=0D0
38307 TOP=0D0
38308 GLU=0D0
38309 ENDIF
38310 ELSE
38311 IF(P2.LT.QQ2) THEN
38312 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38313 & BOT,TOP,GLU)
38314 ELSE
38315 UPV=0D0
38316 DNV=0D0
38317 USEA=0D0
38318 DSEA=0D0
38319 STR=0D0
38320 CHM=0D0
38321 BOT=0D0
38322 TOP=0D0
38323 GLU=0D0
38324 ENDIF
38325 ENDIF
38326 VINT(231)=Q2MIN
38327 XPQ(0)=GLU
38328 XPQ(1)=DNV
38329 XPQ(-1)=DNV
38330 XPQ(2)=UPV
38331 XPQ(-2)=UPV
38332 XPQ(3)=STR
38333 XPQ(-3)=STR
38334 XPQ(4)=CHM
38335 XPQ(-4)=CHM
38336 XPQ(5)=BOT
38337 XPQ(-5)=BOT
38338 XPQ(6)=TOP
38339 XPQ(-6)=TOP
38340 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38341 XPVAL(1)=XPVU/4D0
38342 XPVAL(2)=XPVU
38343 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38344 XPVAL(4)=MIN(XPQ(4),XPVU)
38345 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38346 XPVAL(-1)=XPVAL(1)
38347 XPVAL(-2)=XPVAL(2)
38348 XPVAL(-3)=XPVAL(3)
38349 XPVAL(-4)=XPVAL(4)
38350 XPVAL(-5)=XPVAL(5)
38351 ELSE
38352 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38353 ENDIF
38354
38355C...Pion/gammaVDM parton distribution call.
38356 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38357 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38358 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38359 & MSTP(55).LE.12) THEN
38360 ISET=1+MOD(MSTP(55)-1,4)
38361 Q2MX=Q2
38362 P2MX=0.36D0
38363 IF(ISET.GE.3) P2MX=4.0D0
38364 IF(MSTP(57).EQ.0) Q2MX=P2MX
38365 P2=0D0
38366 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38367 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38368 DO 160 KFL=-6,6
38369 XPQ(KFL)=XPVMD(KFL)
38370 XPVAL(KFL)=VXPVMD(KFL)
38371 160 CONTINUE
38372 VINT(231)=P2MX
38373 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38374 CALL PYPDPI(X,Q2,XPPI)
38375 DO 170 KFL=-6,6
38376 XPQ(KFL)=XPPI(KFL)
38377 170 CONTINUE
38378 XPVAL(2)=XPQ(2)-XPQ(-2)
38379 XPVAL(-1)=XPQ(-1)-XPQ(1)
38380 ELSEIF(MSTP(54).EQ.2) THEN
38381C...Call PDFLIB parton distributions.
38382 PARM(1)='NPTYPE'
38383 VALUE(1)=2
38384 PARM(2)='NGROUP'
38385 VALUE(2)=MSTP(53)/1000
38386 PARM(3)='NSET'
38387 VALUE(3)=MOD(MSTP(53),1000)
38388 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38389 CALL PDFSET_ALICE(PARM,VALUE)
38390 MINT(93)=2000000+MSTP(53)
38391 ENDIF
38392 XX=X
38393 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38394 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38395 CALL STRUCTM_ALICE
38396 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38397 VINT(231)=Q2MIN
38398 XPQ(0)=GLU
38399 XPQ(1)=DSEA
38400 XPQ(-1)=UPV+DSEA
38401 XPQ(2)=UPV+USEA
38402 XPQ(-2)=USEA
38403 XPQ(3)=STR
38404 XPQ(-3)=STR
38405 XPQ(4)=CHM
38406 XPQ(-4)=CHM
38407 XPQ(5)=BOT
38408 XPQ(-5)=BOT
38409 XPQ(6)=TOP
38410 XPQ(-6)=TOP
38411 XPVAL(2)=UPV
38412 XPVAL(-1)=UPV
38413 ELSE
38414 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38415 ENDIF
38416
38417C...Anomalous photon parton distribution call.
38418 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38419 Q2MX=Q2
38420 P2MX=PARP(15)**2
38421 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38422 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38423 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38424 IF(MSTP(57).EQ.0) Q2MX=P2MX
38425 P2=0D0
38426 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38427 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38428 DO 180 KFL=-6,6
38429 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38430 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38431 180 CONTINUE
38432 VINT(231)=P2MX
38433 ELSEIF(MSTP(56).EQ.1) THEN
38434 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38435 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38436 IF(MSTP(57).EQ.0) Q2MX=P2MX
38437 P2=0D0
38438 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38439 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38440 DO 190 KFL=-6,6
38441 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38442 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38443 190 CONTINUE
38444 VINT(231)=P2MX
38445 ELSEIF(MSTP(56).EQ.2) THEN
38446 IF(MSTP(57).EQ.0) Q2MX=P2MX
38447 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38448 DO 200 KFL=-6,6
38449 XPQ(KFL)=XPGA(KFL)
38450 XPVAL(KFL)=VXPGA(KFL)
38451 200 CONTINUE
38452 VINT(231)=P2MX
38453 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38454 IF(MSTP(57).EQ.0) Q2MX=P2MX
38455 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38456 DO 210 KFL=-6,6
38457 XPQ(KFL)=XPGA(KFL)
38458 XPVAL(KFL)=VXPGA(KFL)
38459 210 CONTINUE
38460 VINT(231)=P2MX
38461 ELSE
38462 220 RKF=11D0*PYR(0)
38463 KFR=1
38464 IF(RKF.GT.1D0) KFR=2
38465 IF(RKF.GT.5D0) KFR=3
38466 IF(RKF.GT.6D0) KFR=4
38467 IF(RKF.GT.10D0) KFR=5
38468 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38469 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38470 IF(MSTP(57).EQ.0) Q2MX=P2MX
38471 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38472 DO 230 KFL=-6,6
38473 XPQ(KFL)=XPGA(KFL)
38474 XPVAL(KFL)=VXPGA(KFL)
38475 230 CONTINUE
38476 VINT(231)=P2MX
38477 ENDIF
38478
38479C...Proton parton distribution call.
38480 ELSE
38481 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38482 CALL PYPDPR(X,Q2,XPPR)
38483 DO 240 KFL=-6,6
38484 XPQ(KFL)=XPPR(KFL)
38485 240 CONTINUE
38486C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38487 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38488 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38489 ELSEIF(MSTP(52).EQ.2) THEN
38490C...Call PDFLIB parton distributions.
38491 PARM(1)='NPTYPE'
38492 VALUE(1)=1
38493 PARM(2)='NGROUP'
38494 VALUE(2)=MSTP(51)/1000
38495 PARM(3)='NSET'
38496 VALUE(3)=MOD(MSTP(51),1000)
38497 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38498 CALL PDFSET_ALICE(PARM,VALUE)
38499 MINT(93)=1000000+MSTP(51)
38500 ENDIF
38501 XX=X
38502 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38503 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38504 CALL STRUCTM_ALICE(
38505 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38506 VINT(231)=Q2MIN
38507 XPQ(0)=GLU
38508 XPQ(1)=DNV+DSEA
38509 XPQ(-1)=DSEA
38510 XPQ(2)=UPV+USEA
38511 XPQ(-2)=USEA
38512 XPQ(3)=STR
38513 XPQ(-3)=STR
38514 XPQ(4)=CHM
38515 XPQ(-4)=CHM
38516 XPQ(5)=BOT
38517 XPQ(-5)=BOT
38518 XPQ(6)=TOP
38519 XPQ(-6)=TOP
38520 XPVAL(1)=DNV
38521 XPVAL(2)=UPV
38522 ELSE
38523 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38524 ENDIF
38525 ENDIF
38526
38527C...Isospin average for pi0/gammaVDM.
38528 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38529 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38530 XPV=XPQ(2)-XPQ(1)
38531 XPQ(2)=XPQ(1)
38532 XPQ(-2)=XPQ(-1)
38533 ELSE
38534 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38535 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38536 XPQ(2)=XPS
38537 XPQ(-1)=XPS
38538 ENDIF
38539 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38540 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38541 DO 250 KFL=-6,6
38542 XPVAL(KFL)=0D0
38543 250 CONTINUE
38544 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38545 XPQ(1)=XPQ(1)+0.2D0*XPV
38546 XPQ(2)=XPQ(2)+0.8D0*XPV
38547 XPVAL(1)=0.2D0*XPVL
38548 XPVAL(2)=0.8D0*XPVL
38549 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38550 XPQ(3)=XPQ(3)+XPV
38551 XPVAL(3)=XPVL
38552 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38553 XPQ(4)=XPQ(4)+XPV
38554 XPVAL(4)=XPVL
38555 IF(MSTP(55).GE.9) THEN
38556 DO 260 KFL=-6,6
38557 XPQ(KFL)=0D0
38558 260 CONTINUE
38559 ENDIF
38560 ELSE
38561 XPQ(1)=XPQ(1)+0.5D0*XPV
38562 XPQ(2)=XPQ(2)+0.5D0*XPV
38563 XPVAL(1)=0.5D0*XPVL
38564 XPVAL(2)=0.5D0*XPVL
38565 ENDIF
38566 DO 270 KFL=1,6
38567 XPQ(-KFL)=XPQ(KFL)
38568 XPVAL(-KFL)=XPVAL(KFL)
38569 270 CONTINUE
38570
38571C...Rescale for gammaVDM by effective gamma -> rho coupling.
38572C+++Do not rescale?
38573 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38574 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38575 DO 280 KFL=-6,6
38576 XPQ(KFL)=VINT(281)*XPQ(KFL)
38577 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38578 280 CONTINUE
38579 VINT(232)=VINT(281)*XPV
38580 ENDIF
38581
38582C...Simple recipes for kaons.
38583 ELSEIF(KFA.EQ.321) THEN
38584 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38585 XPQ(-1)=XPQ(1)
38586 XPVAL(-3)=XPVAL(-1)
38587 XPVAL(-1)=0D0
38588 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38589 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38590 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38591 XPQ(2)=XPS
38592 XPQ(-1)=XPS
38593 XPQ(1)=XPQ(1)+0.5D0*XPV
38594 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38595 XPQ(3)=XPQ(3)+0.5D0*XPV
38596 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38597 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38598 XPVAL(2)=0D0
38599 XPVAL(-1)=0D0
38600 XPVAL(1)=0.5D0*XPV
38601 XPVAL(-1)=0.5D0*XPV
38602 XPVAL(3)=0.5D0*XPV
38603 XPVAL(-3)=0.5D0*XPV
38604
38605C...Isospin conjugation for neutron.
38606 ELSEIF(KFA.EQ.2112) THEN
38607 XPSV=XPQ(1)
38608 XPQ(1)=XPQ(2)
38609 XPQ(2)=XPSV
38610 XPSV=XPQ(-1)
38611 XPQ(-1)=XPQ(-2)
38612 XPQ(-2)=XPSV
38613 XPSV=XPVAL(1)
38614 XPVAL(1)=XPVAL(2)
38615 XPVAL(2)=XPSV
38616
38617C...Simple recipes for hyperon (average valence parton distribution).
38618 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38619 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38620 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38621 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38622 XPQ(1)=XPS
38623 XPQ(2)=XPS
38624 XPQ(-1)=XPS
38625 XPQ(-2)=XPS
38626 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38627 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38628 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38629 XPV=(XPVAL(1)+XPVAL(2))/3D0
38630 XPVAL(1)=0D0
38631 XPVAL(2)=0D0
38632 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38633 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38634 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38635 ENDIF
38636
38637C...Charge conjugation for antiparticle.
38638 IF(KF.LT.0) THEN
38639 DO 290 KFL=1,25
38640 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38641 XPSV=XPQ(KFL)
38642 XPQ(KFL)=XPQ(-KFL)
38643 XPQ(-KFL)=XPSV
38644 290 CONTINUE
38645 DO 300 KFL=1,6
38646 XPSV=XPVAL(KFL)
38647 XPVAL(KFL)=XPVAL(-KFL)
38648 XPVAL(-KFL)=XPSV
38649 300 CONTINUE
38650 ENDIF
38651
38652C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38653C...Set side.
38654 JS=MINT(30)
38655C...Only reshape PDFs for the non-first interactions;
38656C...But need valence/sea separation already from first interaction.
38657 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38658 KFVSEL=KFIVAL(JS,1)
38659C...If valence quark kicked out of pi0 or gamma then that decides
38660C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38661 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38662 XPVL=0D0
38663 DO 310 KFL=1,6
38664 XPVL=XPVL+XPVAL(KFL)
38665 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38666 XPVAL(KFL)=0D0
38667 310 CONTINUE
38668 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38669 XPVAL(IABS(KFVSEL))=XPVL
38670 DO 320 KFL=1,6
38671 XPQ(-KFL)=XPQ(KFL)
38672 XPVAL(-KFL)=XPVAL(KFL)
38673 320 CONTINUE
38674
38675C...If valence quark kicked out of K0S or K0S then that decides whether
38676C...we should consider state as d sbar or s dbar.
38677 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38678 KFS=1
38679 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38680 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38681 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38682 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38683 XPVAL(-KFS)=0D0
38684 KFS=-3*KFS
38685 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38686 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38687 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38688 XPVAL(-KFS)=0D0
38689 ENDIF
38690
38691C...XPQ distributions are nominal for a (signed) beam particle
38692C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38693 CMPFAC=1D0
38694 NRESC=0
38695 345 NRESC=NRESC+1
38696 PVCTOT(JS,-1)=0D0
38697 PVCTOT(JS, 0)=0D0
38698 PVCTOT(JS, 1)=0D0
38699 DO 350 IFL=-6,6
38700 IF(IFL.EQ.0) GOTO 350
38701
38702C...Count up number of original IFL valence quarks.
38703 IVORG=0
38704 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38705 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38706 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38707C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38708C...bookkeep as if d dbar (for total momentum sum in valence sector).
38709 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38710C...Count down number of remaining IFL valence quarks. Skip current
38711C...interaction initiator.
38712 IVREM=IVORG
38713 DO 330 I1=1,NMI(JS)
38714 IF (I1.EQ.MINT(36)) GOTO 330
38715 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38716 & IVREM=IVREM-1
38717 330 CONTINUE
38718
38719C...Separate out original VALENCE and SEA content.
38720 VAL=XPVAL(IFL)
38721 SEA=MAX(0D0,XPQ(IFL)-VAL)
38722 XPSVC(IFL,0)=VAL
38723 XPSVC(IFL,-1)=SEA
38724
38725C...Rescale valence content if changed.
38726 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38727 & (VAL*IVREM)/IVORG
38728
38729C...Momentum integrals of original and removed valence quarks.
38730 IF(IVORG.NE.0) THEN
38731C...For p/n/pbar/nbar beams can split into d_val and u_val.
38732C...Isospin conjugation for neutrons
38733 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38734 IAFLP=IABS(IFL)
38735 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38736 VPAVG=PAVG(IAFLP,Q2)
38737C...For other baryons average d_val and u_val, like for PDFs.
38738 ELSEIF(KFA.GT.1000) THEN
38739 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38740C...For mesons and photon average d_val and u_val and scale by 3/2.
38741C...Very crude, especially for photon.
38742 ELSE
38743 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38744 ENDIF
38745 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38746 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38747 ENDIF
38748
38749C...Now add companions (at X with partner having been at Z=XASSOC).
38750C...NOTE: due to the assumed simple x scaling, the partner was at what
38751C...corresponds to a higher Z than XASSOC, if there were intermediate
38752C...scatterings. Nothing done about that for the moment.
38753 DO 340 IVC=1,NVC(JS,IFL)
38754C...Skip companions that have been kicked out
38755 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38756 XPSVC(IFL,IVC)=0D0
38757 GOTO 340
38758 ELSE
38759C...Momentum fraction of the partner quark.
38760C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38761 XS=XASSOC(JS,IFL,IVC)
38762 XREM=VINT(142+JS)
38763 YS=XS/(XREM+XS)
38764C...Momentum fraction of the companion quark.
38765C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38766 Y=X*(1D0-YS)
38767 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38768C...Add to momentum sum, with rescaling compensation factor.
38769 XCFAC=(XREM+XS)/XREM*CMPFAC
38770 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38771 ENDIF
38772 340 CONTINUE
38773 350 CONTINUE
38774
38775C...Wait until all flavours treated, then rescale seas and gluon.
38776 XPSVC(0,-1)=XPQ(0)
38777 XPSVC(0,0)=0D0
38778 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38779 IF (RSFAC.LE.0D0) THEN
38780C...First calculate factor needed to exactly restore pz cons.
38781 IF (NRESC.EQ.1) CMPFAC =
38782 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38783C...Add a bit of headroom
38784 CMPFAC=0.99*CMPFAC
38785C...Try a few times if more headroom is needed, then print error message.
38786 IF (NRESC.LE.10) GOTO 345
38787 CALL PYERRM(15,
38788 & '(PYPDFU:) Negative reshaping factor persists!')
38789 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38790 RSFAC=0D0
38791 ENDIF
38792 DO 370 IFL=-6,6
38793 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38794C...Also store resulting distributions in XPQ
38795 XPQ(IFL)=0D0
38796 DO 360 ISVC=-1,NVC(JS,IFL)
38797 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38798 360 CONTINUE
38799 370 CONTINUE
38800C...Save companion reweighting factor for PYPTIS.
38801 VINT(140)=CMPFAC
38802 ENDIF
38803
38804
38805C...Allow gluon also in position 21.
38806 XPQ(21)=XPQ(0)
38807
38808C...Check positivity and reset above maximum allowed flavour.
38809 DO 380 KFL=-25,25
38810 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38811 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38812 380 CONTINUE
38813
38814C...Formats for error printouts.
38815 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38816 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38817 &' KF =',I5)
38818 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38819 &3I5)
38820 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38821 & ' Removed valence momentum fraction : ',F6.3/
38822 & ' Added companion momentum fraction : ',F6.3/
38823 & ' Resulting rescale factor : ',F6.3)
38824
38825C...Reset side pointer and return
38826 9999 MINT(30)=0
38827
38828 RETURN
38829 END
38830
38831C*********************************************************************
38832
38833C...PYPDFL
38834C...Gives proton parton distribution at small x and/or Q^2 according to
38835C...correct limiting behaviour.
38836
38837 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38838
38839C...Double precision and integer declarations.
38840 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38841 IMPLICIT INTEGER(I-N)
38842 INTEGER PYK,PYCHGE,PYCOMP
38843C...Commonblocks.
38844 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38845 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38846 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38847 COMMON/PYINT1/MINT(400),VINT(400)
38848 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38849C...Local arrays.
38850 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38851 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38852
38853C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38854 MINT(92)=0
38855 KFA=IABS(KF)
38856 IACC=0
38857 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38858 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38859 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38860 IF(IACC.EQ.0) THEN
38861 CALL PYPDFU(KF,X,Q2,XPQ)
38862 RETURN
38863 ENDIF
38864
38865C...Reset. Check x.
38866 DO 100 KFL=-25,25
38867 XPQ(KFL)=0D0
38868 100 CONTINUE
38869 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38870 WRITE(MSTU(11),5000) X
38871 RETURN
38872 ENDIF
38873
38874C...Define valence content.
38875 KFC=KF
38876 NV1=2
38877 NV2=1
38878 IF(KF.EQ.2212) THEN
38879 KFV1=2
38880 KFV2=1
38881 ELSEIF(KF.EQ.-2212) THEN
38882 KFV1=-2
38883 KFV2=-1
38884 ELSEIF(KF.EQ.2112) THEN
38885 KFV1=1
38886 KFV2=2
38887 ELSEIF(KF.EQ.-2112) THEN
38888 KFV1=-1
38889 KFV2=-2
38890 ELSEIF(KF.EQ.211) THEN
38891 NV1=1
38892 KFV1=2
38893 KFV2=-1
38894 ELSEIF(KF.EQ.-211) THEN
38895 NV1=1
38896 KFV1=-2
38897 KFV2=1
38898 ELSEIF(MINT(105).LE.223) THEN
38899 KFV1=1
38900 WTV1=0.2D0
38901 KFV2=2
38902 WTV2=0.8D0
38903 ELSEIF(MINT(105).EQ.333) THEN
38904 KFV1=3
38905 WTV1=1.0D0
38906 KFV2=1
38907 WTV2=0.0D0
38908 ELSEIF(MINT(105).EQ.443) THEN
38909 KFV1=4
38910 WTV1=1.0D0
38911 KFV2=1
38912 WTV2=0.0D0
38913 ENDIF
38914
38915C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38916 MINT30=MINT(30)
38917 CALL PYPDFU(KFC,X,Q2,XPA)
38918 Q2MN=MAX(3D0,VINT(231))
38919 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38920 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38921
38922C...Large Q2 and large x: naive call is enough.
38923 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38924 DO 110 KFL=-25,25
38925 XPQ(KFL)=XPA(KFL)
38926 110 CONTINUE
38927 MINT(92)=1
38928
38929C...Small Q2 and large x: dampen boundary value.
38930 ELSEIF(X.GT.XMN) THEN
38931
38932C...Evaluate at boundary and define dampening factors.
38933 MINT(30)=MINT30
38934 CALL PYPDFU(KFC,X,Q2MN,XPA)
38935 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38936 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38937
38938C...Separate valence and sea parts of parton distribution.
38939 IF(KFA.NE.22) THEN
38940 XFV1=XPA(KFV1)-XPA(-KFV1)
38941 XPA(KFV1)=XPA(-KFV1)
38942 XFV2=XPA(KFV2)-XPA(-KFV2)
38943 XPA(KFV2)=XPA(-KFV2)
38944 ELSE
38945 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38946 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38947 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38948 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38949 ENDIF
38950
38951C...Dampen valence and sea separately. Put back together.
38952 DO 120 KFL=-25,25
38953 XPQ(KFL)=FS*XPA(KFL)
38954 120 CONTINUE
38955 IF(KFA.NE.22) THEN
38956 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38957 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38958 ELSE
38959 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38960 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38961 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38962 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38963 ENDIF
38964 MINT(92)=2
38965
38966C...Large Q2 and small x: interpolate behaviour.
38967 ELSEIF(Q2.GT.Q2MN) THEN
38968
38969C...Evaluate at extremes and define coefficients for interpolation.
38970 MINT(30)=MINT30
38971 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38972 VI232A=VINT(232)
38973 MINT(30)=MINT30
38974 CALL PYPDFU(KFC,X,Q2B,XPB)
38975 VI232B=VINT(232)
38976 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38977 FVA=(X/XMN)**0.45D0*FLA
38978 FSA=(X/XMN)**(-0.08D0)*FLA
38979 FB=1D0-FLA
38980
38981C...Separate valence and sea parts of parton distribution.
38982 IF(KFA.NE.22) THEN
38983 XFVA1=XPA(KFV1)-XPA(-KFV1)
38984 XPA(KFV1)=XPA(-KFV1)
38985 XFVA2=XPA(KFV2)-XPA(-KFV2)
38986 XPA(KFV2)=XPA(-KFV2)
38987 XFVB1=XPB(KFV1)-XPB(-KFV1)
38988 XPB(KFV1)=XPB(-KFV1)
38989 XFVB2=XPB(KFV2)-XPB(-KFV2)
38990 XPB(KFV2)=XPB(-KFV2)
38991 ELSE
38992 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
38993 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
38994 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
38995 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
38996 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
38997 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
38998 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
38999 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39000 ENDIF
39001
39002C...Interpolate for valence and sea. Put back together.
39003 DO 130 KFL=-25,25
39004 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39005 130 CONTINUE
39006 IF(KFA.NE.22) THEN
39007 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39008 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39009 ELSE
39010 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39011 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39012 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39013 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39014 ENDIF
39015 MINT(92)=3
39016
39017C...Small Q2 and small x: dampen boundary value and add term.
39018 ELSE
39019
39020C...Evaluate at boundary and define dampening factors.
39021 MINT(30)=MINT30
39022 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39023 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39024 FA=1D0-FB
39025 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39026 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39027 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39028 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39029 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39030 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39031
39032C...Separate valence and sea parts of parton distribution.
39033 IF(KFA.NE.22) THEN
39034 XFV1=XPA(KFV1)-XPA(-KFV1)
39035 XPA(KFV1)=XPA(-KFV1)
39036 XFV2=XPA(KFV2)-XPA(-KFV2)
39037 XPA(KFV2)=XPA(-KFV2)
39038 ELSE
39039 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39040 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39041 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39042 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39043 ENDIF
39044
39045C...Dampen valence and sea separately. Add constant terms.
39046C...Put back together.
39047 DO 140 KFL=-25,25
39048 XPQ(KFL)=FSA*XPA(KFL)
39049 140 CONTINUE
39050 IF(KFA.NE.22) THEN
39051 DO 150 KFL=-3,3
39052 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39053 150 CONTINUE
39054 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39055 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39056 ELSE
39057 DO 160 KFL=-3,3
39058 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39059 160 CONTINUE
39060 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39061 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39062 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39063 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39064 ENDIF
39065 XPQ(21)=XPQ(0)
39066 MINT(92)=4
39067 ENDIF
39068
39069C...Format for error printout.
39070 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39071
39072 RETURN
39073 END
39074
39075C*********************************************************************
39076
39077C...PYPDEL
39078C...Gives electron (or muon, or tau) parton distribution.
39079
39080 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39081
39082C...Double precision and integer declarations.
39083 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39084 IMPLICIT INTEGER(I-N)
39085 INTEGER PYK,PYCHGE,PYCOMP
39086C...Commonblocks.
39087 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39088 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39090 COMMON/PYINT1/MINT(400),VINT(400)
39091 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39092C...Local arrays.
39093 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39094
39095C...Interface to PDFLIB.
39096 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39097 SAVE /W50513/
39098 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39099 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39100 CHARACTER*20 PARM(20)
39101 DATA VALUE/20*0D0/,PARM/20*' '/
39102
39103C...Some common constants.
39104 DO 100 KFL=-25,25
39105 XPEL(KFL)=0D0
39106 100 CONTINUE
39107 AEM=PARU(101)
39108 PME=PMAS(11,1)
39109 IF(KFA.EQ.13) PME=PMAS(13,1)
39110 IF(KFA.EQ.15) PME=PMAS(15,1)
39111 XL=LOG(MAX(1D-10,X))
39112 X1L=LOG(MAX(1D-10,1D0-X))
39113 HLE=LOG(MAX(3D0,Q2/PME**2))
39114 HBE2=(AEM/PARU(1))*(HLE-1D0)
39115
39116C...Electron inside electron, see R. Kleiss et al., in Z physics at
39117C...LEP 1, CERN 89-08, p. 34
39118 IF(MSTP(59).LE.1) THEN
39119 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39120 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39121 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39122 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39123 & 4D0*XL/(1D0-X)-5D0-X)
39124 ELSE
39125 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39126 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39127 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39128 ENDIF
39129C...Zero distribution for very large x and rescale it for intermediate.
39130 IF(X.GT.1D0-1D-10) THEN
39131 HEE=0D0
39132 ELSEIF(X.GT.1D0-1D-7) THEN
39133 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39134 ENDIF
39135 XPEL(KFA)=X*HEE
39136
39137C...Photon and (transverse) W- inside electron.
39138 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39139 IF(MSTP(13).LE.1) THEN
39140 HLG=HLE
39141 ELSE
39142 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39143 ENDIF
39144 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39145 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39146 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39147
39148C...Electron or positron inside photon inside electron.
39149 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39150 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39151 & 2D0*X*(1D0+X)*XL)
39152 XPEL(11)=XPEL(11)+XFSEA
39153 XPEL(-11)=XFSEA
39154
39155C...Initialize PDFLIB photon parton distributions.
39156 IF(MSTP(56).EQ.2) THEN
39157 PARM(1)='NPTYPE'
39158 VALUE(1)=3
39159 PARM(2)='NGROUP'
39160 VALUE(2)=MSTP(55)/1000
39161 PARM(3)='NSET'
39162 VALUE(3)=MOD(MSTP(55),1000)
39163 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39164 CALL PDFSET_ALICE(PARM,VALUE)
39165 MINT(93)=3000000+MSTP(55)
39166 ENDIF
39167 ENDIF
39168
39169C...Quarks and gluons inside photon inside electron:
39170C...numerical convolution required.
39171 DO 110 KFL=0,6
39172 SXP(KFL)=0D0
39173 110 CONTINUE
39174 SUMXPP=0D0
39175 ITER=-1
39176 120 ITER=ITER+1
39177 SUMXP=SUMXPP
39178 NSTP=2**(ITER-1)
39179 IF(ITER.EQ.0) NSTP=2
39180 DO 130 KFL=0,6
39181 SXP(KFL)=0.5D0*SXP(KFL)
39182 130 CONTINUE
39183 WTSTP=0.5D0/NSTP
39184 IF(ITER.EQ.0) WTSTP=0.5D0
39185C...Pick grid of x_{gamma} values logarithmically even.
39186 DO 150 ISTP=1,NSTP
39187 IF(ITER.EQ.0) THEN
39188 XLE=XL*(ISTP-1)
39189 ELSE
39190 XLE=XL*(ISTP-0.5D0)/NSTP
39191 ENDIF
39192 XE=MIN(1D0-1D-10,EXP(XLE))
39193 XG=MIN(1D0-1D-10,X/XE)
39194C...Evaluate photon inside electron parton distribution for convolution.
39195 XPGP=1D0+(1D0-XE)**2
39196 IF(MSTP(13).LE.1) THEN
39197 XPGP=XPGP*HLE
39198 ELSE
39199 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39200 ENDIF
39201C...Evaluate photon parton distributions for convolution.
39202 IF(MSTP(56).EQ.1) THEN
39203 IF(MSTP(55).EQ.1) THEN
39204 CALL PYPDGA(XG,Q2,XPGA)
39205 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39206 Q2MX=Q2
39207 P2MX=0.36D0
39208 IF(MSTP(55).GE.7) P2MX=4.0D0
39209 IF(MSTP(57).EQ.0) Q2MX=P2MX
39210 P2=0D0
39211 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39212 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39213 VINT(231)=P2MX
39214 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39215 Q2MX=Q2
39216 P2MX=0.36D0
39217 IF(MSTP(55).GE.11) P2MX=4.0D0
39218 IF(MSTP(57).EQ.0) Q2MX=P2MX
39219 P2=0D0
39220 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39221 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39222 VINT(231)=P2MX
39223 ENDIF
39224 DO 140 KFL=0,5
39225 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39226 140 CONTINUE
39227 ELSEIF(MSTP(56).EQ.2) THEN
39228C...Call PDFLIB parton distributions.
39229 XX=XG
39230 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39231 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39232 CALL STRUCTM_ALICE
39233 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39234 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39235 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39236 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39237 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39238 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39239 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39240 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39241 ENDIF
39242 150 CONTINUE
39243 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39244 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39245 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39246
39247C...Put convolution into output arrays.
39248 FCONV=AEMP*(-XL)
39249 XPEL(0)=FCONV*SXP(0)
39250 DO 160 KFL=1,6
39251 XPEL(KFL)=FCONV*SXP(KFL)
39252 XPEL(-KFL)=XPEL(KFL)
39253 160 CONTINUE
39254 ENDIF
39255
39256 RETURN
39257 END
39258
39259C*********************************************************************
39260
39261C...PYPDGA
39262C...Gives photon parton distribution.
39263
39264 SUBROUTINE PYPDGA(X,Q2,XPGA)
39265
39266C...Double precision and integer declarations.
39267 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39268 IMPLICIT INTEGER(I-N)
39269 INTEGER PYK,PYCHGE,PYCOMP
39270C...Commonblocks.
39271 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39272 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39273 COMMON/PYINT1/MINT(400),VINT(400)
39274 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39275C...Local arrays.
39276 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39277 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39278 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39279
39280C...The following data lines are coefficients needed in the
39281C...Drees and Grassie photon parton distribution parametrization.
39282 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39283 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39284 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39285 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39286 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39287 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39288 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39289 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39290 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39291 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39292 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39293 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39294 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39295 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39296 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39297 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39298 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39299 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39300 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39301 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39302 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39303 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39304 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39305 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39306 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39307 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39308
39309C...Photon parton distribution from Drees and Grassie.
39310C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39311 DO 100 KFL=-6,6
39312 XPGA(KFL)=0D0
39313 100 CONTINUE
39314 VINT(231)=1D0
39315 IF(MSTP(57).LE.0) THEN
39316 T=LOG(1D0/0.16D0)
39317 ELSE
39318 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39319 ENDIF
39320 X1=1D0-X
39321 NF=3
39322 IF(Q2.GT.25D0) NF=4
39323 IF(Q2.GT.300D0) NF=5
39324 NFE=NF-2
39325 AEM=PARU(101)
39326
39327C...Evaluate gluon content.
39328 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39329 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39330 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39331 XPGL=DGA*X**DGB*X1**DGC
39332
39333C...Evaluate up- and down-type quark content.
39334 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39335 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39336 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39337 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39338 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39339 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39340 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39341 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39342 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39343 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39344 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39345 DGF=9D0
39346 IF(NF.EQ.4) DGF=10D0
39347 IF(NF.EQ.5) DGF=55D0/6D0
39348 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39349 IF(NF.LE.3) THEN
39350 XPQU=(XPQS+9D0*XPQN)/6D0
39351 XPQD=(XPQS-4.5D0*XPQN)/6D0
39352 ELSEIF(NF.EQ.4) THEN
39353 XPQU=(XPQS+6D0*XPQN)/8D0
39354 XPQD=(XPQS-6D0*XPQN)/8D0
39355 ELSE
39356 XPQU=(XPQS+7.5D0*XPQN)/10D0
39357 XPQD=(XPQS-5D0*XPQN)/10D0
39358 ENDIF
39359
39360C...Put into output arrays.
39361 XPGA(0)=AEM*XPGL
39362 XPGA(1)=AEM*XPQD
39363 XPGA(2)=AEM*XPQU
39364 XPGA(3)=AEM*XPQD
39365 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39366 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39367 DO 110 KFL=1,6
39368 XPGA(-KFL)=XPGA(KFL)
39369 110 CONTINUE
39370
39371 RETURN
39372 END
39373
39374C*********************************************************************
39375
39376C...PYGGAM
39377C...Constructs the F2 and parton distributions of the photon
39378C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39379C...For F2, c and b are included by the Bethe-Heitler formula;
39380C...in the 'MSbar' scheme additionally a Cgamma term is added.
39381C...Contains the SaS sets 1D, 1M, 2D and 2M.
39382C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39383
39384 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39385
39386C...Double precision and integer declarations.
39387 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39388 IMPLICIT INTEGER(I-N)
39389 INTEGER PYK,PYCHGE,PYCOMP
39390C...Commonblocks.
39391 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39392 &XPDIR(-6:6)
39393 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39394 SAVE /PYINT8/,/PYINT9/
39395C...Local arrays.
39396 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39397C...Charm and bottom masses (low to compensate for J/psi etc.).
39398 DATA PMC/1.3D0/, PMB/4.6D0/
39399C...alpha_em and alpha_em/(2*pi).
39400 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39401C...Lambda value for 4 flavours.
39402 DATA ALAM/0.20D0/
39403C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39404 DATA FRACU/0.8D0/
39405C...VMD couplings f_V**2/(4*pi).
39406 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39407C...Masses for rho (=omega) and phi.
39408 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39409C...Number of points in integration for IP2=1.
39410 DATA NSTEP/100/
39411
39412C...Reset output.
39413 F2GM=0D0
39414 DO 100 KFL=-6,6
39415 XPDFGM(KFL)=0D0
39416 XPVMD(KFL)=0D0
39417 XPANL(KFL)=0D0
39418 XPANH(KFL)=0D0
39419 XPBEH(KFL)=0D0
39420 XPDIR(KFL)=0D0
39421 VXPVMD(KFL)=0D0
39422 VXPANL(KFL)=0D0
39423 VXPANH(KFL)=0D0
39424 VXPDGM(KFL)=0D0
39425 100 CONTINUE
39426
39427C...Set Q0 cut-off parameter as function of set used.
39428 IF(ISET.LE.2) THEN
39429 Q0=0.6D0
39430 ELSE
39431 Q0=2D0
39432 ENDIF
39433 Q02=Q0**2
39434
39435C...Scale choice for off-shell photon; common factors.
39436 Q2A=Q2
39437 FACNOR=1D0
39438 IF(IP2.EQ.1) THEN
39439 P2MX=P2+Q02
39440 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39441 FACNOR=LOG(Q2/Q02)/NSTEP
39442 ELSEIF(IP2.EQ.2) THEN
39443 P2MX=MAX(P2,Q02)
39444 ELSEIF(IP2.EQ.3) THEN
39445 P2MX=P2+Q02
39446 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39447 ELSEIF(IP2.EQ.4) THEN
39448 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39449 & ((Q2+P2)*(Q02+P2)))
39450 ELSEIF(IP2.EQ.5) THEN
39451 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39452 & ((Q2+P2)*(Q02+P2)))
39453 P2MX=Q0*SQRT(P2MXA)
39454 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39455 ELSEIF(IP2.EQ.6) THEN
39456 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39457 & ((Q2+P2)*(Q02+P2)))
39458 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39459 ELSE
39460 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=Q0*SQRT(P2MXA)
39463 P2MXB=P2MX
39464 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39465 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39466 IF(ABS(Q2-Q02).GT.1D-6) THEN
39467 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39468 ELSEIF(P2.LT.Q02) THEN
39469 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39470 ELSE
39471 FACNOR=1D0
39472 ENDIF
39473 ENDIF
39474
39475C...Call VMD parametrization for d quark and use to give rho, omega,
39476C...phi. Note dipole dampening for off-shell photon.
39477 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39478 XFVAL=VXPGA(1)
39479 XPGA(1)=XPGA(2)
39480 XPGA(-1)=XPGA(-2)
39481 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39482 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39483 DO 110 KFL=-5,5
39484 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39485 110 CONTINUE
39486 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39487 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39488 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39489 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39490 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39491 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39492 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39493 VXPVMD(2)=FRACU*FACUD*XFVAL
39494 VXPVMD(3)=FACS*XFVAL
39495 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39496 VXPVMD(-2)=FRACU*FACUD*XFVAL
39497 VXPVMD(-3)=FACS*XFVAL
39498
39499 IF(IP2.NE.1) THEN
39500C...Anomalous parametrizations for different strategies
39501C...for off-shell photons; except full integration.
39502
39503C...Call anomalous parametrization for d + u + s.
39504 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39505 DO 120 KFL=-5,5
39506 XPANL(KFL)=FACNOR*XPGA(KFL)
39507 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39508 120 CONTINUE
39509
39510C...Call anomalous parametrization for c and b.
39511 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39512 DO 130 KFL=-5,5
39513 XPANH(KFL)=FACNOR*XPGA(KFL)
39514 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39515 130 CONTINUE
39516 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39517 DO 140 KFL=-5,5
39518 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39519 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39520 140 CONTINUE
39521
39522 ELSE
39523C...Special option: loop over flavours and integrate over k2.
39524 DO 170 KF=1,5
39525 DO 160 ISTEP=1,NSTEP
39526 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39527 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39528 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39529 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39530 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39531 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39532 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39533 DO 150 KFL=-5,5
39534 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39535 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39536 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39537 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39538 150 CONTINUE
39539 160 CONTINUE
39540 170 CONTINUE
39541 ENDIF
39542
39543C...Call Bethe-Heitler term expression for charm and bottom.
39544 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39545 XPBEH(4)=XPBH
39546 XPBEH(-4)=XPBH
39547 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39548 XPBEH(5)=XPBH
39549 XPBEH(-5)=XPBH
39550
39551C...For MSbar subtraction call C^gamma term expression for d, u, s.
39552 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39553 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39554 DO 180 KFL=-5,5
39555 XPDIR(KFL)=XPGA(KFL)
39556 180 CONTINUE
39557 ENDIF
39558
39559C...Store result in output array.
39560 DO 190 KFL=-5,5
39561 CHSQ=1D0/9D0
39562 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39563 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39564 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39565 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39566 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39567 190 CONTINUE
39568
39569 RETURN
39570 END
39571
39572C*********************************************************************
39573
39574C...PYGVMD
39575C...Evaluates the VMD parton distributions of a photon,
39576C...evolved homogeneously from an initial scale P2 to Q2.
39577C...Does not include dipole suppression factor.
39578C...ISET is parton distribution set, see above;
39579C...additionally ISET=0 is used for the evolution of an anomalous photon
39580C...which branched at a scale P2 and then evolved homogeneously to Q2.
39581C...ALAM is the 4-flavour Lambda, which is automatically converted
39582C...to 3- and 5-flavour equivalents as needed.
39583C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39584
39585 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39586
39587C...Double precision and integer declarations.
39588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39589 IMPLICIT INTEGER(I-N)
39590 INTEGER PYK,PYCHGE,PYCOMP
39591C...Local arrays and data.
39592 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39593 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39594
39595C...Reset output.
39596 DO 100 KFL=-6,6
39597 XPGA(KFL)=0D0
39598 VXPGA(KFL)=0D0
39599 100 CONTINUE
39600 KFA=IABS(KF)
39601
39602C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39603 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39604 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39605 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39606 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39607 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39608 Q2EFF=MAX(Q2,P2EFF)
39609
39610C...Find number of flavours at lower and upper scale.
39611 NFP=4
39612 IF(P2EFF.LT.PMC**2) NFP=3
39613 IF(P2EFF.GT.PMB**2) NFP=5
39614 NFQ=4
39615 IF(Q2EFF.LT.PMC**2) NFQ=3
39616 IF(Q2EFF.GT.PMB**2) NFQ=5
39617
39618C...Find s as sum of 3-, 4- and 5-flavour parts.
39619 S=0D0
39620 IF(NFP.EQ.3) THEN
39621 Q2DIV=PMC**2
39622 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39623 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39624 ENDIF
39625 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39626 P2DIV=P2EFF
39627 IF(NFP.EQ.3) P2DIV=PMC**2
39628 Q2DIV=Q2EFF
39629 IF(NFQ.EQ.5) Q2DIV=PMB**2
39630 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39631 ENDIF
39632 IF(NFQ.EQ.5) THEN
39633 P2DIV=PMB**2
39634 IF(NFP.EQ.5) P2DIV=P2EFF
39635 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39636 ENDIF
39637
39638C...Calculate frequent combinations of x and s.
39639 X1=1D0-X
39640 XL=-LOG(X)
39641 S2=S**2
39642 S3=S**3
39643 S4=S**4
39644
39645C...Evaluate homogeneous anomalous parton distributions below or
39646C...above threshold.
39647 IF(ISET.EQ.0) THEN
39648 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39649 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39650 XVAL = X * 1.5D0 * (X**2+X1**2)
39651 XGLU = 0D0
39652 XSEA = 0D0
39653 ELSE
39654 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39655 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39656 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39657 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39658 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39659 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39660 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39661 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39662 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39663 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39664 & (2D0*X-1D0)*X*XL**2)
39665 ENDIF
39666
39667C...Evaluate set 1D parton distributions below or above threshold.
39668 ELSEIF(ISET.EQ.1) THEN
39669 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39670 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39671 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39672 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39673 XSEA = 0.100D0 * X1**3.76D0
39674 ELSE
39675 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39676 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39677 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39678 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39679 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39680 & X**0.40D0 * X1**(1.76D0+3D0*S)
39681 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39682 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39683 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39684 XSEA0 = 0.100D0 * X1**3.76D0
39685 ENDIF
39686
39687C...Evaluate set 1M parton distributions below or above threshold.
39688 ELSEIF(ISET.EQ.2) THEN
39689 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39690 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39691 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39692 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39693 XSEA = 0D0
39694 ELSE
39695 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39696 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39697 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39698 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39699 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39700 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39701 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39702 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39703 & XL**(2.8D0*S)
39704 XSEA0 = 0D0
39705 ENDIF
39706
39707C...Evaluate set 2D parton distributions below or above threshold.
39708 ELSEIF(ISET.EQ.3) THEN
39709 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39710 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39711 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39712 XGLU = 1.925D0 * X1**2
39713 XSEA = 0.242D0 * X1**4
39714 ELSE
39715 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39716 & X**(0.46D0+0.25D0*S) *
39717 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39718 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39719 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39720 & EXP(-18.67D0*S) *
39721 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39722 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39723 & XL**(9.3D0*S/(1D0+1.7D0*S))
39724 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39725 & (1D0-0.607D0*S+21.95D0*S2) *
39726 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39727 XSEA0 = 0.242D0 * X1**4
39728 ENDIF
39729
39730C...Evaluate set 2M parton distributions below or above threshold.
39731 ELSEIF(ISET.EQ.4) THEN
39732 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39733 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39734 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39735 XGLU = 1.808D0 * X1**2
39736 XSEA = 0.209D0 * X1**4
39737 ELSE
39738 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39739 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39740 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39741 & XL**(5.15D0*S/(1D0+2D0*S)) +
39742 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39743 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39744 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39745 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39746 & XL**(10.9D0*S/(1D0+2.5D0*S))
39747 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39748 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39749 & X1**(4D0+S) * XL**(0.45D0*S)
39750 XSEA0 = 0.209D0 * X1**4
39751 ENDIF
39752 ENDIF
39753
39754C...Threshold factors for c and b sea.
39755 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39756 XCHM=0D0
39757 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39758 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39759 IF(ISET.EQ.0) THEN
39760 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39761 ELSE
39762 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39763 ENDIF
39764 ENDIF
39765 XBOT=0D0
39766 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39767 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39768 IF(ISET.EQ.0) THEN
39769 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39770 ELSE
39771 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39772 ENDIF
39773 ENDIF
39774
39775C...Fill parton distributions.
39776 XPGA(0)=XGLU
39777 XPGA(1)=XSEA
39778 XPGA(2)=XSEA
39779 XPGA(3)=XSEA
39780 XPGA(4)=XCHM
39781 XPGA(5)=XBOT
39782 XPGA(KFA)=XPGA(KFA)+XVAL
39783 DO 110 KFL=1,5
39784 XPGA(-KFL)=XPGA(KFL)
39785 110 CONTINUE
39786 VXPGA(KFA)=XVAL
39787 VXPGA(-KFA)=XVAL
39788
39789 RETURN
39790 END
39791
39792C*********************************************************************
39793
39794C...PYGANO
39795C...Evaluates the parton distributions of the anomalous photon,
39796C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39797C...KF=0 gives the sum over (up to) 5 flavours,
39798C...KF<0 limits to flavours up to abs(KF),
39799C...KF>0 is for flavour KF only.
39800C...ALAM is the 4-flavour Lambda, which is automatically converted
39801C...to 3- and 5-flavour equivalents as needed.
39802C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39803
39804 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39805
39806C...Double precision and integer declarations.
39807 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39808 IMPLICIT INTEGER(I-N)
39809 INTEGER PYK,PYCHGE,PYCOMP
39810C...Local arrays and data.
39811 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39812 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39813
39814C...Reset output.
39815 DO 100 KFL=-6,6
39816 XPGA(KFL)=0D0
39817 VXPGA(KFL)=0D0
39818 100 CONTINUE
39819 IF(Q2.LE.P2) RETURN
39820 KFA=IABS(KF)
39821
39822C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39823 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39824 ALAMSQ(4)=ALAM**2
39825 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39826 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39827 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39828 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39829 Q2EFF=MAX(Q2,P2EFF)
39830 XL=-LOG(X)
39831
39832C...Find number of flavours at lower and upper scale.
39833 NFP=4
39834 IF(P2EFF.LT.PMC**2) NFP=3
39835 IF(P2EFF.GT.PMB**2) NFP=5
39836 NFQ=4
39837 IF(Q2EFF.LT.PMC**2) NFQ=3
39838 IF(Q2EFF.GT.PMB**2) NFQ=5
39839
39840C...Define range of flavour loop.
39841 IF(KF.EQ.0) THEN
39842 KFLMN=1
39843 KFLMX=5
39844 ELSEIF(KF.LT.0) THEN
39845 KFLMN=1
39846 KFLMX=KFA
39847 ELSE
39848 KFLMN=KFA
39849 KFLMX=KFA
39850 ENDIF
39851
39852C...Loop over flavours the photon can branch into.
39853 DO 110 KFL=KFLMN,KFLMX
39854
39855C...Light flavours: calculate t range and (approximate) s range.
39856 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39857 TDIFF=LOG(Q2EFF/P2EFF)
39858 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39859 & LOG(P2EFF/ALAMSQ(NFQ)))
39860 IF(NFQ.GT.NFP) THEN
39861 Q2DIV=PMB**2
39862 IF(NFQ.EQ.4) Q2DIV=PMC**2
39863 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39864 & LOG(P2EFF/ALAMSQ(NFQ)))
39865 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39866 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39867 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39868 ENDIF
39869 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39870 Q2DIV=PMC**2
39871 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39872 & LOG(P2EFF/ALAMSQ(4)))
39873 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39874 & LOG(P2EFF/ALAMSQ(3)))
39875 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39876 ENDIF
39877
39878C...u and s quark do not need a separate treatment when d has been done.
39879 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39880
39881C...Charm: as above, but only include range above c threshold.
39882 ELSEIF(KFL.EQ.4) THEN
39883 IF(Q2.LE.PMC**2) GOTO 110
39884 P2EFF=MAX(P2EFF,PMC**2)
39885 Q2EFF=MAX(Q2EFF,P2EFF)
39886 TDIFF=LOG(Q2EFF/P2EFF)
39887 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39888 & LOG(P2EFF/ALAMSQ(NFQ)))
39889 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39890 Q2DIV=PMB**2
39891 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39892 & LOG(P2EFF/ALAMSQ(NFQ)))
39893 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39894 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39895 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39896 ENDIF
39897
39898C...Bottom: as above, but only include range above b threshold.
39899 ELSEIF(KFL.EQ.5) THEN
39900 IF(Q2.LE.PMB**2) GOTO 110
39901 P2EFF=MAX(P2EFF,PMB**2)
39902 Q2EFF=MAX(Q2,P2EFF)
39903 TDIFF=LOG(Q2EFF/P2EFF)
39904 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39905 & LOG(P2EFF/ALAMSQ(NFQ)))
39906 ENDIF
39907
39908C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39909 CHSQ=1D0/9D0
39910 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39911 FAC=AEM2PI*2D0*CHSQ*TDIFF
39912
39913C...Evaluate parton distributions (normalized to unit momentum sum).
39914 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39915 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39916 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39917 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39918 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39919 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39920 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39921 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39922 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39923 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39924 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39925 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39926
39927C...Threshold factors for c and b sea.
39928 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39929 XCHM=0D0
39930 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39931 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39932 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39933 ENDIF
39934 XBOT=0D0
39935 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39936 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39937 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39938 ENDIF
39939 ENDIF
39940
39941C...Add contribution of each valence flavour.
39942 XPGA(0)=XPGA(0)+FAC*XGLU
39943 XPGA(1)=XPGA(1)+FAC*XSEA
39944 XPGA(2)=XPGA(2)+FAC*XSEA
39945 XPGA(3)=XPGA(3)+FAC*XSEA
39946 XPGA(4)=XPGA(4)+FAC*XCHM
39947 XPGA(5)=XPGA(5)+FAC*XBOT
39948 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39949 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39950 110 CONTINUE
39951 DO 120 KFL=1,5
39952 XPGA(-KFL)=XPGA(KFL)
39953 VXPGA(-KFL)=VXPGA(KFL)
39954 120 CONTINUE
39955
39956 RETURN
39957 END
39958
39959
39960C*********************************************************************
39961
39962C...PYGBEH
39963C...Evaluates the Bethe-Heitler cross section for heavy flavour
39964C...production.
39965C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39966
39967 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39968
39969C...Double precision and integer declarations.
39970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39971 IMPLICIT INTEGER(I-N)
39972 INTEGER PYK,PYCHGE,PYCOMP
39973
39974C...Local data.
39975 DATA AEM2PI/0.0011614D0/
39976
39977C...Reset output.
39978 XPBH=0D0
39979 SIGBH=0D0
39980
39981C...Check kinematics limits.
39982 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39983 W2=Q2*(1D0-X)/X-P2
39984 BETA2=1D0-4D0*PM2/W2
39985 IF(BETA2.LT.1D-10) RETURN
39986 BETA=SQRT(BETA2)
39987 RMQ=4D0*PM2/Q2
39988
39989C...Simple case: P2 = 0.
39990 IF(P2.LT.1D-4) THEN
39991 IF(BETA.LT.0.99D0) THEN
39992 XBL=LOG((1D0+BETA)/(1D0-BETA))
39993 ELSE
39994 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
39995 ENDIF
39996 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
39997 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
39998
39999C...Complicated case: P2 > 0, based on approximation of
40000C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40001 ELSE
40002 RPQ=1D0-4D0*X**2*P2/Q2
40003 IF(RPQ.GT.1D-10) THEN
40004 RPBE=SQRT(RPQ*BETA2)
40005 IF(RPBE.LT.0.99D0) THEN
40006 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40007 XBI=2D0*RPBE/(1D0-RPBE**2)
40008 ELSE
40009 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40010 XBL=LOG((1D0+RPBE)**2/RPBESN)
40011 XBI=2D0*RPBE/RPBESN
40012 ENDIF
40013 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40014 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40015 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40016 ENDIF
40017 ENDIF
40018
40019C...Multiply by charge-squared etc. to get parton distribution.
40020 CHSQ=1D0/9D0
40021 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40022 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40023
40024 RETURN
40025 END
40026
40027C*********************************************************************
40028
40029C...PYGDIR
40030C...Evaluates the direct contribution, i.e. the C^gamma term,
40031C...as needed in MSbar parametrizations.
40032C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40033
40034 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40035
40036C...Double precision and integer declarations.
40037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40038 IMPLICIT INTEGER(I-N)
40039 INTEGER PYK,PYCHGE,PYCOMP
40040C...Local array and data.
40041 DIMENSION XPGA(-6:6)
40042 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40043
40044C...Reset output.
40045 DO 100 KFL=-6,6
40046 XPGA(KFL)=0D0
40047 100 CONTINUE
40048
40049C...Evaluate common x-dependent expression.
40050 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40051 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40052
40053C...d, u, s part by simple charge factor.
40054 XPGA(1)=(1D0/9D0)*CGAM
40055 XPGA(2)=(4D0/9D0)*CGAM
40056 XPGA(3)=(1D0/9D0)*CGAM
40057
40058C...Also fill for antiquarks.
40059 DO 110 KF=1,5
40060 XPGA(-KF)=XPGA(KF)
40061 110 CONTINUE
40062
40063 RETURN
40064 END
40065
40066C*********************************************************************
40067
40068C...PYPDPI
40069C...Gives pi+ parton distribution according to two different
40070C...parametrizations.
40071
40072 SUBROUTINE PYPDPI(X,Q2,XPPI)
40073
40074C...Double precision and integer declarations.
40075 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40076 IMPLICIT INTEGER(I-N)
40077 INTEGER PYK,PYCHGE,PYCOMP
40078C...Commonblocks.
40079 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40081 COMMON/PYINT1/MINT(400),VINT(400)
40082 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40083C...Local arrays.
40084 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40085
40086C...The following data lines are coefficients needed in the
40087C...Owens pion parton distribution parametrizations, see below.
40088C...Expansion coefficients for up and down valence quark distributions.
40089 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40090 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40091 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40092 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40093 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40094 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40095 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40096 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40097C...Expansion coefficients for gluon distribution.
40098 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40099 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40100 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40101 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40102 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40103 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40104 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40105 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40106C...Expansion coefficients for (up+down+strange) quark sea distribution.
40107 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40108 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40109 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40110 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40111 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40112 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40113 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40114 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40115C...Expansion coefficients for charm quark sea distribution.
40116 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40117 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40118 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40119 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40120 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40121 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40122 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40123 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40124
40125C...Euler's beta function, requires ordinary Gamma function
40126 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40127
40128C...Reset output array.
40129 DO 100 KFL=-6,6
40130 XPPI(KFL)=0D0
40131 100 CONTINUE
40132
40133 IF(MSTP(53).LE.2) THEN
40134C...Pion parton distributions from Owens.
40135C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40136
40137C...Determine set, Lambda and s expansion variable.
40138 NSET=MSTP(53)
40139 IF(NSET.EQ.1) ALAM=0.2D0
40140 IF(NSET.EQ.2) ALAM=0.4D0
40141 VINT(231)=4D0
40142 IF(MSTP(57).LE.0) THEN
40143 SD=0D0
40144 ELSE
40145 Q2IN=MIN(2D3,MAX(4D0,Q2))
40146 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40147 ENDIF
40148
40149C...Calculate parton distributions.
40150 DO 120 KFL=1,4
40151 DO 110 IS=1,5
40152 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40153 & COW(3,IS,KFL,NSET)*SD**2
40154 110 CONTINUE
40155 IF(KFL.EQ.1) THEN
40156 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40157 ELSE
40158 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40159 & TS(5)*X**2)
40160 ENDIF
40161 120 CONTINUE
40162
40163C...Put into output array.
40164 XPPI(0)=XQ(2)
40165 XPPI(1)=XQ(3)/6D0
40166 XPPI(2)=XQ(1)+XQ(3)/6D0
40167 XPPI(3)=XQ(3)/6D0
40168 XPPI(4)=XQ(4)
40169 XPPI(-1)=XQ(1)+XQ(3)/6D0
40170 XPPI(-2)=XQ(3)/6D0
40171 XPPI(-3)=XQ(3)/6D0
40172 XPPI(-4)=XQ(4)
40173
40174C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40175C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40176C...10^-5 < x < 1.
40177 ELSE
40178
40179C...Determine s expansion variable and some x expressions.
40180 VINT(231)=0.25D0
40181 IF(MSTP(57).LE.0) THEN
40182 SD=0D0
40183 ELSE
40184 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40185 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40186 ENDIF
40187 SD2=SD**2
40188 XL=-LOG(X)
40189 XS=SQRT(X)
40190
40191C...Evaluate valence, gluon and sea distributions.
40192 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40193 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40194 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40195 & SD-0.175D0*SD2)+
40196 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40197 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40198 & XL)))*
40199 & (1D0-X)**(0.390D0+1.053D0*SD)
40200 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40201 & X)**3.359D0*
40202 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40203 & XL))/
40204 & XL**(2.538D0-0.763D0*SD)
40205 IF(SD.LE.0.888D0) THEN
40206 XFCHM=0D0
40207 ELSE
40208 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40209 & 0.771D0*SD)*
40210 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40211 & XL))
40212 ENDIF
40213 IF(SD.LE.1.351D0) THEN
40214 XFBOT=0D0
40215 ELSE
40216 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40217 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40218 & XL))
40219 ENDIF
40220
40221C...Put into output array.
40222 XPPI(0)=XFGLU
40223 XPPI(1)=XFSEA
40224 XPPI(2)=XFSEA
40225 XPPI(3)=XFSEA
40226 XPPI(4)=XFCHM
40227 XPPI(5)=XFBOT
40228 DO 130 KFL=1,5
40229 XPPI(-KFL)=XPPI(KFL)
40230 130 CONTINUE
40231 XPPI(2)=XPPI(2)+XFVAL
40232 XPPI(-1)=XPPI(-1)+XFVAL
40233 ENDIF
40234
40235 RETURN
40236 END
40237
40238C*********************************************************************
40239
40240C...PYPDPR
40241C...Gives proton parton distributions according to a few different
40242C...parametrizations.
40243
40244 SUBROUTINE PYPDPR(X,Q2,XPPR)
40245
40246C...Double precision and integer declarations.
40247 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40248 IMPLICIT INTEGER(I-N)
40249 INTEGER PYK,PYCHGE,PYCOMP
40250C...Commonblocks.
40251 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40252 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40253 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40254 COMMON/PYINT1/MINT(400),VINT(400)
40255 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40256C...Arrays and data.
40257 DIMENSION XPPR(-6:6),Q2MIN(16)
40258 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40259 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40260
40261C...Reset output array.
40262 DO 100 KFL=-6,6
40263 XPPR(KFL)=0D0
40264 100 CONTINUE
40265
40266C...Common preliminaries.
40267 NSET=MAX(1,MIN(16,MSTP(51)))
40268 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40269 VINT(231)=Q2MIN(NSET)
40270 IF(MSTP(57).EQ.0) THEN
40271 Q2L=Q2MIN(NSET)
40272 ELSE
40273 Q2L=MAX(Q2MIN(NSET),Q2)
40274 ENDIF
40275
40276 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40277C...Interface to the CTEQ 3 parton distributions.
40278 QRT=SQRT(MAX(1D0,Q2L))
40279
40280C...Loop over flavours.
40281 DO 110 I=-6,6
40282 IF(I.LE.0) THEN
40283 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40284 ELSEIF(I.LE.2) THEN
40285 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40286 ELSE
40287 XPPR(I)=XPPR(-I)
40288 ENDIF
40289 110 CONTINUE
40290
40291 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40292C...Interface to the GRV 94 distributions.
40293 IF(NSET.EQ.4) THEN
40294 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40295 ELSEIF(NSET.EQ.5) THEN
40296 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40297 ELSE
40298 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40299 ENDIF
40300
40301C...Put into output array.
40302 XPPR(0)=GL
40303 XPPR(-1)=0.5D0*(UDB+DEL)
40304 XPPR(-2)=0.5D0*(UDB-DEL)
40305 XPPR(-3)=SB
40306 XPPR(-4)=CHM
40307 XPPR(-5)=BOT
40308 XPPR(1)=DV+XPPR(-1)
40309 XPPR(2)=UV+XPPR(-2)
40310 XPPR(3)=SB
40311 XPPR(4)=CHM
40312 XPPR(5)=BOT
40313
40314 ELSEIF(NSET.EQ.7) THEN
40315C...Interface to the CTEQ 5L parton distributions.
40316C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40317C...freezing x*f(x,Q2) at borders.
40318 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40319 XIN=MAX(1D-6,MIN(1D0,X))
40320
40321C...Loop over flavours (with u <-> d notation mismatch).
40322 SUMUDB=PYCT5L(-1,XIN,QRT)
40323 RATUDB=PYCT5L(-2,XIN,QRT)
40324 DO 120 I=-5,2
40325 IF(I.EQ.1) THEN
40326 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40327 ELSEIF(I.EQ.2) THEN
40328 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40329 ELSEIF(I.EQ.-1) THEN
40330 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40331 ELSEIF(I.EQ.-2) THEN
40332 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40333 ELSE
40334 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40335 IF(I.LT.0) XPPR(-I)=XPPR(I)
40336 ENDIF
40337 120 CONTINUE
40338
40339 ELSEIF(NSET.EQ.8) THEN
40340C...Interface to the CTEQ 5M1 parton distributions.
40341 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40342 XIN=MAX(1D-6,MIN(1D0,X))
40343
40344C...Loop over flavours (with u <-> d notation mismatch).
40345 SUMUDB=PYCT5M(-1,XIN,QRT)
40346 RATUDB=PYCT5M(-2,XIN,QRT)
40347 DO 130 I=-5,2
40348 IF(I.EQ.1) THEN
40349 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40350 ELSEIF(I.EQ.2) THEN
40351 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40352 ELSEIF(I.EQ.-1) THEN
40353 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40354 ELSEIF(I.EQ.-2) THEN
40355 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40356 ELSE
40357 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40358 IF(I.LT.0) XPPR(-I)=XPPR(I)
40359 ENDIF
40360 130 CONTINUE
40361
40362 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40363C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40364C...obsolete but offers backwards compatibility.
40365 CALL PYPDPO(X,Q2L,XPPR)
40366
40367C...Symmetric choice for debugging only
40368 ELSEIF(NSET.EQ.16) THEN
40369 XPPR(0)=.5D0/X
40370 XPPR(1)=.05D0/X
40371 XPPR(2)=.05D0/X
40372 XPPR(3)=.05D0/X
40373 XPPR(4)=.05D0/X
40374 XPPR(5)=.05D0/X
40375 XPPR(-1)=.05D0/X
40376 XPPR(-2)=.05D0/X
40377 XPPR(-3)=.05D0/X
40378 XPPR(-4)=.05D0/X
40379 XPPR(-5)=.05D0/X
40380
40381 ENDIF
40382
40383 RETURN
40384 END
40385
40386C*********************************************************************
40387
40388C...PYCTEQ
40389C...Gives the CTEQ 3 parton distribution function sets in
40390C...parametrized form, of October 24, 1994.
40391C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40392C...J. Qiu, W.K. Tung and H. Weerts.
40393
40394 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40395
40396C...Double precision declaration.
40397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40398 IMPLICIT INTEGER(I-N)
40399
40400C...Data on Lambda values of fits, minimum Q and quark masses.
40401 DIMENSION ALM(3), QMS(4:6)
40402 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40403 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40404
40405C....Check flavour thresholds. Set up QI for SB.
40406 IP = IABS(IPRT)
40407 IF(IP .GE. 4) THEN
40408 IF(Q .LE. QMS(IP)) THEN
40409 PYCTEQ = 0D0
40410 RETURN
40411 ENDIF
40412 QI = QMS(IP)
40413 ELSE
40414 QI = QMN
40415 ENDIF
40416
40417C...Use "standard lambda" of parametrization program for expansion.
40418 ALAM = ALM (ISET)
40419 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40420 SB = LOG (SBL)
40421 SB2 = SB*SB
40422 SB3 = SB2*SB
40423
40424C...Expansion for CTEQ3L.
40425 IF(ISET .EQ. 1) THEN
40426 IF(IPRT .EQ. 2) THEN
40427 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40428 & 0.3171D+00*SB3)
40429 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40430 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40431 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40432 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40433 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40434 ELSEIF(IPRT .EQ. 1) THEN
40435 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40436 & 0.7728D+00*SB3)
40437 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40438 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40439 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40440 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40441 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40442 ELSEIF(IPRT .EQ. 0) THEN
40443 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40444 & 0.5343D+00*SB3)
40445 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40446 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40447 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40448 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40449 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40450 ELSEIF(IPRT .EQ. -1) THEN
40451 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40452 & 0.2031D+01*SB3)
40453 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40454 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40455 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40456 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40457 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40458 ELSEIF(IPRT .EQ. -2) THEN
40459 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40460 & 0.9872D-01*SB3)
40461 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40462 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40463 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40464 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40465 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40466 ELSEIF(IPRT .EQ. -3) THEN
40467 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40468 & 0.8390D+00*SB3)
40469 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40470 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40471 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40472 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40473 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40474 ELSEIF(IPRT .EQ. -4) THEN
40475 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40476 & 0.1651D-01*SB2)
40477 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40478 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40479 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40480 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40481 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40482 ELSEIF(IPRT .EQ. -5) THEN
40483 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40484 & 0.3702D+01*SB2)
40485 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40486 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40487 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40488 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40489 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40490 ELSEIF(IPRT .EQ. -6) THEN
40491 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40492 & 0.6943D+00*SB2)
40493 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40494 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40495 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40496 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40497 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40498 ENDIF
40499
40500C...Expansion for CTEQ3M.
40501 ELSEIF(ISET .EQ. 2) THEN
40502 IF(IPRT .EQ. 2) THEN
40503 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40504 & 0.2935D+00*SB3)
40505 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40506 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40507 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40508 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40509 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40510 ELSEIF(IPRT .EQ. 1) THEN
40511 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40512 & 0.4305D-01*SB3)
40513 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40514 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40515 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40516 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40517 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40518 ELSEIF(IPRT .EQ. 0) THEN
40519 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40520 & 0.1037D-01*SB3)
40521 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40522 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40523 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40524 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40525 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40526 ELSEIF(IPRT .EQ. -1) THEN
40527 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40528 & 0.1602D+01*SB3)
40529 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40530 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40531 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40532 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40533 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40534 ELSEIF(IPRT .EQ. -2) THEN
40535 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40536 & 0.2496D+00*SB3)
40537 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40538 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40539 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40540 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40541 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40542 ELSEIF(IPRT .EQ. -3) THEN
40543 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40544 & 0.1936D+01*SB3)
40545 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40546 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40547 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40548 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40549 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40550 ELSEIF(IPRT .EQ. -4) THEN
40551 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40552 & 0.5348D+00*SB2)
40553 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40554 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40555 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40556 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40557 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40558 ELSEIF(IPRT .EQ. -5) THEN
40559 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40560 & 0.1569D+01*SB2)
40561 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40562 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40563 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40564 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40565 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40566 ELSEIF(IPRT .EQ. -6) THEN
40567 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40568 & 0.8838D+01*SB2)
40569 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40570 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40571 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40572 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40573 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40574 ENDIF
40575
40576C...Expansion for CTEQ3D.
40577 ELSEIF(ISET .EQ. 3) THEN
40578 IF(IPRT .EQ. 2) THEN
40579 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40580 & 0.2902D+00*SB3)
40581 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40582 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40583 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40584 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40585 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40586 ELSEIF(IPRT .EQ. 1) THEN
40587 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40588 & 0.7257D+00*SB3)
40589 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40590 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40591 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40592 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40593 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40594 ELSEIF(IPRT .EQ. 0) THEN
40595 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40596 & 0.2734D-04*SB3)
40597 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40598 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40599 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40600 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40601 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40602 ELSEIF(IPRT .EQ. -1) THEN
40603 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40604 & 0.1671D+01*SB3)
40605 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40606 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40607 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40608 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40609 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40610 ELSEIF(IPRT .EQ. -2) THEN
40611 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40612 & 0.2223D+00*SB3)
40613 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40614 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40615 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40616 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40617 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40618 ELSEIF(IPRT .EQ. -3) THEN
40619 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40620 & 0.1937D+01*SB3)
40621 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40622 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40623 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40624 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40625 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40626 ELSEIF(IPRT .EQ. -4) THEN
40627 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40628 & 0.5137D+00*SB2)
40629 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40630 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40631 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40632 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40633 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40634 ELSEIF(IPRT .EQ. -5) THEN
40635 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40636 & 0.2143D+01*SB2)
40637 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40638 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40639 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40640 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40641 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40642 ELSEIF(IPRT .EQ. -6) THEN
40643 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40644 & 0.9998D+01*SB2)
40645 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40646 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40647 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40648 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40649 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40650 ENDIF
40651 ENDIF
40652
40653C...Calculation of x * f(x, Q).
40654 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40655 & *(LOG(1D0+1D0/X))**A5 )
40656
40657 RETURN
40658 END
40659
40660C*********************************************************************
40661
40662C...PYGRVL
40663C...Gives the GRV 94 L (leading order) parton distribution function set
40664C...in parametrized form.
40665C...Authors: M. Glueck, E. Reya and A. Vogt.
40666
40667 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40668
40669C...Double precision declaration.
40670 IMPLICIT DOUBLE PRECISION (A - Z)
40671
40672C...Common expressions.
40673 MU2 = 0.23D0
40674 LAM2 = 0.2322D0 * 0.2322D0
40675 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40676 DS = SQRT (S)
40677 S2 = S * S
40678 S3 = S2 * S
40679
40680C...uv :
40681 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40682 AKU = 0.590D0 - 0.024D0 * S
40683 BKU = 0.131D0 + 0.063D0 * S
40684 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40685 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40686 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40687 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40688 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40689
40690C...dv :
40691 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40692 AKD = 0.376D0
40693 BKD = 0.486D0 + 0.062D0 * S
40694 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40695 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40696 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40697 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40698 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40699
40700C...del :
40701 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40702 AKE = 0.409D0 - 0.005D0 * S
40703 BKE = 0.799D0 + 0.071D0 * S
40704 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40705 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40706 CE = 0.0D0
40707 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40708 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40709
40710C...udb :
40711 ALX = 1.451D0
40712 BEX = 0.271D0
40713 AKX = 0.410D0 - 0.232D0 * S
40714 BKX = 0.534D0 - 0.457D0 * S
40715 AGX = 0.890D0 - 0.140D0 * S
40716 BGX = -0.981D0
40717 CX = 0.320D0 + 0.683D0 * S
40718 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40719 EX = 4.119D0 + 1.713D0 * S
40720 ESX = 0.682D0 + 2.978D0 * S
40721 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40722 & DX, EX, ESX)
40723
40724C...sb :
40725 STS = 0D0
40726 ALS = 0.914D0
40727 BES = 0.577D0
40728 AKS = 1.798D0 - 0.596D0 * S
40729 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40730 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40731 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40732 EST = 3.981D0 + 1.638D0 * S
40733 ESS = 6.402D0
40734 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40735
40736C...cb :
40737 STC = 0.888D0
40738 ALC = 1.01D0
40739 BEC = 0.37D0
40740 AKC = 0D0
40741 AC = 0D0
40742 BC = 4.24D0 - 0.804D0 * S
40743 DCT = 3.46D0 - 1.076D0 * S
40744 ECT = 4.61D0 + 1.49D0 * S
40745 ESC = 2.555D0 + 1.961D0 * S
40746 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40747
40748C...bb :
40749 STB = 1.351D0
40750 ALB = 1.00D0
40751 BEB = 0.51D0
40752 AKB = 0D0
40753 AB = 0D0
40754 BB = 1.848D0
40755 DBT = 2.929D0 + 1.396D0 * S
40756 EBT = 4.71D0 + 1.514D0 * S
40757 ESB = 4.02D0 + 1.239D0 * S
40758 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40759
40760C...gl :
40761 ALG = 0.524D0
40762 BEG = 1.088D0
40763 AKG = 1.742D0 - 0.930D0 * S
40764 BKG = - 0.399D0 * S2
40765 AG = 7.486D0 - 2.185D0 * S
40766 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40767 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40768 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40769 EG = 0.807D0 + 2.005D0 * S
40770 ESG = 3.841D0 + 0.316D0 * S
40771 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40772 & DG, EG, ESG)
40773
40774 RETURN
40775 END
40776
40777C*********************************************************************
40778
40779C...PYGRVM
40780C...Gives the GRV 94 M (MSbar) parton distribution function set
40781C...in parametrized form.
40782C...Authors: M. Glueck, E. Reya and A. Vogt.
40783
40784 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40785
40786C...Double precision declaration.
40787 IMPLICIT DOUBLE PRECISION (A - Z)
40788
40789C...Common expressions.
40790 MU2 = 0.34D0
40791 LAM2 = 0.248D0 * 0.248D0
40792 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40793 DS = SQRT (S)
40794 S2 = S * S
40795 S3 = S2 * S
40796
40797C...uv :
40798 NU = 1.304D0 + 0.863D0 * S
40799 AKU = 0.558D0 - 0.020D0 * S
40800 BKU = 0.183D0 * S
40801 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40802 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40803 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40804 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40805 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40806
40807C...dv :
40808 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40809 AKD = 0.270D0 - 0.019D0 * S
40810 BKD = 0.260D0
40811 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40812 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40813 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40814 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40815 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40816
40817C...del :
40818 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40819 AKE = 0.409D0 - 0.007D0 * S
40820 BKE = 0.782D0 + 0.082D0 * S
40821 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40822 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40823 CE = 0.0D0
40824 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40825 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40826
40827C...udb :
40828 ALX = 0.877D0
40829 BEX = 0.561D0
40830 AKX = 0.275D0
40831 BKX = 0.0D0
40832 AGX = 0.997D0
40833 BGX = 3.210D0 - 1.866D0 * S
40834 CX = 7.300D0
40835 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40836 EX = 3.077D0 + 1.446D0 * S
40837 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40838 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40839 & DX, EX, ESX)
40840
40841C...sb :
40842 STS = 0D0
40843 ALS = 0.756D0
40844 BES = 0.216D0
40845 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40846 AS = -4.329D0 + 1.131D0 * S
40847 BS = 9.568D0 - 1.744D0 * S
40848 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40849 EST = 3.031D0 + 1.639D0 * S
40850 ESS = 5.837D0 + 0.815D0 * S
40851 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40852
40853C...cb :
40854 STC = 0.820D0
40855 ALC = 0.98D0
40856 BEC = 0D0
40857 AKC = -0.625D0 - 0.523D0 * S
40858 AC = 0D0
40859 BC = 1.896D0 + 1.616D0 * S
40860 DCT = 4.12D0 + 0.683D0 * S
40861 ECT = 4.36D0 + 1.328D0 * S
40862 ESC = 0.677D0 + 0.679D0 * S
40863 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40864
40865C...bb :
40866 STB = 1.297D0
40867 ALB = 0.99D0
40868 BEB = 0D0
40869 AKB = - 0.193D0 * S
40870 AB = 0D0
40871 BB = 0D0
40872 DBT = 3.447D0 + 0.927D0 * S
40873 EBT = 4.68D0 + 1.259D0 * S
40874 ESB = 1.892D0 + 2.199D0 * S
40875 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40876
40877C...gl :
40878 ALG = 1.014D0
40879 BEG = 1.738D0
40880 AKG = 1.724D0 + 0.157D0 * S
40881 BKG = 0.800D0 + 1.016D0 * S
40882 AG = 7.517D0 - 2.547D0 * S
40883 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40884 CG = 4.039D0 + 1.491D0 * S
40885 DG = 3.404D0 + 0.830D0 * S
40886 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40887 ESG = 3.256D0 - 0.436D0 * S
40888 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40889
40890 RETURN
40891 END
40892
40893C*********************************************************************
40894
40895C...PYGRVD
40896C...Gives the GRV 94 D (DIS) parton distribution function set
40897C...in parametrized form.
40898C...Authors: M. Glueck, E. Reya and A. Vogt.
40899
40900 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40901
40902C...Double precision declaration.
40903 IMPLICIT DOUBLE PRECISION (A - Z)
40904
40905C...Common expressions.
40906 MU2 = 0.34D0
40907 LAM2 = 0.248D0 * 0.248D0
40908 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40909 DS = SQRT (S)
40910 S2 = S * S
40911 S3 = S2 * S
40912
40913C...uv :
40914 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40915 AKU = 0.563D0 - 0.025D0 * S
40916 BKU = 0.054D0 + 0.154D0 * S
40917 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40918 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40919 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40920 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40921 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40922
40923C...dv :
40924 ND = 0.156D0 - 0.017D0 * S
40925 AKD = 0.299D0 - 0.022D0 * S
40926 BKD = 0.259D0 - 0.015D0 * S
40927 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40928 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40929 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40930 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40931 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40932
40933C...del :
40934 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40935 AKE = 0.419D0 - 0.013D0 * S
40936 BKE = 1.064D0 - 0.038D0 * S
40937 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40938 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40939 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40940 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40941 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40942
40943C...udb :
40944 ALX = 1.215D0
40945 BEX = 0.466D0
40946 AKX = 0.326D0 + 0.150D0 * S
40947 BKX = 0.956D0 + 0.405D0 * S
40948 AGX = 0.272D0
40949 BGX = 3.794D0 - 2.359D0 * DS
40950 CX = 2.014D0
40951 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40952 EX = 3.049D0 + 1.597D0 * S
40953 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40954 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40955 & DX, EX, ESX)
40956
40957C...sb :
40958 STS = 0D0
40959 ALS = 0.175D0
40960 BES = 0.344D0
40961 AKS = 1.415D0 - 0.641D0 * DS
40962 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40963 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40964 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40965 EST = 4.546D0 + 0.372D0 * S2
40966 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40967 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40968
40969C...cb :
40970 STC = 0.820D0
40971 ALC = 0.98D0
40972 BEC = 0D0
40973 AKC = -0.625D0 - 0.523D0 * S
40974 AC = 0D0
40975 BC = 1.896D0 + 1.616D0 * S
40976 DCT = 4.12D0 + 0.683D0 * S
40977 ECT = 4.36D0 + 1.328D0 * S
40978 ESC = 0.677D0 + 0.679D0 * S
40979 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40980
40981C...bb :
40982 STB = 1.297D0
40983 ALB = 0.99D0
40984 BEB = 0D0
40985 AKB = - 0.193D0 * S
40986 AB = 0D0
40987 BB = 0D0
40988 DBT = 3.447D0 + 0.927D0 * S
40989 EBT = 4.68D0 + 1.259D0 * S
40990 ESB = 1.892D0 + 2.199D0 * S
40991 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40992
40993C...gl :
40994 ALG = 1.258D0
40995 BEG = 1.846D0
40996 AKG = 2.423D0
40997 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
40998 AG = 25.09D0 - 7.935D0 * S
40999 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41000 CG = 590.3D0 - 173.8D0 * S
41001 DG = 5.196D0 + 1.857D0 * S
41002 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41003 ESG = 3.232D0 - 0.542D0 * S
41004 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41005
41006 RETURN
41007 END
41008
41009C*********************************************************************
41010
41011C...PYGRVV
41012C...Auxiliary for the GRV 94 parton distribution functions
41013C...for u and d valence and d-u sea.
41014C...Authors: M. Glueck, E. Reya and A. Vogt.
41015
41016 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41017
41018C...Double precision declaration.
41019 IMPLICIT DOUBLE PRECISION (A - Z)
41020
41021C...Evaluation.
41022 DX = SQRT (X)
41023 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41024 & (1D0- X)**D
41025
41026 RETURN
41027 END
41028
41029C*********************************************************************
41030
41031C...PYGRVW
41032C...Auxiliary for the GRV 94 parton distribution functions
41033C...for d+u sea and gluon.
41034C...Authors: M. Glueck, E. Reya and A. Vogt.
41035
41036 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41037
41038C...Double precision declaration.
41039 IMPLICIT DOUBLE PRECISION (A - Z)
41040
41041C...Evaluation.
41042 LX = LOG (1D0/X)
41043 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41044 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41045
41046 RETURN
41047 END
41048
41049C*********************************************************************
41050
41051C...PYGRVS
41052C...Auxiliary for the GRV 94 parton distribution functions
41053C...for s, c and b sea.
41054C...Authors: M. Glueck, E. Reya and A. Vogt.
41055
41056 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41057
41058C...Double precision declaration.
41059 IMPLICIT DOUBLE PRECISION (A - Z)
41060
41061C...Evaluation.
41062 IF(S.LE.STH) THEN
41063 PYGRVS = 0D0
41064 ELSE
41065 DX = SQRT (X)
41066 LX = LOG (1D0/X)
41067 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41068 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41069 ENDIF
41070
41071 RETURN
41072 END
41073
41074C*********************************************************************
41075
41076C...PYCT5L
41077C...Auxiliary function for parametrization of CTEQ5L.
41078C...Author: J. Pumplin 9/99.
41079
41080C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41081C...in Parametrized Form
41082C... September 15, 1999
41083C
41084C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41085C... CTEQ5 PPARTON DISTRIBUTIONS"
41086C...hep-ph/9903282
41087
41088C...The CTEQ5M1 set given here is an updated version of the original
41089C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41090C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41091C...almost all applications.
41092C...The improvement is in the QCD evolution which is now more
41093C...accurate, and which agrees completely with the benchmark work
41094C...of the HERA 96/97 Workshop.
41095C...The differences between the parametrized and the corresponding
41096C...table versions (on which it is based) are of similar order as
41097C...between the two version.
41098
41099C...!! Because accurate parametrizations over a wide range of (x,Q)
41100C...is hard to obtain, only the most widely used sets CTEQ5M and
41101C...CTEQ5L are available in parametrized form for now.
41102
41103C...These parametrizations were obtained by Jon Pumplin.
41104
41105C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41106C -------------------------------------------------------------------
41107C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41108C 3 CTEQ5L Leading Order 0.127 192 146
41109C -------------------------------------------------------------------
41110C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41111C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41112C...calibration.
41113
41114C...The two Iset value are adopted to agree with the standard table
41115C...versions.
41116
41117C...Range of validity:
41118C...The range of (x, Q) covered by this parametrization of the QCD
41119C...evolved parton distributions is 1E-6 < x < 1 ;
41120C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41121C...data only in a subset of that region; and the assumed DGLAP
41122C...evolution is unlikely to be valid for all of it either.
41123
41124C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41125C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41126C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41127C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41128
41129 FUNCTION PYCT5L(IFL,X,Q)
41130
41131C...Double precision declaration.
41132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41133 IMPLICIT INTEGER(I-N)
41134
41135 PARAMETER (NEX=8, NLF=2)
41136 DIMENSION AM(0:NEX,0:NLF,-5:2)
41137 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41138 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41139 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41140 DIMENSION AF(0:NEX)
41141
41142 DATA MEXVEC( 2) / 8 /
41143 DATA MLFVEC( 2) / 2 /
41144 DATA UT1VEC( 2) / 0.4971265E+01 /
41145 DATA UT2VEC( 2) / -0.1105128E+01 /
41146 DATA ALFVEC( 2) / 0.2987216E+00 /
41147 DATA QMAVEC( 2) / 0.0000000E+00 /
41148 DATA (AM( 0,K, 2),K=0, 2)
41149 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41150 DATA (AM( 1,K, 2),K=0, 2)
41151 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41152 DATA (AM( 2,K, 2),K=0, 2)
41153 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41154 DATA (AM( 3,K, 2),K=0, 2)
41155 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41156 DATA (AM( 4,K, 2),K=0, 2)
41157 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41158 DATA (AM( 5,K, 2),K=0, 2)
41159 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41160 DATA (AM( 6,K, 2),K=0, 2)
41161 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41162 DATA (AM( 7,K, 2),K=0, 2)
41163 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41164 DATA (AM( 8,K, 2),K=0, 2)
41165 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41166
41167 DATA MEXVEC( 1) / 8 /
41168 DATA MLFVEC( 1) / 2 /
41169 DATA UT1VEC( 1) / 0.2612618E+01 /
41170 DATA UT2VEC( 1) / -0.1258304E+06 /
41171 DATA ALFVEC( 1) / 0.3407552E+00 /
41172 DATA QMAVEC( 1) / 0.0000000E+00 /
41173 DATA (AM( 0,K, 1),K=0, 2)
41174 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41175 DATA (AM( 1,K, 1),K=0, 2)
41176 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41177 DATA (AM( 2,K, 1),K=0, 2)
41178 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41179 DATA (AM( 3,K, 1),K=0, 2)
41180 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41181 DATA (AM( 4,K, 1),K=0, 2)
41182 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41183 DATA (AM( 5,K, 1),K=0, 2)
41184 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41185 DATA (AM( 6,K, 1),K=0, 2)
41186 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41187 DATA (AM( 7,K, 1),K=0, 2)
41188 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41189 DATA (AM( 8,K, 1),K=0, 2)
41190 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41191
41192 DATA MEXVEC( 0) / 8 /
41193 DATA MLFVEC( 0) / 2 /
41194 DATA UT1VEC( 0) / -0.4656819E+00 /
41195 DATA UT2VEC( 0) / -0.2742390E+03 /
41196 DATA ALFVEC( 0) / 0.4491863E+00 /
41197 DATA QMAVEC( 0) / 0.0000000E+00 /
41198 DATA (AM( 0,K, 0),K=0, 2)
41199 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41200 DATA (AM( 1,K, 0),K=0, 2)
41201 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41202 DATA (AM( 2,K, 0),K=0, 2)
41203 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41204 DATA (AM( 3,K, 0),K=0, 2)
41205 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41206 DATA (AM( 4,K, 0),K=0, 2)
41207 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41208 DATA (AM( 5,K, 0),K=0, 2)
41209 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41210 DATA (AM( 6,K, 0),K=0, 2)
41211 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41212 DATA (AM( 7,K, 0),K=0, 2)
41213 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41214 DATA (AM( 8,K, 0),K=0, 2)
41215 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41216
41217 DATA MEXVEC(-1) / 8 /
41218 DATA MLFVEC(-1) / 2 /
41219 DATA UT1VEC(-1) / 0.3862583E+01 /
41220 DATA UT2VEC(-1) / -0.1265969E+01 /
41221 DATA ALFVEC(-1) / 0.2457668E+00 /
41222 DATA QMAVEC(-1) / 0.0000000E+00 /
41223 DATA (AM( 0,K,-1),K=0, 2)
41224 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41225 DATA (AM( 1,K,-1),K=0, 2)
41226 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41227 DATA (AM( 2,K,-1),K=0, 2)
41228 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41229 DATA (AM( 3,K,-1),K=0, 2)
41230 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41231 DATA (AM( 4,K,-1),K=0, 2)
41232 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41233 DATA (AM( 5,K,-1),K=0, 2)
41234 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41235 DATA (AM( 6,K,-1),K=0, 2)
41236 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41237 DATA (AM( 7,K,-1),K=0, 2)
41238 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41239 DATA (AM( 8,K,-1),K=0, 2)
41240 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41241
41242 DATA MEXVEC(-2) / 7 /
41243 DATA MLFVEC(-2) / 2 /
41244 DATA UT1VEC(-2) / 0.1895615E+00 /
41245 DATA UT2VEC(-2) / -0.3069097E+01 /
41246 DATA ALFVEC(-2) / 0.5293999E+00 /
41247 DATA QMAVEC(-2) / 0.0000000E+00 /
41248 DATA (AM( 0,K,-2),K=0, 2)
41249 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41250 DATA (AM( 1,K,-2),K=0, 2)
41251 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41252 DATA (AM( 2,K,-2),K=0, 2)
41253 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41254 DATA (AM( 3,K,-2),K=0, 2)
41255 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41256 DATA (AM( 4,K,-2),K=0, 2)
41257 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41258 DATA (AM( 5,K,-2),K=0, 2)
41259 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41260 DATA (AM( 6,K,-2),K=0, 2)
41261 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41262 DATA (AM( 7,K,-2),K=0, 2)
41263 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41264
41265 DATA MEXVEC(-3) / 7 /
41266 DATA MLFVEC(-3) / 2 /
41267 DATA UT1VEC(-3) / 0.3753257E+01 /
41268 DATA UT2VEC(-3) / -0.1113085E+01 /
41269 DATA ALFVEC(-3) / 0.3713141E+00 /
41270 DATA QMAVEC(-3) / 0.0000000E+00 /
41271 DATA (AM( 0,K,-3),K=0, 2)
41272 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41273 DATA (AM( 1,K,-3),K=0, 2)
41274 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41275 DATA (AM( 2,K,-3),K=0, 2)
41276 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41277 DATA (AM( 3,K,-3),K=0, 2)
41278 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41279 DATA (AM( 4,K,-3),K=0, 2)
41280 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41281 DATA (AM( 5,K,-3),K=0, 2)
41282 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41283 DATA (AM( 6,K,-3),K=0, 2)
41284 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41285 DATA (AM( 7,K,-3),K=0, 2)
41286 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41287
41288 DATA MEXVEC(-4) / 7 /
41289 DATA MLFVEC(-4) / 2 /
41290 DATA UT1VEC(-4) / 0.4400772E+01 /
41291 DATA UT2VEC(-4) / -0.1356116E+01 /
41292 DATA ALFVEC(-4) / 0.3712017E-01 /
41293 DATA QMAVEC(-4) / 0.1300000E+01 /
41294 DATA (AM( 0,K,-4),K=0, 2)
41295 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41296 DATA (AM( 1,K,-4),K=0, 2)
41297 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41298 DATA (AM( 2,K,-4),K=0, 2)
41299 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41300 DATA (AM( 3,K,-4),K=0, 2)
41301 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41302 DATA (AM( 4,K,-4),K=0, 2)
41303 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41304 DATA (AM( 5,K,-4),K=0, 2)
41305 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41306 DATA (AM( 6,K,-4),K=0, 2)
41307 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41308 DATA (AM( 7,K,-4),K=0, 2)
41309 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41310
41311 DATA MEXVEC(-5) / 6 /
41312 DATA MLFVEC(-5) / 2 /
41313 DATA UT1VEC(-5) / 0.5562568E+01 /
41314 DATA UT2VEC(-5) / -0.1801317E+01 /
41315 DATA ALFVEC(-5) / 0.4952010E-02 /
41316 DATA QMAVEC(-5) / 0.4500000E+01 /
41317 DATA (AM( 0,K,-5),K=0, 2)
41318 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41319 DATA (AM( 1,K,-5),K=0, 2)
41320 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41321 DATA (AM( 2,K,-5),K=0, 2)
41322 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41323 DATA (AM( 3,K,-5),K=0, 2)
41324 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41325 DATA (AM( 4,K,-5),K=0, 2)
41326 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41327 DATA (AM( 5,K,-5),K=0, 2)
41328 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41329 DATA (AM( 6,K,-5),K=0, 2)
41330 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41331
41332 IF(Q .LE. QMAVEC(IFL)) THEN
41333 PYCT5L = 0.D0
41334 RETURN
41335 ENDIF
41336
41337 IF(X .GE. 1.D0) THEN
41338 PYCT5L = 0.D0
41339 RETURN
41340 ENDIF
41341
41342 TMP = LOG(Q/ALFVEC(IFL))
41343 IF(TMP .LE. 0.D0) THEN
41344 PYCT5L = 0.D0
41345 RETURN
41346 ENDIF
41347
41348 SB = LOG(TMP)
41349 SB1 = SB - 1.2D0
41350 SB2 = SB1*SB1
41351
41352 DO 110 I = 0, NEX
41353 AF(I) = 0.D0
41354 SBX = 1.D0
41355 DO 100 K = 0, MLFVEC(IFL)
41356 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41357 SBX = SB1*SBX
41358 100 CONTINUE
41359 110 CONTINUE
41360
41361 Y = -LOG(X)
41362 U = LOG(X/0.00001D0)
41363
41364 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41365 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41366 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41367 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41368 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41369
41370 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41371
41372C...Include threshold factor.
41373 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41374
41375 RETURN
41376 END
41377
41378C*********************************************************************
41379
41380C...PYCT5M
41381C...Auxiliary function for parametrization of CTEQ5M1.
41382C...Author: J. Pumplin 9/99.
41383
41384 FUNCTION PYCT5M(IFL,X,Q)
41385
41386C...Double precision declaration.
41387 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41388 IMPLICIT INTEGER(I-N)
41389
41390 PARAMETER (NEX=8, NLF=2)
41391 DIMENSION AM(0:NEX,0:NLF,-5:2)
41392 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41393 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41394 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41395 DIMENSION AF(0:NEX)
41396
41397 DATA MEXVEC( 2) / 8 /
41398 DATA MLFVEC( 2) / 2 /
41399 DATA UT1VEC( 2) / 0.5141718E+01 /
41400 DATA UT2VEC( 2) / -0.1346944E+01 /
41401 DATA ALFVEC( 2) / 0.5260555E+00 /
41402 DATA QMAVEC( 2) / 0.0000000E+00 /
41403 DATA (AM( 0,K, 2),K=0, 2)
41404 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41405 DATA (AM( 1,K, 2),K=0, 2)
41406 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41407 DATA (AM( 2,K, 2),K=0, 2)
41408 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41409 DATA (AM( 3,K, 2),K=0, 2)
41410 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41411 DATA (AM( 4,K, 2),K=0, 2)
41412 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41413 DATA (AM( 5,K, 2),K=0, 2)
41414 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41415 DATA (AM( 6,K, 2),K=0, 2)
41416 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41417 DATA (AM( 7,K, 2),K=0, 2)
41418 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41419 DATA (AM( 8,K, 2),K=0, 2)
41420 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41421
41422 DATA MEXVEC( 1) / 8 /
41423 DATA MLFVEC( 1) / 2 /
41424 DATA UT1VEC( 1) / 0.4138426E+01 /
41425 DATA UT2VEC( 1) / -0.3221374E+01 /
41426 DATA ALFVEC( 1) / 0.4960962E+00 /
41427 DATA QMAVEC( 1) / 0.0000000E+00 /
41428 DATA (AM( 0,K, 1),K=0, 2)
41429 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41430 DATA (AM( 1,K, 1),K=0, 2)
41431 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41432 DATA (AM( 2,K, 1),K=0, 2)
41433 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41434 DATA (AM( 3,K, 1),K=0, 2)
41435 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41436 DATA (AM( 4,K, 1),K=0, 2)
41437 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41438 DATA (AM( 5,K, 1),K=0, 2)
41439 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41440 DATA (AM( 6,K, 1),K=0, 2)
41441 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41442 DATA (AM( 7,K, 1),K=0, 2)
41443 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41444 DATA (AM( 8,K, 1),K=0, 2)
41445 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41446
41447 DATA MEXVEC( 0) / 8 /
41448 DATA MLFVEC( 0) / 2 /
41449 DATA UT1VEC( 0) / -0.1026789E+01 /
41450 DATA UT2VEC( 0) / -0.9051707E+01 /
41451 DATA ALFVEC( 0) / 0.9462977E+00 /
41452 DATA QMAVEC( 0) / 0.0000000E+00 /
41453 DATA (AM( 0,K, 0),K=0, 2)
41454 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41455 DATA (AM( 1,K, 0),K=0, 2)
41456 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41457 DATA (AM( 2,K, 0),K=0, 2)
41458 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41459 DATA (AM( 3,K, 0),K=0, 2)
41460 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41461 DATA (AM( 4,K, 0),K=0, 2)
41462 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41463 DATA (AM( 5,K, 0),K=0, 2)
41464 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41465 DATA (AM( 6,K, 0),K=0, 2)
41466 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41467 DATA (AM( 7,K, 0),K=0, 2)
41468 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41469 DATA (AM( 8,K, 0),K=0, 2)
41470 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41471
41472 DATA MEXVEC(-1) / 8 /
41473 DATA MLFVEC(-1) / 2 /
41474 DATA UT1VEC(-1) / 0.5243571E+01 /
41475 DATA UT2VEC(-1) / -0.2870513E+01 /
41476 DATA ALFVEC(-1) / 0.6701448E+00 /
41477 DATA QMAVEC(-1) / 0.0000000E+00 /
41478 DATA (AM( 0,K,-1),K=0, 2)
41479 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41480 DATA (AM( 1,K,-1),K=0, 2)
41481 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41482 DATA (AM( 2,K,-1),K=0, 2)
41483 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41484 DATA (AM( 3,K,-1),K=0, 2)
41485 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41486 DATA (AM( 4,K,-1),K=0, 2)
41487 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41488 DATA (AM( 5,K,-1),K=0, 2)
41489 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41490 DATA (AM( 6,K,-1),K=0, 2)
41491 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41492 DATA (AM( 7,K,-1),K=0, 2)
41493 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41494 DATA (AM( 8,K,-1),K=0, 2)
41495 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41496
41497 DATA MEXVEC(-2) / 7 /
41498 DATA MLFVEC(-2) / 2 /
41499 DATA UT1VEC(-2) / 0.4782210E+01 /
41500 DATA UT2VEC(-2) / -0.1976856E+02 /
41501 DATA ALFVEC(-2) / 0.7558374E+00 /
41502 DATA QMAVEC(-2) / 0.0000000E+00 /
41503 DATA (AM( 0,K,-2),K=0, 2)
41504 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41505 DATA (AM( 1,K,-2),K=0, 2)
41506 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41507 DATA (AM( 2,K,-2),K=0, 2)
41508 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41509 DATA (AM( 3,K,-2),K=0, 2)
41510 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41511 DATA (AM( 4,K,-2),K=0, 2)
41512 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41513 DATA (AM( 5,K,-2),K=0, 2)
41514 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41515 DATA (AM( 6,K,-2),K=0, 2)
41516 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41517 DATA (AM( 7,K,-2),K=0, 2)
41518 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41519
41520 DATA MEXVEC(-3) / 7 /
41521 DATA MLFVEC(-3) / 2 /
41522 DATA UT1VEC(-3) / 0.4518239E+01 /
41523 DATA UT2VEC(-3) / -0.2690590E+01 /
41524 DATA ALFVEC(-3) / 0.6124079E+00 /
41525 DATA QMAVEC(-3) / 0.0000000E+00 /
41526 DATA (AM( 0,K,-3),K=0, 2)
41527 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41528 DATA (AM( 1,K,-3),K=0, 2)
41529 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41530 DATA (AM( 2,K,-3),K=0, 2)
41531 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41532 DATA (AM( 3,K,-3),K=0, 2)
41533 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41534 DATA (AM( 4,K,-3),K=0, 2)
41535 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41536 DATA (AM( 5,K,-3),K=0, 2)
41537 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41538 DATA (AM( 6,K,-3),K=0, 2)
41539 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41540 DATA (AM( 7,K,-3),K=0, 2)
41541 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41542
41543 DATA MEXVEC(-4) / 7 /
41544 DATA MLFVEC(-4) / 2 /
41545 DATA UT1VEC(-4) / 0.2783230E+01 /
41546 DATA UT2VEC(-4) / -0.1746328E+01 /
41547 DATA ALFVEC(-4) / 0.1115653E+01 /
41548 DATA QMAVEC(-4) / 0.1300000E+01 /
41549 DATA (AM( 0,K,-4),K=0, 2)
41550 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41551 DATA (AM( 1,K,-4),K=0, 2)
41552 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41553 DATA (AM( 2,K,-4),K=0, 2)
41554 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41555 DATA (AM( 3,K,-4),K=0, 2)
41556 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41557 DATA (AM( 4,K,-4),K=0, 2)
41558 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41559 DATA (AM( 5,K,-4),K=0, 2)
41560 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41561 DATA (AM( 6,K,-4),K=0, 2)
41562 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41563 DATA (AM( 7,K,-4),K=0, 2)
41564 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41565
41566 DATA MEXVEC(-5) / 6 /
41567 DATA MLFVEC(-5) / 2 /
41568 DATA UT1VEC(-5) / 0.1619654E+02 /
41569 DATA UT2VEC(-5) / -0.3367346E+01 /
41570 DATA ALFVEC(-5) / 0.5109891E-02 /
41571 DATA QMAVEC(-5) / 0.4500000E+01 /
41572 DATA (AM( 0,K,-5),K=0, 2)
41573 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41574 DATA (AM( 1,K,-5),K=0, 2)
41575 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41576 DATA (AM( 2,K,-5),K=0, 2)
41577 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41578 DATA (AM( 3,K,-5),K=0, 2)
41579 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41580 DATA (AM( 4,K,-5),K=0, 2)
41581 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41582 DATA (AM( 5,K,-5),K=0, 2)
41583 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41584 DATA (AM( 6,K,-5),K=0, 2)
41585 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41586
41587 IF(Q .LE. QMAVEC(IFL)) THEN
41588 PYCT5M = 0.D0
41589 RETURN
41590 ENDIF
41591
41592 IF(X .GE. 1.D0) THEN
41593 PYCT5M = 0.D0
41594 RETURN
41595 ENDIF
41596
41597 TMP = LOG(Q/ALFVEC(IFL))
41598 IF(TMP .LE. 0.D0) THEN
41599 PYCT5M = 0.D0
41600 RETURN
41601 ENDIF
41602
41603 SB = LOG(TMP)
41604 SB1 = SB - 1.2D0
41605 SB2 = SB1*SB1
41606
41607 DO 110 I = 0, NEX
41608 AF(I) = 0.D0
41609 SBX = 1.D0
41610 DO 100 K = 0, MLFVEC(IFL)
41611 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41612 SBX = SB1*SBX
41613 100 CONTINUE
41614 110 CONTINUE
41615
41616 Y = -LOG(X)
41617 U = LOG(X/0.00001D0)
41618
41619 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41620 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41621 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41622 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41623 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41624
41625 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41626
41627C...Include threshold factor.
41628 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41629
41630 RETURN
41631 END
41632
41633C*********************************************************************
41634
41635C...PYPDPO
41636C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41637C...a few older parametrizations, now obsolete but convenient for
41638C...backwards checks.
41639
41640 SUBROUTINE PYPDPO(X,Q2,XPPR)
41641
41642C...Double precision and integer declarations.
41643 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41644 IMPLICIT INTEGER(I-N)
41645 INTEGER PYK,PYCHGE,PYCOMP
41646C...Commonblocks.
41647 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41648 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41649 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41650 COMMON/PYINT1/MINT(400),VINT(400)
41651 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41652 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41653 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41654
41655
41656C...The following data lines are coefficients needed in the
41657C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41658C...parametrizations, see below.
41659C...Powers of 1-x in different cases.
41660 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41661C...Expansion coefficients for up valence quark distribution.
41662 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41663 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41664 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41665 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41666 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41667 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41668 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41669 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41670 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41671 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41672 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41673 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41674 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41675 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41676 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41677 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41678 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41679 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41680 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41681 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41682 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41683 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41684 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41685 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41686 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41687 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41688C...Expansion coefficients for down valence quark distribution.
41689 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41690 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41691 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41692 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41693 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41694 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41695 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41696 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41697 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41698 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41699 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41700 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41701 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41702 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41703 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41704 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41705 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41706 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41707 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41708 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41709 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41710 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41711 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41712 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41713 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41714 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41715C...Expansion coefficients for up and down sea quark distributions.
41716 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41717 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41718 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41719 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41720 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41721 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41722 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41723 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41724 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41725 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41726 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41727 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41728 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41729 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41730 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41731 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41732 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41733 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41734 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41735 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41736 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41737 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41738 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41739 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41740 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41741 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41742C...Expansion coefficients for gluon distribution.
41743 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41744 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41745 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41746 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41747 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41748 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41749 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41750 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41751 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41752 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41753 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41754 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41755 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41756 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41757 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41758 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41759 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41760 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41761 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41762 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41763 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41764 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41765 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41766 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41767 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41768 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41769C...Expansion coefficients for strange sea quark distribution.
41770 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41771 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41772 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41773 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41774 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41775 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41776 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41777 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41778 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41779 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41780 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41781 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41782 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41783 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41784 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41785 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41786 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41787 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41788 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41789 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41790 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41791 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41792 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41793 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41794 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41795 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41796C...Expansion coefficients for charm sea quark distribution.
41797 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41798 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41799 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41800 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41801 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41802 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41803 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41804 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41805 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41806 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41807 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41808 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41809 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41810 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41811 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41812 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41813 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41814 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41815 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41816 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41817 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41818 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41819 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41820 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41821 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41822 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41823C...Expansion coefficients for bottom sea quark distribution.
41824 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41825 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41826 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41827 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41828 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41829 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41830 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41831 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41832 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41833 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41834 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41835 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41836 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41837 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41838 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41839 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41840 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41841 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41842 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41843 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41844 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41845 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41846 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41847 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41848 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41849 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41850C...Expansion coefficients for top sea quark distribution.
41851 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41852 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41853 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41854 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41855 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41856 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41857 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41858 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41859 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41860 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41861 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41862 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41863 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41864 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41865 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41866 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41867 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41868 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41869 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41870 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41871 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41872 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41873 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41874 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41875 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41876 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41877
41878C...The following data lines are coefficients needed in the
41879C...Duke, Owens proton structure function parametrizations, see below.
41880C...Expansion coefficients for (up+down) valence quark distribution.
41881 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41882 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41883 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41884 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41885 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41886 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41887 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41888 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41889C...Expansion coefficients for down valence quark distribution.
41890 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41891 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41893 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41894 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41895 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41898C...Expansion coefficients for (up+down+strange) sea quark distribution.
41899 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41900 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41901 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41902 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41903 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41904 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41906 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41907C...Expansion coefficients for charm sea quark distribution.
41908 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41909 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41910 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41911 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41912 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41913 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41915 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41916C...Expansion coefficients for gluon distribution.
41917 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41918 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41919 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41920 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41921 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41922 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41923 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41924 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41925
41926C...Euler's beta function, requires ordinary Gamma function
41927 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41928
41929C...Leading order proton parton distributions from Glueck, Reya and
41930C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41931C...10^-5 < x < 1.
41932 IF(MSTP(51).EQ.11) THEN
41933
41934C...Determine s expansion variable and some x expressions.
41935 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41936 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41937 SD2=SD**2
41938 XL=-LOG(X)
41939 XS=SQRT(X)
41940
41941C...Evaluate valence, gluon and sea distributions.
41942 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41943 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41944 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41945 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41946 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41947 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41948 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41949 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41950 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41951 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41952 & SQRT(4.066D0*SD**1.218D0*XL)))*
41953 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41954 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41955 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41956 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41957 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41958 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41959 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41960 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41961 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41962 IF(SD.LE.0.888D0) THEN
41963 XFCHM=0D0
41964 ELSE
41965 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41966 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41967 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41968 ENDIF
41969 IF(SD.LE.1.351D0) THEN
41970 XFBOT=0D0
41971 ELSE
41972 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41973 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41974 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41975 ENDIF
41976
41977C...Put into output array.
41978 XPPR(0)=XFGLU
41979 XPPR(1)=XFVDD+XFSEA
41980 XPPR(2)=XFVUD-XFVDD+XFSEA
41981 XPPR(3)=XFSTR
41982 XPPR(4)=XFCHM
41983 XPPR(5)=XFBOT
41984 XPPR(-1)=XFSEA
41985 XPPR(-2)=XFSEA
41986 XPPR(-3)=XFSTR
41987 XPPR(-4)=XFCHM
41988 XPPR(-5)=XFBOT
41989
41990C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
41991C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
41992 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
41993
41994C...Determine set, Lambda and x and t expansion variables.
41995 NSET=MSTP(51)-11
41996 IF(NSET.EQ.1) ALAM=0.2D0
41997 IF(NSET.EQ.2) ALAM=0.29D0
41998 TMIN=LOG(5D0/ALAM**2)
41999 TMAX=LOG(1D8/ALAM**2)
42000 T=LOG(MAX(1D0,Q2/ALAM**2))
42001 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42002 NX=1
42003 IF(X.LE.0.1D0) NX=2
42004 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42005 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42006
42007C...Chebyshev polynomials for x and t expansion.
42008 TX(1)=1D0
42009 TX(2)=VX
42010 TX(3)=2D0*VX**2-1D0
42011 TX(4)=4D0*VX**3-3D0*VX
42012 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42013 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42014 TT(1)=1D0
42015 TT(2)=VT
42016 TT(3)=2D0*VT**2-1D0
42017 TT(4)=4D0*VT**3-3D0*VT
42018 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42019 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42020
42021C...Calculate structure functions.
42022 DO 120 KFL=1,6
42023 XQSUM=0D0
42024 DO 110 IT=1,6
42025 DO 100 IX=1,6
42026 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42027 100 CONTINUE
42028 110 CONTINUE
42029 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42030 120 CONTINUE
42031
42032C...Put into output array.
42033 XPPR(0)=XQ(4)
42034 XPPR(1)=XQ(2)+XQ(3)
42035 XPPR(2)=XQ(1)+XQ(3)
42036 XPPR(3)=XQ(5)
42037 XPPR(4)=XQ(6)
42038 XPPR(-1)=XQ(3)
42039 XPPR(-2)=XQ(3)
42040 XPPR(-3)=XQ(5)
42041 XPPR(-4)=XQ(6)
42042
42043C...Special expansion for bottom (threshold effects).
42044 IF(MSTP(58).GE.5) THEN
42045 IF(NSET.EQ.1) TMIN=8.1905D0
42046 IF(NSET.EQ.2) TMIN=7.4474D0
42047 IF(T.GT.TMIN) THEN
42048 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42049 TT(1)=1D0
42050 TT(2)=VT
42051 TT(3)=2D0*VT**2-1D0
42052 TT(4)=4D0*VT**3-3D0*VT
42053 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42054 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42055 XQSUM=0D0
42056 DO 140 IT=1,6
42057 DO 130 IX=1,6
42058 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42059 130 CONTINUE
42060 140 CONTINUE
42061 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42062 XPPR(-5)=XPPR(5)
42063 ENDIF
42064 ENDIF
42065
42066C...Special expansion for top (threshold effects).
42067 IF(MSTP(58).GE.6) THEN
42068 IF(NSET.EQ.1) TMIN=11.5528D0
42069 IF(NSET.EQ.2) TMIN=10.8097D0
42070 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42071 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42072 IF(T.GT.TMIN) THEN
42073 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42074 TT(1)=1D0
42075 TT(2)=VT
42076 TT(3)=2D0*VT**2-1D0
42077 TT(4)=4D0*VT**3-3D0*VT
42078 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42079 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42080 XQSUM=0D0
42081 DO 160 IT=1,6
42082 DO 150 IX=1,6
42083 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42084 150 CONTINUE
42085 160 CONTINUE
42086 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42087 XPPR(-6)=XPPR(6)
42088 ENDIF
42089 ENDIF
42090
42091C...Proton parton distributions from Duke, Owens.
42092C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42093 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42094
42095C...Determine set, Lambda and s expansion parameter.
42096 NSET=MSTP(51)-13
42097 IF(NSET.EQ.1) ALAM=0.2D0
42098 IF(NSET.EQ.2) ALAM=0.4D0
42099 Q2IN=MIN(1D6,MAX(4D0,Q2))
42100 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42101
42102C...Calculate structure functions.
42103 DO 180 KFL=1,5
42104 DO 170 IS=1,6
42105 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42106 & CDO(3,IS,KFL,NSET)*SD**2
42107 170 CONTINUE
42108 IF(KFL.LE.2) THEN
42109 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42110 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42111 ELSE
42112 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42113 & TS(5)*X**2+TS(6)*X**3)
42114 ENDIF
42115 180 CONTINUE
42116
42117C...Put into output arrays.
42118 XPPR(0)=XQ(5)
42119 XPPR(1)=XQ(2)+XQ(3)/6D0
42120 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42121 XPPR(3)=XQ(3)/6D0
42122 XPPR(4)=XQ(4)
42123 XPPR(-1)=XQ(3)/6D0
42124 XPPR(-2)=XQ(3)/6D0
42125 XPPR(-3)=XQ(3)/6D0
42126 XPPR(-4)=XQ(4)
42127
42128 ENDIF
42129
42130 RETURN
42131 END
42132
42133C*********************************************************************
42134
42135C...PYHFTH
42136C...Gives threshold attractive/repulsive factor for heavy flavour
42137C...production.
42138
42139 FUNCTION PYHFTH(SH,SQM,FRATT)
42140
42141C...Double precision and integer declarations.
42142 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42143 IMPLICIT INTEGER(I-N)
42144 INTEGER PYK,PYCHGE,PYCOMP
42145C...Commonblocks.
42146 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42147 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42148 COMMON/PYINT1/MINT(400),VINT(400)
42149 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42150
42151C...Value for alpha_strong.
42152 IF(MSTP(35).LE.1) THEN
42153 ALSSG=PARP(35)
42154 ELSE
42155 MST115=MSTU(115)
42156 MSTU(115)=MSTP(36)
42157 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42158 & PARP(36)**2)))
42159 ALSSG=PYALPS(Q2BN)
42160 MSTU(115)=MST115
42161 ENDIF
42162
42163C...Evaluate attractive and repulsive factors.
42164 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42165 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42166 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42167 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42168 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42169 VINT(138)=PYHFTH
42170
42171 RETURN
42172 END
42173
42174C*********************************************************************
42175
42176C...PYSPLI
42177C...Splits a hadron remnant into two (partons or hadron + parton)
42178C...in case it is more complicated than just a quark or a diquark.
42179
42180 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42181
42182C...Double precision and integer declarations.
42183 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42184 IMPLICIT INTEGER(I-N)
42185 INTEGER PYK,PYCHGE,PYCOMP
42186C...Commonblocks. PYDAT1 temporary
42187 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42188 COMMON/PYINT1/MINT(400),VINT(400)
42189 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42190 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42191C...Local array.
42192 DIMENSION KFL(3)
42193
42194C...Preliminaries. Parton composition.
42195 KFA=IABS(KF)
42196 KFS=ISIGN(1,KF)
42197 KFL(1)=MOD(KFA/1000,10)
42198 KFL(2)=MOD(KFA/100,10)
42199 KFL(3)=MOD(KFA/10,10)
42200 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42201 KFL(2)=INT(1.5D0+PYR(0))
42202 IF(MINT(105).EQ.333) KFL(2)=3
42203 IF(MINT(105).EQ.443) KFL(2)=4
42204 KFL(3)=KFL(2)
42205 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42206 KFL(2)=2
42207 KFL(3)=2
42208 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42209 KFL(2)=1
42210 KFL(3)=1
42211 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42212 KFL(2)=MOD(KFA/10,10)
42213 KFL(3)=MOD(KFA/100,10)
42214 ENDIF
42215 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42216 KFLR=KFLIN*KFS
42217 ELSE
42218 KFLR=KFLIN
42219 ENDIF
42220 KFLCH=0
42221
42222C...Subdivide lepton.
42223 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42224 IF(KFLR.EQ.KFA) THEN
42225 KFLSP=KFS*22
42226 ELSEIF(KFLR.EQ.22) THEN
42227 KFLSP=KFA
42228 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42229 KFLSP=KFA+1
42230 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42231 KFLSP=KFA-1
42232 ELSEIF(KFLR.EQ.21) THEN
42233 KFLSP=KFA
42234 KFLCH=KFS*21
42235 ELSE
42236 KFLSP=KFA
42237 KFLCH=-KFLR
42238 ENDIF
42239
42240C...Subdivide photon.
42241 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42242 IF(KFLR.NE.21) THEN
42243 KFLSP=-KFLR
42244 ELSE
42245 RAGR=0.75D0*PYR(0)
42246 KFLSP=1
42247 IF(RAGR.GT.0.125D0) KFLSP=2
42248 IF(RAGR.GT.0.625D0) KFLSP=3
42249 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42250 KFLCH=-KFLSP
42251 ENDIF
42252
42253C...Subdivide Reggeon or Pomeron.
42254 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42255 IF(KFLIN.EQ.21) THEN
42256 KFLSP=KFS*21
42257 ELSE
42258 KFLSP=-KFLIN
42259 ENDIF
42260
42261C...Subdivide meson.
42262 ELSEIF(KFL(1).EQ.0) THEN
42263 KFL(2)=KFL(2)*(-1)**KFL(2)
42264 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42265 IF(KFLR.EQ.KFL(2)) THEN
42266 KFLSP=KFL(3)
42267 ELSEIF(KFLR.EQ.KFL(3)) THEN
42268 KFLSP=KFL(2)
42269 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42270 KFLSP=KFL(2)
42271 KFLCH=KFL(3)
42272 ELSEIF(KFLR.EQ.21) THEN
42273 KFLSP=KFL(3)
42274 KFLCH=KFL(2)
42275 ELSEIF(KFLR*KFL(2).GT.0) THEN
42276 NTRY=0
42277 100 NTRY=NTRY+1
42278 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42279 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42280 GOTO 100
42281 ELSEIF(KFLCH.EQ.0) THEN
42282 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42283 MINT(51)=1
42284 RETURN
42285 ENDIF
42286 KFLSP=KFL(3)
42287 ELSE
42288 NTRY=0
42289 110 NTRY=NTRY+1
42290 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42291 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42292 GOTO 110
42293 ELSEIF(KFLCH.EQ.0) THEN
42294 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42295 MINT(51)=1
42296 RETURN
42297 ENDIF
42298 KFLSP=KFL(2)
42299 ENDIF
42300
42301C...Special case for extracting photon from baryon without splitting
42302C...the latter. (Currently only used by external programs.)
42303 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42304 KFLSP=KFA
42305 KFLCH=0
42306
42307C...Subdivide baryon.
42308 ELSE
42309 NAGR=0
42310 DO 120 J=1,3
42311 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42312 120 CONTINUE
42313 IF(NAGR.GE.1) THEN
42314 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42315 IAGR=0
42316 DO 130 J=1,3
42317 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42318 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42319 130 CONTINUE
42320 ELSE
42321 IAGR=1.00001D0+2.99998D0*PYR(0)
42322 ENDIF
42323 ID1=1
42324 IF(IAGR.EQ.1) ID1=2
42325 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42326 ID2=6-IAGR-ID1
42327 KSP=3
42328 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42329 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42330 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42331 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42332 ELSEIF(MOD(KFA,10).EQ.2) THEN
42333 IF(IAGR.EQ.1) KSP=1
42334 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42335 ENDIF
42336 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42337 IF(KFLR.EQ.21) THEN
42338 KFLCH=KFL(IAGR)
42339 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42340 NTRY=0
42341 140 NTRY=NTRY+1
42342 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42343 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42344 GOTO 140
42345 ELSEIF(KFLCH.EQ.0) THEN
42346 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42347 MINT(51)=1
42348 RETURN
42349 ENDIF
42350 ELSEIF(NAGR.EQ.0) THEN
42351 NTRY=0
42352 150 NTRY=NTRY+1
42353 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42354 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42355 GOTO 150
42356 ELSEIF(KFLCH.EQ.0) THEN
42357 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42358 MINT(51)=1
42359 RETURN
42360 ENDIF
42361 KFLSP=KFL(IAGR)
42362 ENDIF
42363 ENDIF
42364
42365C...Add on correct sign for result.
42366 KFLCH=KFLCH*KFS
42367 KFLSP=KFLSP*KFS
42368
42369 RETURN
42370 END
42371
42372C*********************************************************************
42373
42374C...PYGAMM
42375C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42376C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42377C...(Dover, 1965) 6.1.36.
42378
42379 FUNCTION PYGAMM(X)
42380
42381C...Double precision and integer declarations.
42382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42383 IMPLICIT INTEGER(I-N)
42384 INTEGER PYK,PYCHGE,PYCOMP
42385C...Local array and data.
42386 DIMENSION B(8)
42387 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42388 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42389
42390 NX=INT(X)
42391 DX=X-NX
42392
42393 PYGAMM=1D0
42394 DXP=1D0
42395 DO 100 I=1,8
42396 DXP=DXP*DX
42397 PYGAMM=PYGAMM+B(I)*DXP
42398 100 CONTINUE
42399 IF(X.LT.1D0) THEN
42400 PYGAMM=PYGAMM/X
42401 ELSE
42402 DO 110 IX=1,NX-1
42403 PYGAMM=(X-IX)*PYGAMM
42404 110 CONTINUE
42405 ENDIF
42406
42407 RETURN
42408 END
42409
42410C***********************************************************************
42411
42412C...PYWAUX
42413C...Calculates real and imaginary parts of the auxiliary functions W1
42414C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42415C...der Bij, Nucl. Phys. B297 (1988) 221.
42416
42417 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42418
42419C...Double precision and integer declarations.
42420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42421 IMPLICIT INTEGER(I-N)
42422 INTEGER PYK,PYCHGE,PYCOMP
42423C...Commonblocks.
42424 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42425 SAVE /PYDAT1/
42426
42427 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42428 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42429
42430 IF(EPS.LT.0D0) THEN
42431 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42432 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42433 WIM=0D0
42434 ELSEIF(EPS.LT.1D0) THEN
42435 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42436 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42437 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42438 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42439 ELSE
42440 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42441 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42442 WIM=0D0
42443 ENDIF
42444
42445 RETURN
42446 END
42447
42448C***********************************************************************
42449
42450C...PYI3AU
42451C...Calculates real and imaginary parts of the auxiliary function I3;
42452C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42453C...Nucl. Phys. B297 (1988) 221.
42454
42455 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42456
42457C...Double precision and integer declarations.
42458 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42459 IMPLICIT INTEGER(I-N)
42460 INTEGER PYK,PYCHGE,PYCOMP
42461C...Commonblocks.
42462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42463 SAVE /PYDAT1/
42464
42465 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42466 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42467
42468 IF(EPS.LT.0D0) THEN
42469 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42470 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42471 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42472 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42473 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42474 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42475 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42476 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42477 & EPS))
42478 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42479 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42480 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42481 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42482 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42483 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42484 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42485 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42486 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42487 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42488 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42489 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42490 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42491 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42492 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42493 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42494 ELSE
42495 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42496 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42497 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42498 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42499 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42500 ENDIF
42501 F3IM=0D0
42502 ELSEIF(EPS.LT.1D0) THEN
42503 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42504 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42505 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42506 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42507 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42508 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42509 & (0.25D0*(RAT+1D0)*EPS))
42510 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42511 & (0.25D0*(RAT+1D0)*EPS))
42512 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42513 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42514 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42515 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42516 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42517 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42518 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42519 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42520 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42521 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42522 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42523 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42524 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42525 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42526 & (1D0+0.25D0*RAT*EPS-GA))
42527 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42528 & (1D0+0.25D0*RAT*EPS-GA))
42529 ELSE
42530 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42531 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42532 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42533 & LOG((GA+BE-1D0)/(BE-GA))
42534 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42535 ENDIF
42536 ELSE
42537 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42538 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42539 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42540 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42541 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42542 R=SQRT(RSQ)
42543 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42544 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42545 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42546 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42547 & (PHI-THE)*(PHI+THE-PARU(1))
42548 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42549 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42550 ENDIF
42551
42552 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42553 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42554
42555 RETURN
42556 END
42557
42558C***********************************************************************
42559
42560C...PYSPEN
42561C...Calculates real and imaginary part of Spence function; see
42562C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42563
42564 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42565
42566C...Double precision and integer declarations.
42567 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42568 IMPLICIT INTEGER(I-N)
42569 INTEGER PYK,PYCHGE,PYCOMP
42570C...Commonblocks.
42571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42572 SAVE /PYDAT1/
42573C...Local array and data.
42574 DIMENSION B(0:14)
42575 DATA B/
42576 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42577 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42578 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42579 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42580 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42581
42582 XRE=XREIN
42583 XIM=XIMIN
42584 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42585 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42586 IF(IREIM.EQ.2) PYSPEN=0D0
42587 RETURN
42588 ENDIF
42589
42590 XMOD=SQRT(XRE**2+XIM**2)
42591 IF(XMOD.LT.1D-6) THEN
42592 IF(IREIM.EQ.1) PYSPEN=0D0
42593 IF(IREIM.EQ.2) PYSPEN=0D0
42594 RETURN
42595 ENDIF
42596
42597 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42598 SP0RE=0D0
42599 SP0IM=0D0
42600 SGN=1D0
42601 IF(XMOD.GT.1D0) THEN
42602 ALGXRE=LOG(XMOD)
42603 ALGXIM=XARG-SIGN(PARU(1),XARG)
42604 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42605 SP0IM=-ALGXRE*ALGXIM
42606 SGN=-1D0
42607 XMOD=1D0/XMOD
42608 XARG=-XARG
42609 XRE=XMOD*COS(XARG)
42610 XIM=XMOD*SIN(XARG)
42611 ENDIF
42612 IF(XRE.GT.0.5D0) THEN
42613 ALGXRE=LOG(XMOD)
42614 ALGXIM=XARG
42615 XRE=1D0-XRE
42616 XIM=-XIM
42617 XMOD=SQRT(XRE**2+XIM**2)
42618 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42619 ALGYRE=LOG(XMOD)
42620 ALGYIM=XARG
42621 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42622 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42623 SGN=-SGN
42624 ENDIF
42625
42626 XRE=1D0-XRE
42627 XIM=-XIM
42628 XMOD=SQRT(XRE**2+XIM**2)
42629 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42630 ZRE=-LOG(XMOD)
42631 ZIM=-XARG
42632
42633 SPRE=0D0
42634 SPIM=0D0
42635 SAVERE=1D0
42636 SAVEIM=0D0
42637 DO 100 I=0,14
42638 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42639 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42640 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42641 SAVERE=TERMRE
42642 SAVEIM=TERMIM
42643 SPRE=SPRE+B(I)*TERMRE
42644 SPIM=SPIM+B(I)*TERMIM
42645 100 CONTINUE
42646
42647 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42648 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42649
42650 RETURN
42651 END
42652
42653C***********************************************************************
42654
42655C...PYQQBH
42656C...Calculates the matrix element for the processes
42657C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42658C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42659C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42660
42661 SUBROUTINE PYQQBH(WTQQBH)
42662
42663C...Double precision and integer declarations.
42664 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42665 IMPLICIT INTEGER(I-N)
42666 INTEGER PYK,PYCHGE,PYCOMP
42667C...Commonblocks.
42668 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42669 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42670 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42671 COMMON/PYINT1/MINT(400),VINT(400)
42672 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42673 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42674C...Local arrays and function.
42675 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42676 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42677 &PP(I,3)*PP(J,3)
42678
42679C...Mass parameters.
42680 WTQQBH=0D0
42681 ISUB=MINT(1)
42682 SHPR=SQRT(VINT(26))*VINT(1)
42683 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42684 PH=SQRT(VINT(21))*VINT(1)
42685 SPQ=PQ**2
42686 SPH=PH**2
42687
42688C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42689 DO 100 I=1,2
42690 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42691 PP(I,1)=PT*COS(VINT(198+5*I))
42692 PP(I,2)=PT*SIN(VINT(198+5*I))
42693 100 CONTINUE
42694 PP(3,1)=-PP(1,1)-PP(2,1)
42695 PP(3,2)=-PP(1,2)-PP(2,2)
42696 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42697 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42698 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42699 PMT3=SQRT(PMS3)
42700 PP(3,3)=PMT3*SINH(VINT(211))
42701 PP(3,4)=PMT3*COSH(VINT(211))
42702 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42703 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42704 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42705 PP(2,3)=-PP(1,3)-PP(3,3)
42706 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42707 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42708
42709C...Set up incoming kinematics and derived momentum combinations.
42710 DO 110 I=4,5
42711 PP(I,1)=0D0
42712 PP(I,2)=0D0
42713 PP(I,3)=-0.5D0*SHPR*(-1)**I
42714 PP(I,4)=-0.5D0*SHPR
42715 110 CONTINUE
42716 DO 120 J=1,4
42717 PP(6,J)=PP(1,J)+PP(2,J)
42718 PP(7,J)=PP(1,J)+PP(3,J)
42719 PP(8,J)=PP(1,J)+PP(4,J)
42720 PP(9,J)=PP(1,J)+PP(5,J)
42721 PP(10,J)=-PP(2,J)-PP(3,J)
42722 PP(11,J)=-PP(2,J)-PP(4,J)
42723 PP(12,J)=-PP(2,J)-PP(5,J)
42724 PP(13,J)=-PP(4,J)-PP(5,J)
42725 120 CONTINUE
42726
42727C...Derived kinematics invariants.
42728 X1=DOT(1,2)
42729 X2=DOT(1,3)
42730 X3=DOT(1,4)
42731 X4=DOT(1,5)
42732 X5=DOT(2,3)
42733 X6=DOT(2,4)
42734 X7=DOT(2,5)
42735 X8=DOT(3,4)
42736 X9=DOT(3,5)
42737 X10=DOT(4,5)
42738
42739C...Propagators.
42740 SS1=DOT(7,7)-SPQ
42741 SS2=DOT(8,8)-SPQ
42742 SS3=DOT(9,9)-SPQ
42743 SS4=DOT(10,10)-SPQ
42744 SS5=DOT(11,11)-SPQ
42745 SS6=DOT(12,12)-SPQ
42746 SS7=DOT(13,13)
42747 DX(1)=SS1*SS6
42748 DX(2)=SS2*SS6
42749 DX(3)=SS2*SS4
42750 DX(4)=SS1*SS5
42751 DX(5)=SS3*SS5
42752 DX(6)=SS3*SS4
42753 DX(7)=SS7*SS1
42754 DX(8)=SS7*SS4
42755
42756C...Define colour coefficients for g + g -> Q + Qbar + H.
42757 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42758 DO 140 I=1,3
42759 DO 130 J=1,3
42760 CLR(I,J)=16D0/3D0
42761 CLR(I+3,J+3)=16D0/3D0
42762 CLR(I,J+3)=-2D0/3D0
42763 CLR(I+3,J)=-2D0/3D0
42764 130 CONTINUE
42765 140 CONTINUE
42766 DO 160 L=1,2
42767 DO 150 I=1,3
42768 CLR(I,6+L)=-6D0
42769 CLR(I+3,6+L)=6D0
42770 CLR(6+L,I)=-6D0
42771 CLR(6+L,I+3)=6D0
42772 150 CONTINUE
42773 160 CONTINUE
42774 DO 180 K1=1,2
42775 DO 170 K2=1,2
42776 CLR(6+K1,6+K2)=12D0
42777 170 CONTINUE
42778 180 CONTINUE
42779
42780C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42781 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42782 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42783 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42784 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42785 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42786 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42787 & X10)
42788 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42789 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42790 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42791 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42792 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42793 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42794 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42795 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42796 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42797 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42798 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42799 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42800 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42801 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42802 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42803 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42804 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42805 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42806 & X4*X6*X5)
42807 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42808 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42809 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42810 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42811 & +X4*X9*X5+X4*X5**2)
42812 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42813 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42814 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42815 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42816 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42817 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42818 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42819 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42820 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42821 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42822 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42823 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42824 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42825 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42826 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42827 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42828 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42829 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42830 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42831 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42832 & X6)
42833 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42834 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42835 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42836 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42837 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42838 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42839 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42840 & X5+X4*X6*X5)
42841 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42842 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42843 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42844 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42845 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42846 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42847 & X6**2)
42848 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42849 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42850 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42851 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42852 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42853 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42854 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42855 & X4*X6*X5)
42856 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42857 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42858 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42859 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42860 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42861 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42862 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42863 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42864 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42865 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42866 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42867 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42868 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42869 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42870 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42871 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42872 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42873 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42874 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42875 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42876 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42877 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42878 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42879 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42880 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42881 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42882 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42883 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42884 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42885 & +X3*X8*X5+X3*X5**2)
42886 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42887 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42888 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42889 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42890 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42891 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42892 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42893 & X5+X4*X6*X5)
42894 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42895 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42896 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42897 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42898 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42899 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42900 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42901 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42902 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42903 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42904 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42905 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42906 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42907 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42908 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42909 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42910 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42911 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42912 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42913 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42914 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42915 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42916 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42917 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42918 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42919 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42920 & X10)
42921 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42922 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42923 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42924 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42925 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42926 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42927 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42928 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42929 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42930 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42931 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42932 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42933 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42934 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42935 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42936 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42937 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42938 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42939 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42940 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42941 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42942 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42943 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42944 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42945 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42946 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42947 & X7)
42948 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42949 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42950 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42951 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42952 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42953 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42954 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42955 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42956 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42957 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42958 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42959 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42960 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42961 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42962 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42963 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42964 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42965 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42966 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42967 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42968 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42969 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42970 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42971 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42972 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42973 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42974 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42975 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42976 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42977 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42978 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42979 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42980 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42981 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42982 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42983 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42984 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42985 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42986 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42987 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42988 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42989 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42990 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
42991 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
42992 & *X6)
42993 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
42994 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
42995 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
42996 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
42997 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
42998 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
42999 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43000 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43001 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43002 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43003 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43004 & X8)
43005 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43006 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43007 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43008 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43009 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43010 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43011 & X9*X5)
43012 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43013 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43014 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43015 & X8*X5)
43016 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43017 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43018 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43019 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43020
43021C...Repackage matrix elements.
43022 DO 200 I=1,8
43023 DO 190 J=I,8
43024 RM(I,J)=FM(I,J)
43025 190 CONTINUE
43026 200 CONTINUE
43027 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43028 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43029 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43030
43031C...Produce final result: matrix elements * colours * propagators.
43032 DO 220 I=1,8
43033 DO 210 J=I,8
43034 FAC=8D0
43035 IF(I.EQ.J)FAC=4D0
43036 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43037 210 CONTINUE
43038 220 CONTINUE
43039 WTQQBH=-WTQQBH/256D0
43040
43041 ELSE
43042C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43043 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43044 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43045 & *X6+X8*X7)
43046 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43047 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43048 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43049 & X5)
43050 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43051 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43052 & *X9+X4*X8)
43053
43054C...Produce final result: matrix elements * propagators.
43055 A11=A11/DX(7)**2
43056 A12=A12/(DX(7)*DX(8))
43057 A22=A22/DX(8)**2
43058 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43059 ENDIF
43060
43061 RETURN
43062 END
43063
43064C*********************************************************************
43065
43066C...PYSTBH (and auxiliaries)
43067C.. Evaluates the matrix elements for t + b + H production.
43068
43069 SUBROUTINE PYSTBH(WTTBH)
43070
43071C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43073 IMPLICIT INTEGER(I-N)
43074 INTEGER PYK,PYCHGE,PYCOMP
43075
43076C...COMMONBLOCKS
43077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43079 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43080 COMMON/PYINT1/MINT(400),VINT(400)
43081 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43082 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43083 COMMON/PYINT4/MWID(500),WIDS(500,5)
43084 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43085 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43086 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43087 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43088 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43089 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43090 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43091 DOUBLE PRECISION MW2
43092 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43093 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43094
43095C...LOCAL ARRAYS AND COMPLEX VARIABLES
43096 DIMENSION QQ(4,2),PP(4,3)
43097 DATA QQ/8*0D0/
43098
43099 WTTBH=0D0
43100
43101C...KINEMATIC PARAMETERS.
43102 SHPR=SQRT(VINT(26))*VINT(1)
43103 PH=SQRT(VINT(21))*VINT(1)
43104 SPH=PH**2
43105
43106C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43107 DO 100 I=1,2
43108 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43109 PP(1,I)=PT*COS(VINT(198+5*I))
43110 PP(2,I)=PT*SIN(VINT(198+5*I))
43111 100 CONTINUE
43112 PP(1,3)=-PP(1,1)-PP(1,2)
43113 PP(2,3)=-PP(2,1)-PP(2,2)
43114 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43115 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43116 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43117 PMT3=SQRT(PMS3)
43118 PP(3,3)=PMT3*SINH(VINT(211))
43119 PP(4,3)=PMT3*COSH(VINT(211))
43120 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43121 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43122 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43123 PP(3,2)=-PP(3,1)-PP(3,3)
43124 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43125 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43126
43127C...CM SYSTEM, INGOING QUARKS/GLUONS
43128 QQ(3,1) = SHPR/2.D0
43129 QQ(4,1) = QQ(3,1)
43130 QQ(3,2) = -QQ(3,1)
43131 QQ(4,2) = QQ(4,1)
43132
43133C...PARAMETERS FOR AMPLITUDE METHOD
43134 ALPHA = AEM
43135 ALPHAS = AS
43136 SW2 = PARU(102)
43137 MW2 = PMAS(24,1)**2
43138 TANB = PARU(141)
43139 VTB = VCKM(3,3)
43140 RMB=PYMRUN(5,VINT(52))
43141
43142 ISUB=MINT(1)
43143
43144 IF (ISUB.EQ.401) THEN
43145 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43146 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43147 ELSE IF (ISUB.EQ.402) THEN
43148 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43149 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43150 END IF
43151
43152 RETURN
43153 END
43154C------------------------------------------------------------------
43155 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43156C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43157 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43158 IMPLICIT INTEGER(I-N)
43159 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43160 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43161 SAVE /PYCTBH/
43162
43163C TOP WIDTH CALCULATION
43164C VTB = 0.99
43165 MW=DSQRT(MW2)
43166 XB=(MB/MT)**2
43167 XW=(MW/MT)**2
43168 XH =(MHP/MT)**2
43169 GAMTBH = 0D0
43170 IF (MT .LT. (MHP+MB)) THEN
43171C T ->B W ONLY
43172 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43173 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43174 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43175 GAMT = GAMTBW
43176 ELSE
43177C T ->BW +T ->B H^+
43178 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43179 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43180 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43181C
43182 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43183 & -4.D0*(MHP*MB/MT**2)**2 )
43184 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43185 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43186 GAMT = GAMTBW+GAMTBH
43187 ENDIF
43188C THUS BR IS
43189 BR=GAMTBH/GAMT
43190 RETURN
43191 END
43192
43193C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43194C GG->TBH^+, QQBAR->TBH^+
43195C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43196C (FOR INSTANCE WITH PYTHIA)
43197C------------------------------------------------------------
43198C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43199C PHYS REV. D 60 (1999) 115011
43200C (THESE FILES PREPARED BY J.-L. KNEUR)
43201C------------------------------------------------------------
43202C 1) GG->TBH^+
43203 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43204C
43205C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43206C
43207C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43208C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43209C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43210C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43211C "PHYSICAL PARAMETERS" INPUT:
43212C MT,MB TOP AND BOTTOM MASSES;
43213C MHP CHARGED HIGGS MASS
43214C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43215C
43216C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43217C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43218C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43219C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43220C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43221C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43222C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43223C
43224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43225 IMPLICIT INTEGER(I-N)
43226 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43227 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43231
43232 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43233 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43234C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43235C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43236C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43237C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43238C (TAN BETA) VALUES
43239C
43240C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43241C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43242
43243 PI = 4*DATAN(1.D0)
43244 MW = DSQRT(MW2)
43245C
43246C COLLECTING THE RELEVANT OVERALL FACTORS:
43247C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43248 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43249C COUPLING CONSTANT (OVERALL NORMALIZATION)
43250 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43251C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43252C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43253C ALPHAS IS ALPHA_STRONG;
43254C SW2 IS SIN(THETA_W)**2.
43255C
43256C VTB=.998D0
43257C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43258C
43259 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43260 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43261C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43262C
43263C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43264C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43265 DO 100 KK=1,4
43266 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43267 100 CONTINUE
43268C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43269 S = 2*PYTBHS(Q1,Q2)
43270 P1Q1=PYTBHS(Q1,P1)
43271 P1Q2=PYTBHS(P1,Q2)
43272 P2Q1=PYTBHS(P2,Q1)
43273 P2Q2=PYTBHS(P2,Q2)
43274 P1P2=PYTBHS(P1,P2)
43275C
43276C TOP WIDTH CALCULATION
43277 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43278C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43279C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43280 A1INV= S -2*P1Q1 -2*P1Q2
43281 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43282C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43283C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43284C THE TOP WIDTH
43285 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43286 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43287C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43288C NOW COMES THE AMP**2:
43289C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43290C THE EXPRESSIONS BELOW
43291 V18=0.D0
43292 A18=0.D0
43293 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43294 &512*A1*A2*MB*MT/3-
43295 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43296 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43297 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43298 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43299 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43300 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43301 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43302 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43303 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43304 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43305 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43306 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43307 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43308 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43309 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43310 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43311 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43312 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43313 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43314 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43315 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43316 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43317 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43318 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43319 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43320 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43321 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43322 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43323 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43324 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43325 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43326 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43327 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43328 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43329 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43330 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43331 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43332 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43333 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43334 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43335 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43336 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43337 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43338 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43339 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43340 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43341 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43342 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43343 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43344 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43345 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43346 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43347 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43348 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43349 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43350 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43351 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43352 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43353 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43354 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43355 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43356 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43357 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43358 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43359 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43360 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43361 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43362 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43363 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43364 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43365 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43366 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43367 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43368 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43369 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43370 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43371 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43372 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43373 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43374 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43375 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43376 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43377 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43378 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43379 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43380 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43381 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43382 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43383 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43384 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43385 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43386 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43387 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43388 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43389 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43390 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43391 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43392 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43393 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43394 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43395 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43396 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43397 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43398 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43399 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43400 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43401 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43402 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43403 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43404 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43405 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43406 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43407 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43408 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43409 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43410 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43411 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43412 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43413 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43414 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43415 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43416 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43417 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43418 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43419 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43420 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43421 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43422 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43423 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43424 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43425 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43426 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43427 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43428 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43429 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43430 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43431 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43432 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43433 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43434 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43435 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43436 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43437 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43438 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43439 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43440 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43441 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43442 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43443 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43444 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43445 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43446 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43447 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43448 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43449 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43450 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43451 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43452 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43453 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43454 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43455 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43456 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43457 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43458 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43459 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43460 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43461 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43462 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43463 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43464 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43465 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43466 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43467 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43468 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43469 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43470 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43471 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43472 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43473 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43474 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43475 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43476 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43477 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43478 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43479 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43480 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43481 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43482 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43483 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43484 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43485 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43486 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43487 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43488 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43489 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43490 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43491 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43492 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43493 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43494 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43495 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43496 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43497 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43498 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43499 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43500 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43501 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43502 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43503 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43504 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43505 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43506 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43507 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43508 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43509 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43510 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43511 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43512 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43513 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43514 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43515 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43516 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43517 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43518 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43519 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43520 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43521 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43522 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43523 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43524 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43525 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43526 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43527 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43528 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43529 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43530 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43531 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43532 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43533 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43534 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43535 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43536 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43537 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43538 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43539 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43540 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43541 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43542 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43543 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43544 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43545 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43546 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43547 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43548 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43549 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43550 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43551 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43552 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43553 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43554 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43555 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43556 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43557 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43558 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43559 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43560 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43561 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43562 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43563 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43564 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43565 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43566 &384*A12*MB*MT*P1Q1**2/S**2+
43567 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43568 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43569 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43570 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43571 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43572 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43573 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43574 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43575 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43576 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43577 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43578 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43579 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43580 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43581 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43582 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43583 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43584 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43585 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43586 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43587 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43588 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43589 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43590 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43591 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43592 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43593 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43594 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43595 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43596 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43597 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43598 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43599 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43600 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43601 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43602 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43603 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43604 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43605 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43606 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43607 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43608 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43609 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43610 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43611 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43612 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43613 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43614 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43615 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43616 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43617 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43618 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43619 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43620 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43621 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43622 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43623 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43624 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43625 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43626 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43627 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43628 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43629 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43630 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43631 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43632 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43633 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43634 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43635 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43636 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43637 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43638 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43639 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43640 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43641 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43642 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43643 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43644 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43645 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43646 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43647 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43648 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43649 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43650 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43651 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43652 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43653 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43654 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43655 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43656 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43657 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43658 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43659 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43660 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43661 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43662 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43663 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43664 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43665 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43666 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43667 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43668 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43669 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43670 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43671 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43672 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43673 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43674 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43675 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43676 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43677 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43678 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43679 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43680 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43681 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43682 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43683 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43684 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43685 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43686 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43687 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43688 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43689 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43690 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43691 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43692 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43693 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43694 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43695 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43696 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43697 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43698 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43699 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43700 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43701 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43702 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43703 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43704 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43705 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43706 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43707 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43708 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43709 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43710 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43711 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43712 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43713 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43714 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43715 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43716 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43717 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43718 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43719 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43720 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43721 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43722 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43723 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43724 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43725 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43726 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43727 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43728 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43729 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43730 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43731 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43732 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43733 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43734 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43735 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43736 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43737 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43738 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43739 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43740 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43741 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43742 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43743
43744 V18BIS=
43745 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43746 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43747 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43748 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43749 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43750 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43751 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43752 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43753 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43754 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43755 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43756 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43757 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43758 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43759 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43760 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43761 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43762 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43763 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43764 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43765 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43766 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43767 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43768 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43769 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43770 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43771 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43772 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43773 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43774 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43775 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43776 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43777 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43778 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43779 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43780 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43781 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43782 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43783 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43784 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43785 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43786 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43787 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43788 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43789 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43790 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43791 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43792 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43793 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43794 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43795 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43796 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43797 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43798 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43799 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43800 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43801 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43802 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43803 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43804 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43805 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43806 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43807 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43808 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43809 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43810 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43811 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43812 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43813 &32*A12*P2Q1*S/(3*P1Q1)-
43814 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43815 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43816 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43817 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43818 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43819 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43820 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43821 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43822 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43823 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43824 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43825 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43826 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43827 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43828 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43829 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43830 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43831 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43832 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43833 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43834 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43835 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43836 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43837 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43838 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43839 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43840 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43841 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43842 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43843 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43844 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43845 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43846 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43847 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43848 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43849 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43850 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43851 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43852 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43853 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43854 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43855 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43856 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43857 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43858 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43859 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43860 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43861 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43862 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43863 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43864 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43865 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43866 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43867 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43868 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43869 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43870 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43871 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43872 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43873 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43874 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43875 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43876 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43877 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43878 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43879 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43880 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43881 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43882 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43883 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43884 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43885 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43886 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43887 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43888C
43889
43890 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43891 &512*A1*A2*MB*MT/3+
43892 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43893 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43894 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43895 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43896 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43897 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43898 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43899 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43900 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43901 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43902 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43903 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43904 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43905 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43906 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43907 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43908 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43909 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43910 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43911 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43912 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43913 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43914 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43915 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43916 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43917 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43918 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43919 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43920 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43921 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43922 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43923 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43924 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43925 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43926 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43927 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43928 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43929 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43930 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43931 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43932 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43933 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43934 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43935 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43936 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43937 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43938 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43939 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43940 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43941 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43942 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43943 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43944 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43945 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43946 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43947 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43948 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43949 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43950 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43951 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43952 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43953 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43954 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43955 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43956 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43957 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43958 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43959 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43960 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43961 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43962 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43963 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43964 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43965 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43966 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43967 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43968 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43969 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43970 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43971 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43972 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43973 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43974 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43975 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43976 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43977 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43978 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43979 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43980 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43981 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43982 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43983 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43984 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43985 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43986 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43987 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43988 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43989 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43990 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
43991 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43992 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43993 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43994 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43995 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43996 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
43997 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43998 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
43999 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44000 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44001 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44002 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44003 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44004 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44005 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44006 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44007 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44008 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44009 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44010 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44011 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44012 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44013 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44014 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44015 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44016 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44017 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44018 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44019 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44020 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44021 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44022 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44023 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44024 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44025 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44026 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44027 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44028 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44029 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44030 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44031 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44032 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44033 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44034 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44035 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44036 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44037 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44038 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44039 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44040 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44041 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44042 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44043 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44044 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44045 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44046 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44047 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44048 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44049 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44050 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44051 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44052 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44053 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44054 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44055 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44056 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44057 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44058 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44059 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44060 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44061 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44062 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44063 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44064 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44065 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44066 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44067 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44068 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44069 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44070 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44071 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44072 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44073 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44074 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44075 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44076 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44077 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44078 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44079 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44080 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44081 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44082 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44083 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44084 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44085 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44086 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44087 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44088 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44089 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44090 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44091 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44092 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44093 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44094 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44095 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44096 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44097 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44098 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44099 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44100 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44101 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44102 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44103 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44104 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44105 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44106 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44107 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44108 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44109 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44110 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44111 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44112 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44113 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44114 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44115 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44116 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44117 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44118 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44119 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44120 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44121 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44122 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44123 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44124 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44125 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44126 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44127 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44128 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44129 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44130 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44131 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44132 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44133 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44134 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44135 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44136 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44137 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44138 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44139 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44140 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44141 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44142 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44143 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44144 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44145 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44146 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44147 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44148 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44149 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44150 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44151 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44152 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44153 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44154 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44155 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44156 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44157 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44158 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44159 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44160 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44161 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44162 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44163 &384*A12*MB*MT*P1Q1**2/S**2+
44164 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44165 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44166 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44167 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44168 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44169 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44170 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44171 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44172 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44173 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44174 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44175 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44176 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44177 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44178 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44179 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44180 &384*A2**2*MB*MT*P2Q2**2/S**2+
44181 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44182 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44183 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44184 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44185 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44186 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44187 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44188 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44189 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44190 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44191 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44192 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44193 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44194 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44195 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44196 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44197 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44198 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44199 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44200 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44201 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44202 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44203 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44204 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44205 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44206 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44207 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44208 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44209 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44210 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44211 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44212 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44213 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44214 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44215 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44216 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44217 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44218 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44219 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44220 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44221 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44222 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44223 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44224 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44225 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44226 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44227 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44228 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44229 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44230 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44231 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44232 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44233 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44234 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44235 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44236 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44237 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44238 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44239 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44240 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44241 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44242 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44243 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44244 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44245 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44246 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44247 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44248 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44249 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44250 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44251 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44252 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44253 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44254 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44255 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44256 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44257 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44258 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44259 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44260 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44261 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44262 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44263 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44264 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44265 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44266 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44267 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44268 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44269 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44270 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44271 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44272 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44273 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44274 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44275 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44276 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44277 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44278 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44279 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44280 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44281 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44282 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44283 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44284 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44285 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44286 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44287 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44288 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44289 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44290 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44291 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44292 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44293 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44294 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44295 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44296 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44297 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44298 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44299 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44300 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44301 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44302 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44303 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44304 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44305 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44306 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44307 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44308 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44309 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44310 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44311 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44312 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44313 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44314 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44315 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44316 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44317 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44318 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44319 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44320 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44321 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44322 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44323 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44324 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44325 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44326 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44327 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44328 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44329 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44330 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44331 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44332 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44333 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44334 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44335 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44336 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44337 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44338 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44339 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44340 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44341 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44342 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44343 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44344 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44345 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44346 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44347 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44348 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44349 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44350 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44351 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44352 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44353 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44354 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44355 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44356 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44357 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44358 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44359 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44360 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44361 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44362 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44363 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44364 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44365 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44366 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44367 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44368 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44369 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44370 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44371 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44372 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44373 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44374
44375 A18BIS=
44376 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44377 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44378 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44379 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44380 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44381 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44382 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44383 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44384 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44385 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44386 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44387 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44388 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44389 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44390 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44391 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44392 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44393 &12*S/(P1Q2*P2Q1)+
44394 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44395 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44396 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44397 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44398 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44399 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44400 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44401 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44402 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44403 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44404 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44405 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44406 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44407 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44408 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44409 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44410 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44411 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44412 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44413 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44414 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44415 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44416 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44417 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44418 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44419 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44420 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44421 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44422 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44423 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44424 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44425 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44426 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44427 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44428 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44429 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44430 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44431 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44432 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44433 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44434 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44435 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44436 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44437 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44438 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44439 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44440 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44441 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44442 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44443 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44444 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44445 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44446 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44447 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44448 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44449 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44450 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44451 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44452 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44453 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44454 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44455 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44456 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44457 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44458 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44459 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44460 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44461 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44462 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44463 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44464 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44465 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44466 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44467 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44468 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44469 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44470 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44471 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44472 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44473 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44474 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44475 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44476 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44477 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44478 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44479 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44480C
44481 V18=V18+V18BIS
44482 A18=A18+A18BIS
44483 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44484 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44485 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44486 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44487 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44488 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44489 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44490 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44491 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44492 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44493 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44494 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44495 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44496 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44497 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44498 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44499 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44500 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44501 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44502 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44503 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44504 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44505 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44506C
44507 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44508 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44509 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44510 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44511 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44512 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44513 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44514 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44515 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44516 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44517 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44518 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44519 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44520 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44521 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44522 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44523 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44524 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44525 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44526 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44527 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44528 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44529 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44530C
44531C FINAL RESULT;
44532C
44533 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44534
44535 END
44536C---------------------------------------------------------
44537C 2) Q QBAR ->TBH^+
44538 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44539C
44540C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44541C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44542 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44543 IMPLICIT INTEGER(I-N)
44544 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44545 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44547 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44548 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44549 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44550 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44551C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44552C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44553C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44554C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44555C
44556C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44557C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44558C
44559 DIMENSION YY(2,2)
44560
44561 PI = 4*DATAN(1.D0)
44562 MW = DSQRT(MW2)
44563
44564C COLLECTING THE RELEVANT OVERALL FACTORS:
44565C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44566 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44567C COUPLING CONSTANT (OVERALL NORMALIZATION)
44568 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44569C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44570C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44571C ALPHAS IS ALPHA_STRONG;
44572C SW2 IS SIN(THETA_W)**2.
44573C
44574C VTB=.998D0
44575C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44576C
44577 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44578 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44579C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44580C
44581C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44582C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44583 DO 100 KK=1,4
44584 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44585 100 CONTINUE
44586C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44587 S = 2*PYTBHS(Q1,Q2)
44588 P1Q1=PYTBHS(Q1,P1)
44589 P1Q2=PYTBHS(P1,Q2)
44590 P2Q1=PYTBHS(P2,Q1)
44591 P2Q2=PYTBHS(P2,Q2)
44592 P1P2=PYTBHS(P1,P2)
44593C
44594C TOP WIDTH CALCULATION
44595 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44596C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44597C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44598 A1INV= S -2*P1Q1 -2*P1Q2
44599 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44600C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44601C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44602 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44603 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44604C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44605C NOW COMES THE AMP**2:
44606C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44607C THE EXPRESSIONS BELOW
44608 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44609 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44610 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44611 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44612 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44613 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44614 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44615 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44616 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44617 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44618 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44619 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44620 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44621 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44622 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44623 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44624 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44625 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44626 &32*A2**2*MB**2*P1P2*V**2/S+
44627 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44628 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44629 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44630 YY(1, 1)=2*YY(1, 1)
44631
44632 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44633 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44634 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44635 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44636 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44637 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44638 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44639 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44640 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44641 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44642 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44643 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44644 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44645 &64*A**2*A1*A2*MB*MT*P1P2/S+
44646 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44647 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44648 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44649 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44650 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44651 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44652 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44653 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44654 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44655 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44656 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44657 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44658 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44659 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44660 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44661 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44662 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44663 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44664 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44665 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44666 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44667 &32*A1*A2*P1P2*P1Q1*V**2/S+
44668 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44669 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44670 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44671 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44672
44673
44674 YY(2, 2) =-16*A**2*A12*MB*MT+
44675 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44676 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44677 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44678 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44679 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44680 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44681 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44682 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44683 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44684 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44685 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44686 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44687 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44688 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44689 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44690 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44691 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44692 &32*A12*MT**2*P2Q2*V**2/S-
44693 &32*A12*P1Q2*P2Q2*V**2/S
44694 YY(2, 2)=2*YY(2, 2)
44695
44696 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44697 AMP2= FACT*PS*VTB**2*RES
44698
44699 END
44700C=====================================================================
44701C ************* FUNCTION SCALAR PRODUCTS *************************
44702 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44703 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44704 IMPLICIT INTEGER(I-N)
44705 DIMENSION A(4),B(4)
44706 DUM=A(4)*B(4)
44707 DO 100 ID=1,3
44708 DUM=DUM-A(ID)*B(ID)
44709 100 CONTINUE
44710 PYTBHS=DUM
44711 RETURN
44712 END
44713
44714C*********************************************************************
44715
44716C...PYMSIN
44717C...Initializes supersymmetry: finds sparticle masses and
44718C...branching ratios and stores this information.
44719C...AUTHOR: STEPHEN MRENNA
44720C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44721
44722 SUBROUTINE PYMSIN
44723
44724C...Double precision and integer declarations.
44725 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44726 IMPLICIT INTEGER(I-N)
44727 INTEGER PYK,PYCHGE,PYCOMP
44728C...Parameter statement to help give large particle numbers.
44729 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44730 &KEXCIT=4000000,KDIMEN=5000000)
44731C...Commonblocks.
44732 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44733 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44734 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44735 COMMON/PYDAT4/CHAF(500,2)
44736 CHARACTER CHAF*16
44737 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44738 COMMON/PYINT4/MWID(500),WIDS(500,5)
44739 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44740 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44741 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44742 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44743 COMMON/PYHTRI/HHH(7)
44744 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44745 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44746 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44747
44748C...Local variables.
44749 DOUBLE PRECISION ALFA,BETA
44750 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44751 INTEGER I,J,J1,I1,K1
44752 INTEGER KC,LKNT,IDLAM(400,3)
44753 DOUBLE PRECISION XLAM(0:400)
44754 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44755 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44756 DOUBLE PRECISION DELM,XMDIF
44757 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44758 DOUBLE PRECISION ARG,SGNMU,R
44759 INTEGER IMSSM
44760 INTEGER IRPRTY
44761 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44762 SAVE MWIDSU,MDCYSU
44763 DATA KFSUSY/
44764 &1000001,2000001,1000002,2000002,1000003,2000003,
44765 &1000004,2000004,1000005,2000005,1000006,2000006,
44766 &1000011,2000011,1000012,2000012,1000013,2000013,
44767 &1000014,2000014,1000015,2000015,1000016,2000016,
44768 &1000021,1000022,1000023,1000025,1000035,1000024,
44769 &1000037,1000039, 25, 35, 36, 37,
44770 & 6, 24, 45, 46,1000045, 9*0/
44771 DATA INIT/0/
44772
44773C...Automatically read QNUMBERS, MASS, and DECAY tables
44774 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44775 NQNUM=0
44776 CALL PYSLHA(0,0,IFAIL)
44777 CALL PYSLHA(5,0,IFAIL)
44778 ENDIF
44779 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44780
44781C...Do nothing further if SUSY not requested
44782 IMSSM=IMSS(1)
44783 IF(IMSSM.EQ.0) RETURN
44784
44785C...Save copy of MWID(KC) and MDCY(KC,1) values before
44786C...they are set to zero for the LSP.
44787 IF(INIT.EQ.0) THEN
44788 INIT=1
44789 DO 100 I=1,36
44790 KF=KFSUSY(I)
44791 KC=PYCOMP(KF)
44792 MWIDSU(I)=MWID(KC)
44793 MDCYSU(I)=MDCY(KC,1)
44794 100 CONTINUE
44795 ENDIF
44796
44797C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44798 DO 110 I=1,36
44799 KF=KFSUSY(I)
44800 KC=PYCOMP(KF)
44801 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44802 MWID(KC)=MWIDSU(I)
44803 MDCY(KC,1)=MDCYSU(I)
44804 ENDIF
44805 110 CONTINUE
44806
44807C...First part of routine: set masses and couplings.
44808
44809C...Reset mixing values in sfermion sector to pure left/right.
44810 DO 120 I=1,16
44811 SFMIX(I,1)=1D0
44812 SFMIX(I,4)=1D0
44813 SFMIX(I,2)=0D0
44814 SFMIX(I,3)=0D0
44815 120 CONTINUE
44816
44817C...Add NMSSM states if NMSSM switched on, and change old names.
44818 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44819C... Switch on NMSSM
44820 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44821
44822 KFN=25
44823 KCN=KFN
44824 CHAF(KCN,1)='h_10'
44825 CHAF(KCN,2)=' '
44826
44827 KFN=35
44828 KCN=KFN
44829 CHAF(KCN,1)='h_20'
44830 CHAF(KCN,2)=' '
44831
44832 KFN=45
44833 KCN=KFN
44834 CHAF(KCN,1)='h_30'
44835 CHAF(KCN,2)=' '
44836
44837 KFN=36
44838 KCN=KFN
44839 CHAF(KCN,1)='A_10'
44840 CHAF(KCN,2)=' '
44841
44842 KFN=46
44843 KCN=KFN
44844 CHAF(KCN,1)='A_20'
44845 CHAF(KCN,2)=' '
44846
44847 KFN=1000045
44848 KCN=PYCOMP(KFN)
44849 IF (KCN.EQ.0) THEN
44850 DO 123 KCT=100,MSTU(6)
44851 IF(KCHG(KCT,4).GT.100) KCN=KCT
44852 123 CONTINUE
44853 KCN=KCN+1
44854 KCHG(KCN,4)=KFN
44855 MSTU(20)=0
44856 ENDIF
44857C... Set stable for now
44858 PMAS(KCN,2)=1D-6
44859 MWID(KCN)=0
44860 MDCY(KCN,1)=0
44861 MDCY(KCN,2)=0
44862 MDCY(KCN,3)=0
44863 CHAF(KCN,1)='~chi_50'
44864 CHAF(KCN,2)=' '
44865 ENDIF
44866
44867C...Read spectrum from SLHA file.
44868 IF (IMSSM.EQ.11) THEN
44869 CALL PYSLHA(1,0,IFAIL)
44870 ENDIF
44871
44872C...Common couplings.
44873 TANB=RMSS(5)
44874 BETA=ATAN(TANB)
44875 COSB=COS(BETA)
44876 SINB=TANB*COSB
44877 COS2B=COS(2D0*BETA)
44878 ALFA=RMSS(18)
44879 XMW2=PMAS(24,1)**2
44880 XMZ2=PMAS(23,1)**2
44881 XW=PARU(102)
44882
44883C...Define sparticle masses for a general MSSM simulation.
44884 IF(IMSSM.EQ.1) THEN
44885 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44886 DO 130 I=1,5,2
44887 KC=PYCOMP(KSUSY1+I)
44888 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44889 KC=PYCOMP(KSUSY2+I)
44890 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44891 KC=PYCOMP(KSUSY1+I+1)
44892 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44893 KC=PYCOMP(KSUSY2+I+1)
44894 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44895 130 CONTINUE
44896 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44897 IF(XARG.LT.0D0) THEN
44898 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44899 & ' FROM THE SUM RULE. '
44900 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44901 RETURN
44902 ELSE
44903 XARG=SQRT(XARG)
44904 ENDIF
44905 DO 140 I=11,15,2
44906 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44907 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44908 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44909 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44910 140 CONTINUE
44911 IF(IMSS(8).EQ.1) THEN
44912 RMSS(13)=RMSS(6)
44913 RMSS(14)=RMSS(7)
44914 ENDIF
44915
44916C...Alternatively derive masses from SUGRA relations.
44917 ELSEIF(IMSSM.EQ.2) THEN
44918 RMSS(36)=RMSS(16)
44919 CALL PYAPPS
44920C...Or use ISASUSY
44921 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44922 RMSS(36)=RMSS(16)
44923 CALL PYSUGI
44924 ALFA=RMSS(18)
44925 GOTO 170
44926 ELSE
44927 GOTO 170
44928 ENDIF
44929
44930C...Add in extra D-term contributions.
44931 IF(IMSS(7).EQ.1) THEN
44932 R=0.43D0
44933 DX=RMSS(23)
44934 DY=RMSS(24)
44935 DS=RMSS(25)
44936 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44937 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44938 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44939 WRITE(MSTU(11),*) 'C DX = ',DX
44940 WRITE(MSTU(11),*) 'C DY = ',DY
44941 WRITE(MSTU(11),*) 'C DS = ',DS
44942 WRITE(MSTU(11),*) 'C '
44943 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44944 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44945 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44946 DQ2=DY/6D0-DX/3D0-DS/3D0
44947 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44948 DD2=DY/3D0+DX-2D0*DS/3D0
44949 DL2=-DY/2D0+DX-2D0*DS/3D0
44950 DE2=DY-DX/3D0-DS/3D0
44951 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44952 DHD2=-DY/2D0-2D0*DX/3D0+DS
44953 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44954 & /ABS(COS2B)
44955 DMA2 = 2D0*DMU2+DHU2+DHD2
44956 DO 150 I=1,5,2
44957 KC=PYCOMP(KSUSY1+I)
44958 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44959 KC=PYCOMP(KSUSY2+I)
44960 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44961 KC=PYCOMP(KSUSY1+I+1)
44962 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44963 KC=PYCOMP(KSUSY2+I+1)
44964 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44965 150 CONTINUE
44966 DO 160 I=11,15,2
44967 KC=PYCOMP(KSUSY1+I)
44968 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44969 KC=PYCOMP(KSUSY2+I)
44970 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44971 KC=PYCOMP(KSUSY1+I+1)
44972 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44973 160 CONTINUE
44974 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44975 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44976 CALL PYSTOP(104)
44977 ENDIF
44978 SGNMU=SIGN(1D0,RMSS(4))
44979 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44980 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44981 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44982 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44983 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44984 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44985 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44986 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44987 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44988 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44989 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44990 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
44991 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
44992 CALL PYSTOP(104)
44993 ENDIF
44994 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
44995 RMSS(6)=SQRT(RMSS(6)**2+DL2)
44996 RMSS(7)=SQRT(RMSS(7)**2+DE2)
44997 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
44998 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
44999 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45000 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45001 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45002 ENDIF
45003
45004C...Fix the third generation sfermions.
45005 CALL PYTHRG
45006
45007C...Fix the neutralino--chargino--gluino sector.
45008 CALL PYINOM
45009
45010C...Fix the Higgs sector.
45011 CALL PYHGGM(ALFA)
45012
45013C...Choose the Gunion-Haber convention.
45014 ALFA=-ALFA
45015 RMSS(18)=ALFA
45016
45017C...Print information on mass parameters.
45018 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45019 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45020 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45021 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45022 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45023 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45024 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45025 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45026 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45027 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45028 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45029 ENDIF
45030 IF(IMSS(20).EQ.1) THEN
45031 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45032 WRITE(MSTU(11),*) ' DEBUG MODE '
45033 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45034 & UMIX(2,1),UMIX(2,2)
45035 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45036 & UMIXI(2,1),UMIXI(2,2)
45037 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45038 & VMIX(2,1),VMIX(2,2)
45039 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45040 & VMIXI(2,1),VMIXI(2,2)
45041 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45042 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45043 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45044 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45045 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45046 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45047 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45048 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45049 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45050 WRITE(MSTU(11),*) ' BETA = ',BETA
45051 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45052 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45053 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45054 ENDIF
45055
45056C...Set up the Higgs couplings - needed here since initialization
45057C...in PYINRE did not yet occur when PYWIDT is called below.
45058 170 AL=ALFA
45059 BE=BETA
45060 SINA=SIN(AL)
45061 COSA=COS(AL)
45062 COSB=COS(BE)
45063 SINB=TANB*COSB
45064 SBMA=SIN(BE-AL)
45065 SAPB=SIN(AL+BE)
45066 CAPB=COS(AL+BE)
45067 CBMA=COS(BE-AL)
45068 C2A=COS(2D0*AL)
45069 C2B=COSB**2-SINB**2
45070C...tanb (used for H+)
45071 PARU(141)=TANB
45072
45073C...Firstly: h
45074C...Coupling to d-type quarks
45075 PARU(161)=SINA/COSB
45076C...Coupling to u-type quarks
45077 PARU(162)=-COSA/SINB
45078C...Coupling to leptons
45079 PARU(163)=PARU(161)
45080C...Coupling to Z
45081 PARU(164)=SBMA
45082C...Coupling to W
45083 PARU(165)=PARU(164)
45084
45085C...Secondly: H
45086C...Coupling to d-type quarks
45087 PARU(171)=-COSA/COSB
45088C...Coupling to u-type quarks
45089 PARU(172)=-SINA/SINB
45090C...Coupling to leptons
45091 PARU(173)=PARU(171)
45092C...Coupling to Z
45093 PARU(174)=CBMA
45094C...Coupling to W
45095 PARU(175)=PARU(174)
45096C...Coupling to h
45097 IF(IMSS(4).GE.2) THEN
45098 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45099 ELSE
45100 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45101 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45102 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45103 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45104 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45105 ENDIF
45106C...Coupling to H+
45107C...Define later
45108 IF(IMSS(4).GE.2) THEN
45109 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45110 ELSE
45111 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45112 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45113 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45114 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45115 ENDIF
45116C...Coupling to A
45117 IF(IMSS(4).GE.2) THEN
45118 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45119 ELSE
45120 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45121 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45122 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45123 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45124 ENDIF
45125C...Coupling to H+
45126 IF(IMSS(4).GE.2) THEN
45127 PARU(178)=PARU(177)
45128 ELSE
45129 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45130 ENDIF
45131C...Thirdly, A
45132C...Coupling to d-type quarks
45133 PARU(181)=TANB
45134C...Coupling to u-type quarks
45135 PARU(182)=1D0/PARU(181)
45136C...Coupling to leptons
45137 PARU(183)=PARU(181)
45138 PARU(184)=0D0
45139 PARU(185)=0D0
45140C...Coupling to Z h
45141 PARU(186)=COS(BE-AL)
45142C...Coupling to Z H
45143 PARU(187)=SIN(BE-AL)
45144 PARU(188)=0D0
45145 PARU(189)=0D0
45146 PARU(190)=0D0
45147
45148C...Finally: H+
45149C...Coupling to W h
45150 PARU(195)=COS(BE-AL)
45151
45152C...Tell that all Higgs couplings have been set.
45153 MSTP(4)=1
45154
45155C...Set R-Violating couplings.
45156C...Set lambda couplings to common value or "natural values".
45157 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45158 VIR3=1D0/(126D0)**3
45159 DO 200 IRK=1,3
45160 DO 190 IRI=1,3
45161 DO 180 IRJ=1,3
45162 IF (IRI.NE.IRJ) THEN
45163 IF (IRI.LT.IRJ) THEN
45164 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45165 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45166 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45167 & PMAS(9+2*IRK,1)*VIR3)
45168 ELSE
45169 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45170 ENDIF
45171 ELSE
45172 RVLAM(IRI,IRJ,IRK)=0D0
45173 ENDIF
45174 180 CONTINUE
45175 190 CONTINUE
45176 200 CONTINUE
45177 ENDIF
45178C...Set lambda' couplings to common value or "natural values".
45179 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45180 VIR3=1D0/(126D0)**3
45181 DO 230 IRI=1,3
45182 DO 220 IRJ=1,3
45183 DO 210 IRK=1,3
45184 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45185 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45186 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45187 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45188 210 CONTINUE
45189 220 CONTINUE
45190 230 CONTINUE
45191 ENDIF
45192C...Set lambda'' couplings to common value or "natural values".
45193 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45194 VIR3=1D0/(126D0)**3
45195 DO 260 IRI=1,3
45196 DO 250 IRJ=1,3
45197 DO 240 IRK=1,3
45198 IF (IRJ.NE.IRK) THEN
45199 IF (IRJ.LT.IRK) THEN
45200 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45201 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45202 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45203 & PMAS(2*IRK-1,1)*VIR3)
45204 ELSE
45205 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45206 ENDIF
45207 ELSE
45208 RVLAMB(IRI,IRJ,IRK) = 0D0
45209 ENDIF
45210 240 CONTINUE
45211 250 CONTINUE
45212 260 CONTINUE
45213 ENDIF
45214
45215C...Antisymmetrize couplings set by user
45216 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45217 DO 290 IRI=1,3
45218 DO 280 IRJ=1,3
45219 DO 270 IRK=1,3
45220 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45221 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45222 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45223 ENDIF
45224 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45225 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45226 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45227 ENDIF
45228 270 CONTINUE
45229 280 CONTINUE
45230 290 CONTINUE
45231 ENDIF
45232
45233C...Write spectrum to SLHA file
45234 IF (IMSS(23).NE.0) THEN
45235 IFAIL=0
45236 CALL PYSLHA(3,0,IFAIL)
45237 ENDIF
45238
45239C...Second part of routine: set decay modes and branching ratios.
45240
45241C...Allow chi10 -> gravitino + gamma or not.
45242 KC=PYCOMP(KSUSY1+39)
45243 IF( IMSS(11) .NE. 0 ) THEN
45244 PMAS(KC,1)=RMSS(21)/1D9
45245 PMAS(KC,2)=0D0
45246 IRPRTY=0
45247 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45248 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45249 IRPRTY=0
45250 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45251 & ' ALLOWING SUSY LLE DECAYS'
45252 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45253 & ' ALLOWING SUSY LQD DECAYS'
45254 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45255 & ' ALLOWING SUSY UDD DECAYS'
45256 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45257 & ' --- Warning: R-Violating couplings possibly',
45258 & ' incompatible with proton decay'
45259 ELSE
45260 PMAS(KC,1)=9999D0
45261 IRPRTY=1
45262 ENDIF
45263
45264C...Loop over sparticle and Higgs species.
45265 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45266C...Find the LSP or NLSP for a gravitino LSP
45267 ILSP=0
45268 PMLSP=1D20
45269 DO 300 I=1,36
45270 KF=KFSUSY(I)
45271 IF(KF.EQ.1000039) GOTO 300
45272 KC=PYCOMP(KF)
45273 IF(PMAS(KC,1).LT.PMLSP) THEN
45274 ILSP=I
45275 PMLSP=PMAS(KC,1)
45276 ENDIF
45277 300 CONTINUE
45278 DO 370 I=1,50
45279 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45280 KF=KFSUSY(I)
45281 IF (KF.EQ.0) GOTO 370
45282 KC=PYCOMP(KF)
45283 LKNT=0
45284
45285C...Check if there are any decays listed for this sparticle
45286C...in a file
45287 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45288 IFAIL=0
45289 CALL PYSLHA(2,KF,IFAIL)
45290 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45291 ELSEIF (I.GE.37) THEN
45292 GOTO 370
45293 ENDIF
45294
45295C...Sfermion decays.
45296 IF(I.LE.24) THEN
45297C...First check to see if sneutrino is lighter than chi10.
45298 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45299 & PMAS(KC,1).LT.PMCHI1) THEN
45300 ELSE
45301 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45302 ENDIF
45303
45304C...Gluino decays.
45305 ELSEIF(I.EQ.25) THEN
45306 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45307 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45308
45309C...Neutralino decays.
45310 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45311 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45312C...chi10 stable or chi10 -> gravitino + gamma.
45313 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45314 PMAS(KC,2)=1D-6
45315 MDCY(KC,1)=0
45316 MWID(KC)=0
45317 ENDIF
45318
45319C...Chargino decays.
45320 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45321 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45322
45323C...Gravitino is stable.
45324 ELSEIF(I.EQ.32) THEN
45325 MDCY(KC,1)=0
45326 MWID(KC)=0
45327
45328C...Higgs decays.
45329 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45330C...Calculate decays to non-SUSY particles.
45331 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45332 LKNT=0
45333 DO 310 I1=0,100
45334 XLAM(I1)=0D0
45335 310 CONTINUE
45336 DO 330 I1=1,MDCY(KC,3)
45337 K1=MDCY(KC,2)+I1-1
45338 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45339 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45340 XLAM(I1)=WDTP(I1)
45341 XLAM(0)=XLAM(0)+XLAM(I1)
45342 DO 320 J1=1,3
45343 IDLAM(I1,J1)=KFDP(K1,J1)
45344 320 CONTINUE
45345 LKNT=LKNT+1
45346 330 CONTINUE
45347C...Add the decays to SUSY particles.
45348 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45349 ENDIF
45350C...Zero the branching ratios for use in loop mode
45351C...thanks to K. Matchev (FNAL)
45352 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45353 BRAT(IDC)=0D0
45354 340 CONTINUE
45355
45356C...Set stable particles.
45357 IF(LKNT.EQ.0) THEN
45358 MDCY(KC,1)=0
45359 MWID(KC)=0
45360 PMAS(KC,2)=1D-6
45361 PMAS(KC,3)=1D-5
45362 PMAS(KC,4)=0D0
45363
45364C...Store branching ratios in the standard tables.
45365 ELSE
45366 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45367 DELM=1D6
45368 DO 360 IL=1,LKNT
45369 IDCSV=IDC
45370 350 IDC=IDC+1
45371 BRAT(IDC)=0D0
45372 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45373 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45374 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45375 BRAT(IDC)=XLAM(IL)/XLAM(0)
45376 XMDIF=PMAS(KC,1)
45377 IF(MDME(IDC,1).GE.1) THEN
45378 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45379 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45380 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45381 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45382 ENDIF
45383 IF(I.LE.32) THEN
45384 IF(XMDIF.GE.0D0) THEN
45385 DELM=MIN(DELM,XMDIF)
45386 ELSE
45387 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45388 WRITE(MSTU(11),*) ' KF = ',KF
45389 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45390 ENDIF
45391 ENDIF
45392 GOTO 360
45393 ELSEIF(IDC.EQ.IDCSV) THEN
45394 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45395 & 'channel not recognized:'
45396 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45397 GOTO 360
45398 ELSE
45399 GOTO 350
45400 ENDIF
45401 360 CONTINUE
45402
45403C...Store width, cutoff and lifetime.
45404 PMAS(KC,2)=XLAM(0)
45405 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45406 PMAS(KC,3)=PMAS(KC,2)*10D0
45407 ELSE
45408 PMAS(KC,3)=0.95D0*DELM
45409 ENDIF
45410 IF(PMAS(KC,2).NE.0D0) THEN
45411 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45412 ENDIF
45413C...Write decays to SLHA file
45414 IF (IMSS(24).NE.0) THEN
45415 IFAIL=0
45416 CALL PYSLHA(4,KF,IFAIL)
45417 ENDIF
45418
45419 ENDIF
45420 370 CONTINUE
45421
45422 RETURN
45423 END
45424C*********************************************************************
45425
45426C...PYSLHA
45427C...Read/write spectrum or decay data from SLHA standard file(s).
45428C...P. Skands
45429
45430C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45431C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45432C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45433C... (KFORIG=0 : read all decay tables)
45434C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45435C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45436C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45437C... (KFORIG=0 : read all MASS entries)
45438
45439 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45440
45441C...Double precision and integer declarations.
45442 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45443 IMPLICIT INTEGER(I-N)
45444 INTEGER PYK,PYCHGE,PYCOMP
45445 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45446 &KEXCIT=4000000,KDIMEN=5000000)
45447C...Commonblocks.
45448 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45449 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45450 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45451 COMMON/PYDAT4/CHAF(500,2)
45452 CHARACTER CHAF*16
45453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45454 CHARACTER*40 ISAVER,VISAJE
45455 COMMON/PYINT4/MWID(500),WIDS(500,5)
45456 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45457C...SUSY blocks
45458 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45459 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45460 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45461 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45462 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45463
45464C...Local arrays, character variables and data.
45465 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45466 & AU(3,3),AD(3,3),AE(3,3)
45467 COMMON/PYLH3C/CPRO(2),CVER(2)
45468C...The common block of new states (QNUMBERS / PARTICLE)
45469 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45470C...- NQNUM : Number of QNUMBERS blocks that have been read in
45471C...- KQNUM(I,0) : KF of new state
45472C...- KQNUM(I,1) : 3 times electric charge
45473C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45474C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45475C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45476C...- KQNUM(I,5:9) : space available for further quantum numbers
45477 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45478 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45479C...MMOD: flags to set for each block read in.
45480C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45481C...MSPC: Flags to set for each block read in.
45482C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45483C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45484C...11: AD 12: AE 13: YU 14: YD 15: YE
45485C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45486 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45487 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45488 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45489 INTEGER VERBOS
45490 SAVE VERBOS
45491C...Date of last Change
45492 PARAMETER (DOC='13 Jul 2009')
45493C...Local arrays and initial values
45494 DIMENSION IDC(5),KFSUSY(50)
45495 SAVE KFSUSY
45496 DATA NQNUM /0/
45497 DATA NDECAY /0/
45498 DATA VERBOS /1/
45499 DATA NHELLO /0/
45500 DATA MLHEF /0/
45501 DATA MLHEFD /0/
45502 DATA KFSUSY/
45503 &1000001,1000002,1000003,1000004,1000005,1000006,
45504 &2000001,2000002,2000003,2000004,2000005,2000006,
45505 &1000011,1000012,1000013,1000014,1000015,1000016,
45506 &2000011,2000012,2000013,2000014,2000015,2000016,
45507 &1000021,1000022,1000023,1000025,1000035,1000024,
45508 &1000037,1000039, 25, 35, 36, 37,
45509 & 6, 24, 45, 46,1000045, 9*0/
45510 DATA KFDEC/100*0/
45511 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45512
45513C...Shorthand for spectrum and decay table unit numbers
45514 IMSS21=IMSS(21)
45515 IMSS22=IMSS(22)
45516
45517C...Default for LHEF input: read header information
45518 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45519 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45520 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45521 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45522
45523C...Hello World
45524 IF (NHELLO.EQ.0) THEN
45525 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45526 WRITE(MSTU(11),5000) DOC
45527 NHELLO=1
45528 ENDIF
45529 ENDIF
45530
45531C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45532C...+MUPDA).
45533 LFN=IMSS21
45534 IF (MUPDA.EQ.2) LFN=IMSS22
45535 IF (MUPDA.EQ.3) LFN=IMSS(23)
45536 IF (MUPDA.EQ.4) LFN=IMSS(24)
45537C...Flag that we have not yet found whatever we were asked to find.
45538 IRETRN=1
45539C...Flag that we are skipping until <slha> tag found (if LHEF)
45540 ISKIP=0
45541 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45542
45543C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45544 IF (LFN.EQ.0) THEN
45545 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45546 GOTO 9999
45547 ENDIF
45548
45549C...If reading LHEF header, start by rewinding file
45550 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45551
45552C...If told to read spectrum, first zero all previous information.
45553 IF (MUPDA.EQ.1) THEN
45554C...Zero all block read flags
45555 DO 100 M=1,100
45556 MMOD(M)=0
45557 MSPC(M)=0
45558 100 CONTINUE
45559C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45560 DO 110 ISUSY=1,36
45561 KC=PYCOMP(KFSUSY(ISUSY))
45562 PMAS(KC,1)=0D0
45563 110 CONTINUE
45564C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45565 DO 130 J=1,4
45566 SFMIX(5,J) =0D0
45567 SFMIX(6,J) =0D0
45568 SFMIX(15,J)=0D0
45569 DO 120 L=1,4
45570 ZMIX(L,J) =0D0
45571 ZMIXI(L,J)=0D0
45572 IF (J.LE.2.AND.L.LE.2) THEN
45573 UMIX(L,J) =0D0
45574 UMIXI(L,J)=0D0
45575 VMIX(L,J) =0D0
45576 VMIXI(L,J)=0D0
45577 ENDIF
45578 120 CONTINUE
45579C...Zero signed masses.
45580 SMZ(J)=0D0
45581 IF (J.LE.2) SMW(J)=0D0
45582 130 CONTINUE
45583
45584C...If reading decays, reset PYTHIA decay counters.
45585 ELSEIF (MUPDA.EQ.2) THEN
45586C...Check if DECAY for this KF already read
45587 IF (KFORIG.NE.0) THEN
45588 DO 140 IDEC=1,NDECAY
45589 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45590 IRETRN=0
45591 RETURN
45592 ENDIF
45593 140 CONTINUE
45594 ENDIF
45595 KCC=100
45596 NDC=0
45597 BRSUM=0D0
45598 DO 150 KC=1,MSTU(6)
45599 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45600 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45601 150 CONTINUE
45602 ELSEIF (MUPDA.EQ.5) THEN
45603C...Zero block read flags
45604 DO 160 M=1,100
45605 MSPC(M)=0
45606 160 CONTINUE
45607 ENDIF
45608
45609C............READ
45610C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45611 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45612C...Initialize program and version strings
45613 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45614 CPRO(MUPDA)=' '
45615 CVER(MUPDA)=' '
45616 ENDIF
45617
45618C...Initialize read loop
45619 MERR=0
45620 NLINE=0
45621 CHBLCK=' '
45622C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45623 170 CHINL=' '
45624 READ(LFN,'(A120)',END=400) CHINL
45625C...Count which line number we're at.
45626 NLINE=NLINE+1
45627 WRITE(CHNLIN,'(I6)') NLINE
45628
45629C...Skip comment and empty lines without processing.
45630 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45631
45632C...We assume all upper case below. Rewrite CHINL to all upper case.
45633 INL=0
45634 IGOOD=0
45635 180 INL=INL+1
45636 IF (CHINL(INL:INL).NE.'#') THEN
45637 DO 190 ICH=97,122
45638 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45639 190 CONTINUE
45640C...Extra safety. Chek for sensible input on line
45641 IF (IGOOD.EQ.0) THEN
45642 DO 200 ICH=48,90
45643 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45644 200 CONTINUE
45645 ENDIF
45646 IF (INL.LT.120) GOTO 180
45647 ENDIF
45648 IF (IGOOD.EQ.0) GOTO 170
45649
45650C...If reading from LHEF file, skip until <slha> begin tag found
45651 IF (ISKIP.NE.0) THEN
45652 DO 205 I1=1,10
45653 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45654 205 CONTINUE
45655 IF (ISKIP.NE.0) GOTO 170
45656 ENDIF
45657
45658C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45659 DO 210 I1=1,10
45660 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45661 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45662 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45663 REWIND(LFN)
45664 GOTO 400
45665 ENDIF
45666 210 CONTINUE
45667
45668C...Check for BLOCK begin statement (spectrum).
45669 IF (CHINL(1:5).EQ.'BLOCK') THEN
45670 MERR=0
45671 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45672C...Check if another of this type of block was already read.
45673C...(logarithmic interpolation not yet implemented, so duplicates always
45674C...give errors)
45675 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45676 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45677 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45678 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45679 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45680 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45681 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45682 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45683 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45684 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45685 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45686 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45687 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45688 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45689 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45690 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45691 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45692C...Check for new particles
45693 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45694 & THEN
45695 MSPC(19)=MSPC(19)+1
45696C...Read PDG code
45697 READ(CHBLCK(9:60),*) KFQ
45698
45699 DO 220 MQ=1,NQNUM
45700 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45701 MERR=17
45702 GOTO 380
45703 ENDIF
45704 220 CONTINUE
45705 IF (NHELLO.EQ.0) THEN
45706 WRITE(MSTU(11),5000) DOC
45707 NHELLO=1
45708 ENDIF
45709 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45710 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45711 & ' for KF =',KFQ
45712 NQNUM=NQNUM+1
45713 KQNUM(NQNUM,0)=KFQ
45714 MSPC(19)=MSPC(19)+1
45715 KCQ=PYCOMP(KFQ)
45716C...Only read in new codes (also OK to overwrite if KF > 3000000)
45717 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45718 IF (KCQ.EQ.0) THEN
45719 DO 230 KCT=100,MSTU(6)
45720 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45721 230 CONTINUE
45722 KCQ=KCQ+1
45723 ENDIF
45724 KCC=KCQ
45725 KCHG(KCQ,4)=KFQ
45726C...First write PDG code as name
45727 WRITE(CHTMP,*) KFQ
45728 WRITE(CHTMP,'(A)') CHTMP(2:10)
45729C...Then look for real name
45730 IBEG=9
45731 240 IBEG=IBEG+1
45732 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45733 250 IBEG=IBEG+1
45734 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45735 IEND=IBEG-1
45736 260 IEND=IEND+1
45737 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45738 IF (IEND.LT.59) THEN
45739 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45740 IF (CHDUM.NE.' ') CHTMP=CHDUM
45741 ENDIF
45742 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45743 MSTU(20)=0
45744C...Set stable for now
45745 PMAS(KCQ,2)=1D-6
45746 MWID(KCQ)=0
45747 MDCY(KCQ,1)=0
45748 MDCY(KCQ,2)=0
45749 MDCY(KCQ,3)=0
45750 ELSE
45751 WRITE(MSTU(11),*)
45752 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45753 & CHAF(KCQ,1), '. Entry ignored.'
45754 MERR=7
45755 ENDIF
45756 ENDIF
45757C...Finalize this line and read next.
45758 GOTO 380
45759C...Check for DECAY begin statement (decays).
45760 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45761 MERR=0
45762 BRSUM=0D0
45763 CHBLCK='DECAY'
45764C...Read KF code and WIDTH
45765 MPSIGN=1
45766 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45767 IF (KF.LE.0) THEN
45768 KF=-KF
45769 MPSIGN=-1
45770 ENDIF
45771C...If this is not the KF we're looking for...
45772 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45773C...Set block skip flag and read next line.
45774 MERR=16
45775 GOTO 380
45776 ELSE
45777C...Check whether decay table for this particle already read in
45778 DO 280 IDECAY=1,NDECAY
45779 IF (KFDEC(IDECAY).EQ.KF) THEN
45780 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45781 & ' * (PYSLHA:) Ignoring DECAY table ',
45782 & 'for KF =',KF,' on line ',CHNLIN,
45783 & ' (duplicate)'
45784 MERR=16
45785 GOTO 380
45786 ENDIF
45787 280 CONTINUE
45788 ENDIF
45789
45790C...Determine PYTHIA KC code of particle
45791 KCREP=0
45792 IF(KF.LE.100) THEN
45793 KCREP=KF
45794 ELSE
45795 DO 290 KCR=101,KCC
45796 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45797 290 CONTINUE
45798 ENDIF
45799 KC=KCREP
45800 IF (KCREP.NE.0) THEN
45801C...Particle is already known. Do not overwrite low-mass SM particles,
45802C...since this could give problems at hadronization / hadron decay stage.
45803 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45804C...Set block skip flag and read next line
45805 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45806 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45807 & KF, ' (SLHA read-in not allowed)'
45808 MERR=16
45809 GOTO 380
45810 ENDIF
45811 ELSE
45812C... Add new particle. Actually, this should not happen.
45813C... New particles should be added already when reading the spectrum
45814C... information, so go under previously stable category.
45815 KCC=KCC+1
45816 KC=KCC
45817 ENDIF
45818
45819 IF (WIDTH.LE.0D0) THEN
45820C...Stable (i.e. LSP)
45821 WRITE(MSTU(11),'(A,I9,A,A)')
45822 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45823 & KF,', ',CHAF(KCREP,1)(1:16)
45824 IF (WIDTH.LT.0D0) THEN
45825 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45826 & ' zero !')
45827 WIDTH=0D0
45828 ENDIF
45829 PMAS(KC,2)=1D-6
45830 MWID(KC)=0
45831 MDCY(KC,1)=0
45832C...Ignore any decay lines that may be present for this KF
45833 MERR=16
45834 MDCY(KC,2)=0
45835 MDCY(KC,3)=0
45836C...Return ok
45837 IRETRN=0
45838 ENDIF
45839C...Finalize and start reading in decay modes.
45840 GOTO 380
45841 ELSEIF (MOD(MERR,10).GE.6) THEN
45842C...If ignore block flag set, skip directly to next line.
45843 GOTO 170
45844 ENDIF
45845
45846C...READ SPECTRUM
45847 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45848 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45849 & THEN
45850 READ(CHINL,*) INDX, IVAL
45851 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45852 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45853 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45854 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45855 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45856 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45857 IF (INDX.EQ.4) THEN
45858 KCHG(KCQ,3)=IVAL
45859 IF (IVAL.EQ.1) THEN
45860 CHTMP=CHAF(KCQ,1)
45861 IF (CHTMP.EQ.' ') THEN
45862 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45863 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45864 ELSE
45865 ILAST=17
45866 300 ILAST=ILAST-1
45867 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45868 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45869 CHTMP(ILAST:ILAST)='-'
45870 ELSE
45871 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45872 ENDIF
45873 CHAF(KCQ,2)=CHTMP
45874 ENDIF
45875 ENDIF
45876 ENDIF
45877 ELSE
45878 MERR=8
45879 ENDIF
45880 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45881C...MASS: Mass spectrum
45882 IF (CHBLCK(1:4).EQ.'MASS') THEN
45883 READ(CHINL,*) KF, VAL
45884 MERR=1
45885 KC=0
45886 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45887C...Read in masses for almost anything
45888 MERR=0
45889 KC=PYCOMP(KF)
45890 IF (KC.NE.0) THEN
45891C...Don't read in masses for special code particles
45892 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45893 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45894 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45895 & KF, ' (KF reserved by PYTHIA)'
45896 GOTO 170
45897 ENDIF
45898C...Be careful with light SM particles / hadrons
45899 IF (PMAS(KC,1).LE.20D0) THEN
45900 IF (IABS(KF).LE.22) THEN
45901 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45902 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45903 & KF, ' (SLHA read-in not allowed)'
45904
45905 GOTO 170
45906 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45907 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45908 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45909 & KF, ' (SLHA read-in not allowed)'
45910 GOTO 170
45911 ENDIF
45912 ENDIF
45913 MSPC(1)=MSPC(1)+1
45914 PMAS(KC,1) = ABS(VAL)
45915 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45916 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45917 & ' * (PYSLHA:) Reading MASS entry for KF =',
45918 & KF, ', pole mass =', VAL
45919 IRETRN=0
45920 ENDIF
45921C...Check Z, W and top masses
45922 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45923 & THEN
45924 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45925 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45926 & //CHTMP)
45927 ENDIF
45928 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45929 & THEN
45930 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45931 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45932 & //CHTMP)
45933 ENDIF
45934 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45935 & THEN
45936 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45937 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45938 & //CHTMP//'GeV')
45939 ENDIF
45940C... Signed masses
45941 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45942 IF (KF.EQ.1000022) SMZ(1)=VAL
45943 IF (KF.EQ.1000023) SMZ(2)=VAL
45944 IF (KF.EQ.1000025) SMZ(3)=VAL
45945 IF (KF.EQ.1000035) SMZ(4)=VAL
45946 IF (KF.EQ.1000024) SMW(1)=VAL
45947 IF (KF.EQ.1000037) SMW(2)=VAL
45948 ENDIF
45949 ELSEIF (MUPDA.EQ.5) THEN
45950 MERR=0
45951 ENDIF
45952C... MODSEL: Model selection and global switches
45953 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45954 READ(CHINL,*) INDX, IVAL
45955 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45956 IF (IMSS(1).EQ.0) IMSS(1)=11
45957 MODSEL(INDX)=IVAL
45958 MMOD(1)=MMOD(1)+1
45959 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45960C... Switch on NMSSM
45961 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45962 IMSS(13)=MAX(1,IMSS(13))
45963C... Add NMSSM states if not already done
45964
45965 KFN=25
45966 KCN=KFN
45967 CHAF(KCN,1)='h_10'
45968 CHAF(KCN,2)=' '
45969
45970 KFN=35
45971 KCN=KFN
45972 CHAF(KCN,1)='h_20'
45973 CHAF(KCN,2)=' '
45974
45975 KFN=45
45976 KCN=KFN
45977 CHAF(KCN,1)='h_30'
45978 CHAF(KCN,2)=' '
45979
45980 KFN=36
45981 KCN=KFN
45982 CHAF(KCN,1)='A_10'
45983 CHAF(KCN,2)=' '
45984
45985 KFN=46
45986 KCN=KFN
45987 CHAF(KCN,1)='A_20'
45988 CHAF(KCN,2)=' '
45989
45990 KFN=1000045
45991 KCN=PYCOMP(KFN)
45992 IF (KCN.EQ.0) THEN
45993 DO 310 KCT=100,MSTU(6)
45994 IF(KCHG(KCT,4).GT.100) KCN=KCT
45995 310 CONTINUE
45996 KCN=KCN+1
45997 KCHG(KCN,4)=KFN
45998 MSTU(20)=0
45999 ENDIF
46000C... Set stable for now
46001 PMAS(KCN,2)=1D-6
46002 MWID(KCN)=0
46003 MDCY(KCN,1)=0
46004 MDCY(KCN,2)=0
46005 MDCY(KCN,3)=0
46006 CHAF(KCN,1)='~chi_50'
46007 CHAF(KCN,2)=' '
46008 ENDIF
46009 ELSE
46010 MERR=1
46011 ENDIF
46012 ELSEIF (MUPDA.EQ.5) THEN
46013C...If MUPDA = 5, skip all except MASS, return if MODSEL
46014 MERR=8
46015 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46016 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46017C...Don't print a warning for QNUMBERS when reading spectrum
46018 MERR=8
46019C...MINPAR: Minimal model parameters
46020 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46021 READ(CHINL,*) INDX, VAL
46022 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46023 PARMIN(INDX)=VAL
46024 MMOD(2)=MMOD(2)+1
46025 ELSE
46026 MERR=1
46027 ENDIF
46028 IF (MMOD(3).NE.0) THEN
46029 WRITE(MSTU(11),*)
46030 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46031 MERR=1
46032 ENDIF
46033C...tan(beta)
46034 IF (INDX.EQ.3) RMSS(5)=VAL
46035C...EXTPAR: non-minimal model parameters.
46036 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46037 IF (MMOD(1).NE.0) THEN
46038 READ(CHINL,*) INDX, VAL
46039 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46040 PAREXT(INDX)=VAL
46041 MMOD(3)=MMOD(3)+1
46042 ELSE
46043 MERR=1
46044 ENDIF
46045 ELSE
46046 WRITE(MSTU(11),*)
46047 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46048 MERR=1
46049 ENDIF
46050C...tan(beta)
46051 IF (INDX.EQ.25) RMSS(5)=VAL
46052 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46053 READ(CHINL,*) INDX, VAL
46054 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46055 MERR=1
46056 ELSEIF (INDX.EQ.4) THEN
46057 PMAS(PYCOMP(23),1)=VAL
46058 ELSEIF (INDX.EQ.6) THEN
46059 PMAS(PYCOMP(6),1)=VAL
46060 ENDIF
46061 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46062 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46063 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46064 $ THEN
46065C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46066 IM=0
46067 IF (CHBLCK(5:6).EQ.'IM') IM=1
46068 320 READ(CHINL,*) INDX1, INDX2, VAL
46069 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46070 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46071 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46072 MSPC(2)=MSPC(2)+1
46073 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46074 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46075 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46076 MSPC(3)=MSPC(3)+1
46077 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46078 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46079 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46080 MSPC(4)=MSPC(4)+1
46081 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46082 $ .CHBLCK(1:4).EQ.'STAU') THEN
46083 IF (CHBLCK(1:4).EQ.'STOP') THEN
46084 KFSM=6
46085 ISPC=6
46086 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46087 KFSM=5
46088 ISPC=5
46089 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46090 KFSM=15
46091 ISPC=7
46092 ENDIF
46093C...Set SFMIX element
46094 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46095 MSPC(ISPC)=MSPC(ISPC)+1
46096 ENDIF
46097C...Running parameters
46098 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46099 READ(CHBLCK(8:25),*,ERR=620) Q
46100 READ(CHINL,*) INDX, VAL
46101 MSPC(8)=MSPC(8)+1
46102 IF (INDX.EQ.1) THEN
46103 RMSS(4) = VAL
46104 ELSE
46105 MERR=1
46106 MSPC(8)=MSPC(8)-1
46107 ENDIF
46108 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46109 READ(CHINL,*,ERR=630) VAL
46110 RMSS(18)= VAL
46111 MSPC(17)=MSPC(17)+1
46112C...Higgs parameters set manually or with FeynHiggs.
46113 IMSS(4)=MAX(2,IMSS(4))
46114 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46115 & .CHBLCK(1:2).EQ.'AE') THEN
46116 READ(CHBLCK(9:26),*,ERR=620) Q
46117 READ(CHINL,*) INDX1, INDX2, VAL
46118 IF (CHBLCK(2:2).EQ.'U') THEN
46119 AU(INDX1,INDX2)=VAL
46120 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46121 MSPC(11)=MSPC(11)+1
46122 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46123 AD(INDX1,INDX2)=VAL
46124 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46125 MSPC(10)=MSPC(10)+1
46126 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46127 AE(INDX1,INDX2)=VAL
46128 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46129 MSPC(12)=MSPC(12)+1
46130 ELSE
46131 MERR=1
46132 ENDIF
46133 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46134 IF (MSPC(18).EQ.0) THEN
46135 READ(CHBLCK(9:25),*,ERR=620) Q
46136 RMSOFT(0)=Q
46137 ENDIF
46138 READ(CHINL,*) INDX, VAL
46139 RMSOFT(INDX)=VAL
46140 MSPC(18)=MSPC(18)+1
46141 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46142 MERR=8
46143 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46144 & .CHBLCK(1:2).EQ.'YE') THEN
46145 MERR=8
46146 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46147 READ(CHINL(1:6),*) INDX
46148 IT=0
46149 MIRD=0
46150 330 IT=IT+1
46151 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46152C...Don't read index
46153 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46154 MIRD=1
46155 GOTO 330
46156 ENDIF
46157 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46158 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46159 ELSE
46160C... Set unrecognized block flag.
46161 MERR=6
46162 ENDIF
46163
46164C...DECAY TABLES
46165C...Read in decay information
46166 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46167C...Read new decay chanel
46168 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46169 NDC=NDC+1
46170C...Read in branching ratio and number of daughters for this mode.
46171 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46172 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46173 IF (NDA.LE.5) THEN
46174 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46175 & '(PYSLHA:) Decay data arrays full by KF = '
46176 $ //CHAF(KC,1))
46177C...If first decay channel, set decays start point in decay table
46178 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46179 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46180 & '* (PYSLHA:) Reading DECAY table for '//
46181 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46182C...Set particle parameters (mass set when reading BLOCK MASS above)
46183 PMAS(KC,2)=WIDTH
46184 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46185 WRITE(MSTU(11),'(1x,A)')
46186 & '* Note: the Pythia gg->h/H/A cross section'//
46187 & ' is proportional to the h/H/A->gg width'
46188 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46189 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46190 WRITE(MSTU(11),'(1x,A,A16)')
46191 & '* Warning: will use DECAY table (fixed-width,'//
46192 & ' flat PS) for ',CHAF(KC,1)(1:16)
46193 ENDIF
46194 PMAS(KC,3)=0D0
46195 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46196 MWID(KC)=2
46197 MDCY(KC,1)=1
46198 MDCY(KC,2)=NDC
46199 MDCY(KC,3)=0
46200C...Add to list of DECAY blocks currently read
46201 NDECAY=NDECAY+1
46202 KFDEC(NDECAY)=KF
46203C...Return ok
46204 IRETRN=0
46205 ENDIF
46206C... Count up number of decay modes for this particle
46207 MDCY(KC,3)=MDCY(KC,3)+1
46208C... Read in decay daughters.
46209 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46210C... Flip sign if reading antiparticle decays (if antipartner exists)
46211 DO 340 IDA=1,NDA
46212 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46213 & IDC(IDA)=MPSIGN*IDC(IDA)
46214 340 CONTINUE
46215C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46216 MDME(NDC,1)=1
46217 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46218 BRSUM=BRSUM+ABS(BRAT(NDC))
46219 BRAT(NDC)=ABS(BRAT(NDC))
46220 350 IFLIP=0
46221 DO 360 IDA=1,NDA-1
46222 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46223 ITMP=IDC(IDA)
46224 IDC(IDA)=IDC(IDA+1)
46225 IDC(IDA+1)=ITMP
46226 IFLIP=IFLIP+1
46227 ENDIF
46228 360 CONTINUE
46229 IF (IFLIP.GT.0) GOTO 350
46230C...Treat as ordinary decay, no fancy stuff.
46231 MDME(NDC,2)=0
46232 DO 370 IDA=1,5
46233 IF (IDA.LE.NDA) THEN
46234 KFDP(NDC,IDA)=IDC(IDA)
46235 ELSE
46236 KFDP(NDC,IDA)=0
46237 ENDIF
46238 370 CONTINUE
46239C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46240C & (KFDP(NDC,J),J=1,NDA)
46241 ELSE
46242 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46243 & CHNLIN)
46244 MERR=11
46245 NDC=NDC-1
46246 ENDIF
46247 ELSEIF(CHINL(1:1).EQ.'+') THEN
46248 MERR=11
46249 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46250 MERR=16
46251 ELSE
46252 MERR=16
46253 ENDIF
46254 ENDIF
46255C... Error check.
46256 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46257 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46258 & //CHINL(1:40)
46259 MERR=0
46260 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46261 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46262 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46263 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46264 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46265 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46266 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46267 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46268 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46269 & //'... on line'//CHNLIN
46270 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46271 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46272 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46273 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46274 WRITE (CHTMP,*) KF
46275 WRITE(MSTU(11),*)
46276 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46277 & CHTMP(1:9)//' on line'//CHNLIN
46278 ENDIF
46279C...Iterate read loop
46280 GOTO 170
46281C...Error catching
46282 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46283 & ', ignoring subsequent lines.'
46284 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46285 CHBLCK=' '
46286 GOTO 170
46287C...End of read loop
46288 400 CONTINUE
46289C...Set flag that KC codes have been rearranged.
46290 MSTU(20)=0
46291 VERBOS=0
46292
46293C...Perform possible tests that new information is consistent.
46294 IF (MUPDA.EQ.1) THEN
46295 MSTU23=MSTU(23)
46296 MSTU27=MSTU(27)
46297C...Check masses
46298 DO 410 ISUSY=1,37
46299 KF=KFSUSY(ISUSY)
46300C...Don't complain about right-handed neutrinos
46301 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46302 & +16) GOTO 410
46303C...Only check gravitino in GMSB scenarios
46304 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46305 KC=PYCOMP(KF)
46306 IF (PMAS(KC,1).EQ.0D0) THEN
46307 WRITE(CHTMP,*) KF
46308 CALL PYERRM(9
46309 & ,'(PYSLHA:) No mass information found for KF ='
46310 & //CHTMP)
46311 ENDIF
46312 410 CONTINUE
46313C...Check mixing matrices (MSSM only)
46314 IF (IMSS(13).EQ.0) THEN
46315 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46316 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46317 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46318 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46319 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46320 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46321 IF (MSPC(5).NE.4) CALL PYERRM(9
46322 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46323 IF (MSPC(6).NE.4) CALL PYERRM(9
46324 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46325 IF (MSPC(7).NE.4) CALL PYERRM(9
46326 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46327 IF (MSPC(8).LT.1) CALL PYERRM(9
46328 & ,'(PYSLHA:) Too few elements in HMIX')
46329 IF (MSPC(10).EQ.0) CALL PYERRM(9
46330 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46331 IF (MSPC(11).EQ.0) CALL PYERRM(9
46332 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46333 IF (MSPC(12).EQ.0) CALL PYERRM(9
46334 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46335 IF (MSPC(17).LT.1) CALL PYERRM(9
46336 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46337 ENDIF
46338C...Check wavefunction normalizations.
46339C...Sfermions
46340 DO 420 ISPC=5,7
46341 IF (MSPC(ISPC).EQ.4) THEN
46342 KFSM=ISPC
46343 IF (ISPC.EQ.7) KFSM=15
46344 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46345 & *SFMIX(KFSM,3))
46346 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46347 KCSM=PYCOMP(KFSM)
46348 CALL PYERRM(17
46349 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46350 & //CHAF(KCSM,1))
46351 ENDIF
46352C...Bug fix 30/09 2008: PS
46353C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46354 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46355 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46356 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46357 ENDIF
46358 ENDIF
46359 420 CONTINUE
46360C...Neutralinos + charginos
46361 DO 440 J=1,4
46362 CN1=0D0
46363 CN2=0D0
46364 CU1=0D0
46365 CU2=0D0
46366 CV1=0D0
46367 CV2=0D0
46368 DO 430 L=1,4
46369 CN1=CN1+ZMIX(J,L)**2
46370 CN2=CN2+ZMIX(L,J)**2
46371 IF (J.LE.2.AND.L.LE.2) THEN
46372 CU1=CU1+UMIX(J,L)**2
46373 CU2=CU2+UMIX(L,J)**2
46374 CV1=CV1+VMIX(J,L)**2
46375 CV2=CV2+VMIX(L,J)**2
46376 ENDIF
46377 430 CONTINUE
46378C...NMIX normalization
46379 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46380 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46381 CALL PYERRM(19,
46382 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46383 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46384 ENDIF
46385C...UMIX, VMIX normalizations
46386 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46387 IF (J.LE.2) THEN
46388 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46389 CALL PYERRM(19
46390 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46391 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46392 & CU2
46393 ENDIF
46394 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46395 CALL PYERRM(19,
46396 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46397 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46398 & CV2
46399 ENDIF
46400 ENDIF
46401 ENDIF
46402 440 CONTINUE
46403 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46404 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46405 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46406 ELSE
46407 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46408 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46409 & ,' Warning: one or more (serious)'//
46410 & ' inconsistencies were found in the spectrum !'
46411 & ,' Read the error messages above and check your'//
46412 & ' input file.'
46413 ENDIF
46414C...Increase precision in Higgs sector using FeynHiggs
46415 IF (IMSS(4).EQ.3) THEN
46416C...FeynHiggs needs MSOFT.
46417 IERR=0
46418 IF (MSPC(18).EQ.0) THEN
46419 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46420 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46421 & ' Cannot call FeynHiggs.'
46422 IERR=-1
46423 ELSE
46424 WRITE(MSTU(11),'(1x,/1x,A/)')
46425 & '* (PYSLHA:) Now calling FeynHiggs.'
46426 CALL PYFEYN(IERR)
46427 IF (IERR.NE.0) IMSS(4)=2
46428 ENDIF
46429 ENDIF
46430 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46431 IBEG=1
46432 IF (KFORIG.NE.0) IBEG=NDECAY
46433 DO 490 IDECAY=IBEG,NDECAY
46434 KF = KFDEC(IDECAY)
46435 KC = PYCOMP(KF)
46436 WRITE(CHKF,8300) KF
46437 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46438 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46439 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46440 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46441 $ //CHKF)
46442 BRSUM=0D0
46443 BROPN=0D0
46444 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46445 IF(MDME(IDA,2).GT.80) GOTO 460
46446 KQ=KCHG(KC,1)
46447 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46448 MERR=0
46449 DO 450 J=1,5
46450 KP=KFDP(IDA,J)
46451 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46452 IF(KP.EQ.81) KQ=0
46453 ELSEIF(PYCOMP(KP).EQ.0) THEN
46454 MERR=3
46455 ELSE
46456 KQ=KQ-PYCHGE(KP)
46457 KPC=PYCOMP(KP)
46458 PMS=PMS-PMAS(KPC,1)
46459 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46460 & PMAS(KPC,3))
46461 ENDIF
46462 450 CONTINUE
46463 IF(KQ.NE.0) MERR=MAX(2,MERR)
46464 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46465 & MERR=MAX(1,MERR)
46466 IF(MERR.EQ.3) CALL PYERRM(17,
46467 & '(PYSLHA:) Unknown particle code in decay of KF ='
46468 $ //CHKF)
46469 IF(MERR.EQ.2) CALL PYERRM(17,
46470 & '(PYSLHA:) Charge not conserved in decay of KF ='
46471 $ //CHKF)
46472 IF(MERR.EQ.1) CALL PYERRM(7,
46473 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46474 $ //CHKF)
46475 BRSUM=BRSUM+BRAT(IDA)
46476 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46477 460 CONTINUE
46478C...Check branching ratio sum.
46479 IF (BROPN.LE.0D0) THEN
46480C...If zero, set stable.
46481 WRITE(CHTMP,8500) BROPN
46482 CALL PYERRM(7
46483 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46484 & CHTMP(9:16)//'. Changed to stable.')
46485 PMAS(KC,2)=1D-6
46486 MWID(KC)=0
46487C...If BR's > 1, rescale.
46488 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46489 WRITE(CHTMP,8500) BRSUM
46490 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46491 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46492 & ' ; sum was'//CHTMP(9:16)//'.')
46493 FAC=1D0/BRSUM
46494 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46495 IF(MDME(IDA,2).GT.80) GOTO 470
46496 BRAT(IDA)=FAC*BRAT(IDA)
46497 470 CONTINUE
46498 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46499C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46500 WRITE(CHTMP,8500) BRSUM
46501 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46502 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46503 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46504C...Move table and insert dummy mode
46505 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46506 NDC=NDC+1
46507 BRAT(NDC)=BRAT(IDA)
46508 KFDP(NDC,1)=KFDP(IDA,1)
46509 KFDP(NDC,2)=KFDP(IDA,2)
46510 KFDP(NDC,3)=KFDP(IDA,3)
46511 KFDP(NDC,4)=KFDP(IDA,4)
46512 KFDP(NDC,5)=KFDP(IDA,5)
46513 MDME(NDC,1)=MDME(IDA,1)
46514 480 CONTINUE
46515 NDC=NDC+1
46516 BRAT(NDC)=1D0-BRSUM
46517 KFDP(NDC,1)=0
46518 KFDP(NDC,2)=0
46519 KFDP(NDC,3)=0
46520 KFDP(NDC,4)=0
46521 KFDP(NDC,5)=0
46522 MDME(NDC,1)=0
46523 BRSUM=1D0
46524C...Update MDCY
46525 MDCY(KC,3)=MDCY(KC,3)+1
46526 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46527 ENDIF
46528 490 CONTINUE
46529 ENDIF
46530
46531
46532C...WRITE SPECTRUM ON SLHA FILE
46533 ELSEIF(MUPDA.EQ.3) THEN
46534C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46535 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46536 MODSEL(1)=1
46537 PARMIN(1)=RMSS(8)
46538 PARMIN(2)=RMSS(1)
46539 PARMIN(3)=RMSS(5)
46540 PARMIN(4)=SIGN(1D0,RMSS(4))
46541 PARMIN(5)=RMSS(36)
46542 ENDIF
46543C...Write spectrum
46544 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46545 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46546 & // ' P. Skands.'
46547 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46548 WRITE(LFN,7110) 1, MODSEL(1)
46549 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46550 IF (MODSEL(1).EQ.1) THEN
46551 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46552 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46553 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46554 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46555 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46556 ELSEIF(MODSEL(2).EQ.2) THEN
46557 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46558 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46559 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46560 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46561 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46562 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46563 ENDIF
46564 WRITE(LFN,7000) ' '
46565 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46566 DO 500 I=1,36
46567 KF=KFSUSY(I)
46568 KC=PYCOMP(KF)
46569 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46570 KFSM=KF-KSUSY1
46571 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46572 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46573 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46574 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46575 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46576 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46577 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46578 ELSE
46579 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46580 ENDIF
46581 500 CONTINUE
46582C...SUSY scale
46583 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46584 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46585 WRITE(LFN,7210) 1, RMSS(4),'mu'
46586 WRITE(LFN,7010) 'ALPHA',' '
46587 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46588 WRITE(LFN,7020) 'AU',RMSUSY
46589 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46590 WRITE(LFN,7020) 'AD',RMSUSY
46591 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46592 WRITE(LFN,7020) 'AE',RMSUSY
46593 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46594 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46595 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46596 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46597 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46598 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46599 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46600 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46601 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46602 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46603 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46604 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46605 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46606 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46607 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46608 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46609 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46610 DO 520 I1=1,4
46611 DO 510 I2=1,4
46612 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46613 510 CONTINUE
46614 520 CONTINUE
46615 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46616 DO 540 I1=1,2
46617 DO 530 I2=1,2
46618 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46619 530 CONTINUE
46620 540 CONTINUE
46621 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46622 DO 560 I1=1,2
46623 DO 550 I2=1,2
46624 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46625 550 CONTINUE
46626 560 CONTINUE
46627 WRITE(LFN,7010) 'SPINFO'
46628 IF (IMSS(1).EQ.2) THEN
46629 CPRO(1)='PYTHIA'
46630 CVER(1)='6.4'
46631 ELSEIF (IMSS(1).EQ.12) THEN
46632 ISAVER=VISAJE()
46633 CPRO(1)='ISASUSY'
46634 CVER(1)=ISAVER(1:12)
46635 ENDIF
46636 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46637 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46638 ENDIF
46639
46640C...Print user information about spectrum
46641 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46642 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46643 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46644 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46645 IF (MUPDA.EQ.1) THEN
46646 WRITE(MSTU(11),5020) LFN
46647 ELSE
46648 WRITE(MSTU(11),5010) LFN
46649 ENDIF
46650
46651 WRITE(MSTU(11),5400)
46652 WRITE(MSTU(11),5500) 'Pole masses'
46653 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46654 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46655 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46656 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46657 IF (IMSS(13).EQ.0) THEN
46658 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46659 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46660 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46661 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46662 & CHAF(37,1), ' ', ' ',' ',' ',
46663 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46664 ELSEIF (IMSS(13).EQ.1) THEN
46665 KF1=KSUSY1+21
46666 KF2=KSUSY1+22
46667 KF3=KSUSY1+23
46668 KF4=KSUSY1+25
46669 KF5=KSUSY1+35
46670 KF6=KSUSY1+45
46671 KF7=KSUSY1+24
46672 KF8=KSUSY1+37
46673 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46674 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46675 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46676 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46677 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46678 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46679 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46680 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46681 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46682 & RMFUN(37)
46683 ENDIF
46684 WRITE(MSTU(11),5400)
46685 WRITE(MSTU(11),5500) 'Mixing structure'
46686 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46687 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46688 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46689 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46690 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46691 & ),(SFMIX(15,J),J=3,4)
46692 WRITE(MSTU(11),5400)
46693 WRITE(MSTU(11),5500) 'Couplings'
46694 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46695 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46696 WRITE(MSTU(11),5400)
46697 WRITE(MSTU(11),6500)
46698
46699 ENDIF
46700
46701C...Only rewind when reading
46702 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46703
46704 9999 RETURN
46705
46706C...Serious error catching
46707 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46708 write(*,*) CHINL(1:80)
46709 CALL PYSTOP(106)
46710 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46711 WRITE(*,*) CHINL(1:72)
46712 CALL PYSTOP(106)
46713 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46714 WRITE(*,*) CHINL(1:80)
46715 CALL PYSTOP(106)
46716 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46717 WRITE(*,*) CHINL(1:80)
46718 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46719 CALL PYSTOP(106)
46720 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46721 WRITE(*,*) CHINL(1:80)
46722 CALL PYSTOP(106)
46723
46724 8300 FORMAT(I9)
46725 8500 FORMAT(F16.5)
46726
46727C...Formats for user information printout.
46728 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46729 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46730 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46731 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46732 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46733 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46734 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46735 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46736 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46737 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46738 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46739 & ,'----------------')
46740 5400 FORMAT(1x,'*',1x,A)
46741 5500 FORMAT(1x,'*',1x,A,':')
46742 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46743 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46744 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46745 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46746 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46747 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46748 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46749 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46750 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46751 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46752 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46753 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46754 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46755 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46756 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46757 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46758 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46759 & ,1x,F6.3,1x),'|')
46760 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46761 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46762 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46763 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46764 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46765 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46766 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46767 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46768 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46769 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46770 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46771 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46772 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46773 & ,'A_tau = ',F8.2)
46774 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46775 & ,' mu = ',F8.2)
46776 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46777
46778C...Format to use for comments
46779 7000 FORMAT('# ',A)
46780C...Format to use for block statements
46781 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46782 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46783C...Indexed Int
46784 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46785C...Non-Indexed Double
46786 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46787C...Indexed Double
46788 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46789C...Long Indexed Double (PDG + double)
46790 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46791C...Indexed Char(12)
46792 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46793C...Single matrix
46794 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46795C...Double Matrix
46796 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46797C...Write Decay Table
46798 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46799 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46800 & 3x,'#',1x,A)
46801
46802 END
46803
46804
46805C*********************************************************************
46806
46807C...PYAPPS
46808C...Uses approximate analytical formulae to determine the full set of
46809C...MSSM parameters from SUGRA input.
46810C...See M. Drees and S.P. Martin, hep-ph/9504124
46811
46812 SUBROUTINE PYAPPS
46813
46814C...Double precision and integer declarations.
46815 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46816 IMPLICIT INTEGER(I-N)
46817 INTEGER PYK,PYCHGE,PYCOMP
46818C...Parameter statement to help give large particle numbers.
46819 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46820 &KEXCIT=4000000,KDIMEN=5000000)
46821C...Commonblocks.
46822 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46823 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46824 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46825 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46826
46827 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46828 &' not intended for serious physics studies'
46829 IMSS(5)=0
46830 IMSS(8)=0
46831 XMT=PMAS(6,1)
46832 XMZ2=PMAS(23,1)**2
46833 XMW2=PMAS(24,1)**2
46834 TANB=RMSS(5)
46835 BETA=ATAN(TANB)
46836 XW=PARU(102)
46837 XMG=RMSS(1)
46838 XMG2=XMG*XMG
46839 XM0=RMSS(8)
46840 XM02=XM0*XM0
46841C...Temporary sign change for AT. Others unchanged.
46842 AT=-RMSS(16)
46843 RMSS(15)=RMSS(16)
46844 RMSS(17)=RMSS(16)
46845 SINB=TANB/SQRT(TANB**2+1D0)
46846 COSB=SINB/TANB
46847
46848 DTERM=XMZ2*COS(2D0*BETA)
46849 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46850 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46851 RMSS(6)=XMEL
46852 RMSS(7)=XMER
46853 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46854 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46855 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46856 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46857 DO 100 I=1,5,2
46858 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46859 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46860 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46861 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46862 100 CONTINUE
46863 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46864 IF(XARG.LT.0D0) THEN
46865 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46866 & ' FROM THE SUM RULE. '
46867 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46868 RETURN
46869 ELSE
46870 XARG=SQRT(XARG)
46871 ENDIF
46872 DO 110 I=11,15,2
46873 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46874 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46875 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46876 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46877 110 CONTINUE
46878 RMT=PYMRUN(6,PMAS(6,1)**2)
46879 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46880 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46881 RMB=PYMRUN(5,PMAS(6,1)**2)
46882 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46883 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46884 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46885 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46886 &SINB)**2)
46887 RMSS(16)=-ATP
46888 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46889 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46890 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46891 XMU=SIGN(SQRT(XMU2),RMSS(4))
46892 RMSS(4)=XMU
46893 IF(XMA2.GT.0D0) THEN
46894 RMSS(19)=SQRT(XMA2)
46895 ELSE
46896 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46897 CALL PYSTOP(102)
46898 ENDIF
46899 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46900 IF(ARG.GT.0D0) THEN
46901 RMSS(14)=SQRT(ARG)
46902 ELSE
46903 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46904 CALL PYSTOP(102)
46905 ENDIF
46906 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46907 IF(ARG.GT.0D0) THEN
46908 RMSS(13)=SQRT(ARG)
46909 ELSE
46910 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46911 CALL PYSTOP(102)
46912 ENDIF
46913 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46914 IF(ARG.GT.0D0) THEN
46915 RMSS(10)=SQRT(ARG)
46916 ELSE
46917 RMSS(10)=-SQRT(-ARG)
46918 ENDIF
46919 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46920 IF(ARG.GT.0D0) THEN
46921 RMSS(12)=SQRT(ARG)
46922 ELSE
46923 RMSS(12)=-SQRT(-ARG)
46924 ENDIF
46925 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46926 IF(ARG.GT.0D0) THEN
46927 RMSS(11)=SQRT(ARG)
46928 ELSE
46929 RMSS(11)=-SQRT(-ARG)
46930 ENDIF
46931
46932 RETURN
46933 END
46934
46935C*********************************************************************
46936
46937C...PYSUGI
46938C...Interface to ISASUSY version 7.71.
46939C...Warning: this interface should not be used with earlier versions
46940C...of ISASUSY, since common block incompatibilities may then arise.
46941C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46942C...Then converts to Gunion-Haber conventions.
46943
46944 SUBROUTINE PYSUGI
46945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46946
46947 INTEGER PYK,PYCHGE,PYCOMP
46948 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46949 &KEXCIT=4000000,KDIMEN=5000000)
46950
46951C...Date of Change
46952 CHARACTER DOC*11
46953 PARAMETER (DOC='01 May 2006')
46954
46955C...ISASUGRA Input:
46956 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46957C...XISAIN contains the MSSMi inputs in natural order.
46958 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46959 $XAMIN(7)
46960 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46961 SAVE /SUGXIN/
46962C...ISASUGRA Output
46963 CHARACTER*40 ISAVER,VISAJE
46964 REAL SUPER
46965 COMMON /SSPAR/ SUPER(72)
46966 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46967 $FBGUT,FTAGUT,FNGUT
46968 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46969 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46970 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46971 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46972 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46973 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46974 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46975 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46976 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46977 INTEGER IALLOW
46978 SAVE /SUGMG/,/SSPAR/
46979C SUPER: Filled by ISASUGRA.
46980C SUPER(1) = mass of ~g
46981C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46982C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46983C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46984C ,~tau_2
46985C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46986C SUPER(29) = Higgsino mass = - mu
46987C SUPER(30) = ratio v2/v1 of vev's
46988C SUPER(31:34) = Signed neutralino masses
46989C SUPER(35:50) = Neutralino mixing matrix
46990C SUPER(51:52) = Signed chargino masses
46991C SUPER(53:54) = Chargino left, right mixing angles
46992C SUPER(55:58) = mass of h0, H0, A0, H+
46993C SUPER(59) = Higgs mixing angle alpha
46994C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
46995C SUPER(66) = Gravitino mass
46996C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
46997C SUPER(70) = b-Yukawa at mA scale (not used)
46998C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
46999C GSS: Filled by ISASUGRA
47000C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47001C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47002C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47003C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47004C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47005C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47006C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47007C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47008C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47009C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47010C GSS(31) = log(vuq)
47011C MSS: Filled by ISASUGRA
47012C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47013C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47014C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47015C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47016C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47017C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47018C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47019C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47020C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47021C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47022C MSS(31) = ha0 MSS(32) = h+
47023C Unification, filled by ISASUGRA if applicable.
47024C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47025
47026C...SPYTHIA Input/Output
47027 INTEGER IMSS
47028 DOUBLE PRECISION RMSS
47029 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47030 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47031 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47032C...SLHA Input/Output
47033 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47034 & AU(3,3),AD(3,3),AE(3,3)
47035C...PYTHIA common blocks
47036 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47037 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47038 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47039
47040 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47041CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47042 INTEGER IMODEL
47043 REAL M0,MHF,A0,MT
47044 CHARACTER*20 CHMOD(5)
47045 CHARACTER*32 FNAME
47046
47047 COMMON /SUGNU/ XNUSUG(18)
47048 REAL XNUSUG
47049 SAVE /SUGNU/
47050
47051 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47052 & 'truly unified SUGRA', 'non-minimal GMSB'/
47053
47054C...Start by checking for incompatibilities/inconsistencies:
47055 DO 100 ICHK=2,9
47056 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47057 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47058 & ,' option not used by PYSUGI'
47059 ENDIF
47060 100 CONTINUE
47061C...ISAJET works with REAL numbers.
47062 MZERO=REAL(RMSS(8))
47063 MHLF=REAL(RMSS(1))
47064 AZERO=REAL(RMSS(16))
47065 TANB=REAL(RMSS(5))
47066 SGNMU=REAL(RMSS(4))
47067 MTOP=REAL(PMAS(6,1))
47068 IMODEL=0
47069 IF (IMSS(1).EQ.12) THEN
47070 IMODEL=1
47071 GOTO 130
47072 ELSEIF(IMSS(1).EQ.13) THEN
47073C...Read from isajet par file in IMSS(20)
47074 LFN=IMSS(20)
47075C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47076 IF (LFN.EQ.0) THEN
47077 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47078 GOTO 9999
47079 ENDIF
47080 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47081CMrenna change to allow any susy model
47082 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47083 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47084 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47085 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47086 & ' gauge couplings:'
47087 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47088 READ(LFN,*) IMODEL
47089 IF (IMODEL.EQ.4) THEN
47090 IAL3UN=1
47091 IMODEL=1
47092 ENDIF
47093 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47094 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47095 & //' sgn(mu), M_t:'
47096 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47097 IF (IMODEL.EQ.3) THEN
47098 IMODEL=1
47099 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47100 & //' 0 to continue:'
47101 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47102 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47103 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47104 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47105 & //' generation masses'
47106 WRITE(MSTU(11),*)
47107 & ' NUSUG5 = GUT scale 3rd generation masses'
47108 READ(LFN,*) INUSUG
47109 IF (INUSUG.EQ.0) THEN
47110 GOTO 120
47111 ELSEIF (INUSUG.EQ.1) THEN
47112 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47113 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47114 IF (XNUSUG(3).LE.0.) THEN
47115 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47116 CALL PYSTOP(109)
47117 END IF
47118 ELSEIF (INUSUG.EQ.2) THEN
47119 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47120 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47121 ELSEIF (INUSUG.EQ.3) THEN
47122 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47123 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47124 ELSEIF (INUSUG.EQ.4) THEN
47125 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47126 & //' M(ur), M(el), M(er):'
47127 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47128 & XNUSUG(10),XNUSUG(9)
47129 ELSEIF (INUSUG.EQ.5) THEN
47130 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47131 & //' M(Ll), M(Lr):'
47132 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47133 & XNUSUG(15),XNUSUG(14)
47134 ENDIF
47135 GOTO 110
47136 ENDIF
47137 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47138 IMSS(11)=1
47139 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47140 & ,' sgn(mu), M_t, C_gv:'
47141 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47142 XGMIN(7)=XCMGV
47143 XGMIN(8)=1.
47144C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47145 AMPL=2.4D18
47146 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47147 IF (IMODEL.EQ.5) THEN
47148 IMODEL=2
47149 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47150 & ,' masses at M_mes'
47151 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47152 & ,' shifts at M_mes'
47153 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47154 & ' Y at M_mes'
47155 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47156 & ,'SU(2),SU(3)'
47157 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47158 & ,' n5_2, n5_3'
47159 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47160 $ XGMIN(13),XGMIN(14)
47161 ENDIF
47162 ELSE
47163 WRITE(MSTU(11),*) 'Invalid model choice.'
47164 GOTO 9999
47165 ENDIF
47166 ENDIF
47167
47168 120 MZERO=M0
47169 MHLF=MHF
47170 AZERO=A0
47171C TANB=REAL(RMSS(5))
47172C SGNMU=REAL(RMSS(4))
47173 MTOP=MT
47174
47175C...Initialize MSSM parameter array
47176 130 DO 140 IPAR=1,72
47177 SUPER(IPAR)=0.0
47178 140 CONTINUE
47179C...Call ISASUGRA
47180 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47181C...Check whether ISASUSY thought the model was OK.
47182 IF (NOGOOD.NE.0) THEN
47183 IF (NOGOOD.EQ.1) CALL PYERRM(26
47184 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47185 IF (NOGOOD.EQ.2) CALL PYERRM(26
47186 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47187 IF (NOGOOD.EQ.3) CALL PYERRM(26
47188 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47189 IF (NOGOOD.EQ.4) CALL PYERRM(26
47190 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47191 IF (NOGOOD.EQ.7) CALL PYERRM(26
47192 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47193 IF (NOGOOD.EQ.8) CALL PYERRM(26
47194 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47195C...Give warning, but don't stop, if LSP not ~chi_10.
47196 IF (NOGOOD.EQ.5) CALL PYERRM(16
47197 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47198 ENDIF
47199C...Warn about possible GUT scale tachyons.
47200 IF (ITACHY.NE.0) CALL PYERRM(16,
47201 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47202C...Finalize spectrum (last iteration)
47203C...(Thanks to A. Raklev for pointing this out.)
47204C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47205 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47206 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47207 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47208 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47209 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47210 $ MTOP,IALLOW,1)
47211
47212C...M1, M2, M3.
47213 RMSS(1)=dble(GSS(7))
47214 RMSS(2)=dble(GSS(8))
47215 RMSS(3)=dble(GSS(9))
47216 RMSOFT(1)=dble(GSS(7))
47217 RMSOFT(2)=dble(GSS(8))
47218 RMSOFT(3)=dble(GSS(9))
47219C...Mu = - Higgsino mass.
47220 RMSS(4)=-SUPER(29)
47221 RMSS(5)=TANB
47222C...Slepton and squark masses. 2 first generations.
47223 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47224 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47225 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47226 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47227C...Third generation.
47228 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47229 RMSS(11)=SUPER(11)
47230 RMSS(12)=SUPER(15)
47231 RMSS(13)=SUPER(22)
47232 RMSS(14)=SUPER(23)
47233C...SLHA: store exact soft spectrum in RMSOFT
47234 RMSOFT(31)=SUPER(18)
47235 RMSOFT(32)=SUPER(20)
47236 RMSOFT(33)=SUPER(22)
47237 RMSOFT(34)=SUPER(19)
47238 RMSOFT(35)=SUPER(21)
47239 RMSOFT(36)=SUPER(23)
47240 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47241 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47242 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47243 RMSOFT(44)=SUPER(3)
47244 RMSOFT(45)=SUPER(9)
47245 RMSOFT(46)=SUPER(15)
47246 RMSOFT(47)=SUPER(5)
47247 RMSOFT(48)=SUPER(7)
47248 RMSOFT(49)=SUPER(11)
47249
47250C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47251 RMSS(15)=SUPER(62)
47252 RMSS(16)=SUPER(60)
47253 RMSS(17)=SUPER(64)
47254 RMSS(26)=SUPER(63)
47255 RMSS(27)=SUPER(61)
47256 RMSS(28)=SUPER(65)
47257C...SLHA trilinears
47258 DO 142 K1=1,3
47259 DO 141 K2=1,3
47260 AE(K1,K2)=0D0
47261 AU(K1,K2)=0D0
47262 AD(K1,K2)=0D0
47263 141 CONTINUE
47264 142 CONTINUE
47265 AE(3,3)=SUPER(64)
47266 AU(3,3)=SUPER(60)
47267 AD(3,3)=SUPER(62)
47268C...Higgs mixing angle alpha (Gunion-Haber convention).
47269 RMSS(18)=-SUPER(59)
47270C...A0 mass.
47271 RMSS(19)=SUPER(57)
47272C...GUT scale coupling
47273 RMSS(20)=AGUTSS
47274C...Gravitino mass (for future compatibility)
47275 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47276
47277C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47278C...Higgs sector.
47279 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47280 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47281 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47282 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47283C...Gluino.
47284 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47285C...Squarks and Sleptons.
47286 DO 150 ILR=1,2
47287 ILRM=ILR-1
47288 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47289 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47290 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47291 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47292 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47293 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47294 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47295 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47296 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47297 150 CONTINUE
47298 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47299 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47300 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47301C...Neutralinos.
47302 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47303 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47304 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47305 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47306C...Signed masses (extra minus from going to G-H convention).
47307 SMZ(1)=-SUPER(31)
47308 SMZ(2)=-SUPER(32)
47309 SMZ(3)=-SUPER(33)
47310 SMZ(4)=-SUPER(34)
47311C...Charginos
47312 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47313 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47314C...Signed masses (extra minus from going to G-H convention).
47315 SMW(1)=-SUPER(51)
47316 SMW(2)=-SUPER(52)
47317
47318C... Neutralino Mixing.
47319 DO 160 IN=1,4
47320 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47321 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47322 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47323 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47324 160 CONTINUE
47325C...Chargino Mixing (PYTHIA same angle as HERWIG).
47326 THX=1D0
47327 THY=1D0
47328 IF (SUPER(53).GT.0) THX=-1D0
47329 IF (SUPER(54).GT.0) THY=-1D0
47330 UMIX(1,1) = -SIN(SUPER(53))
47331 UMIX(1,2) = -COS(SUPER(53))
47332 UMIX(2,1) = -THX*COS(SUPER(53))
47333 UMIX(2,2) = THX*SIN(SUPER(53))
47334 VMIX(1,1) = -SIN(SUPER(54))
47335 VMIX(1,2) = -COS(SUPER(54))
47336 VMIX(2,1) = -THY*COS(SUPER(54))
47337 VMIX(2,2) = THY*SIN(SUPER(54))
47338C...Sfermion mixing (PYTHIA same angle as ISAJET)
47339 SFMIX(5,1)=COS(SUPER(63))
47340 SFMIX(5,2)=SIN(SUPER(63))
47341 SFMIX(5,3)=-SIN(SUPER(63))
47342 SFMIX(5,4)=COS(SUPER(63))
47343 SFMIX(6,1)=COS(SUPER(61))
47344 SFMIX(6,2)=SIN(SUPER(61))
47345 SFMIX(6,3)=-SIN(SUPER(61))
47346 SFMIX(6,4)=COS(SUPER(61))
47347 SFMIX(15,1)=COS(SUPER(65))
47348 SFMIX(15,2)=SIN(SUPER(65))
47349 SFMIX(15,3)=-SIN(SUPER(65))
47350 SFMIX(15,4)=COS(SUPER(65))
47351
47352 IF (MSTP(122).NE.0) THEN
47353C...Print a few lines to make the user know what's happening
47354 ISAVER=VISAJE()
47355 WRITE(MSTU(11),5000) DOC, ISAVER
47356 WRITE(MSTU(11),5100)
47357 IF (IMODEL.EQ.1) THEN
47358 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47359 & MTOP
47360 WRITE(MSTU(11),5300)
47361 ENDIF
47362 WRITE(MSTU(11),5500) 'Pole masses'
47363 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47364 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47365 & ,(SUPER(IP),IP=19,25,2)
47366 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47367 & ,IP=1,2)
47368 WRITE(MSTU(11),5400)
47369 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47370 WRITE(MSTU(11),5400)
47371 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47372 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47373 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47374 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47375 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47376 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47377 & ),(SFMIX(15,J),J=3,4)
47378 WRITE(MSTU(11),5400)
47379 WRITE(MSTU(11),6450) RMSS(18)
47380 WRITE(MSTU(11),5400)
47381 WRITE(MSTU(11),5500) 'Couplings'
47382 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47383 WRITE(MSTU(11),5400)
47384 ENDIF
47385
47386C...Call FeynHiggs to improve Higgs sector if requested
47387 IF (IMSS(4).EQ.3) THEN
47388 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47389 & ' (PYSUGI:) Now calling FeynHiggs.'
47390 CALL PYFEYN(IERR)
47391 IF (IERR.EQ.0) THEN
47392 IMSS(4)=2
47393 IF (MSTP(122).NE.0) THEN
47394 WRITE(MSTU(11),5400)
47395 WRITE(MSTU(11),5500)
47396 & 'Corrected Higgs masses and mixing'
47397 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47398 & PMAS(37,1)
47399 WRITE(MSTU(11),6450) RMSS(18)
47400 WRITE(MSTU(11),5400)
47401 ENDIF
47402 ENDIF
47403 ENDIF
47404
47405 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47406
47407C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47408C...output by ISASUSY.
47409 IMSS(4)=MAX(2,IMSS(4))
47410
47411 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47412 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47413 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47414 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47415 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47416 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47417 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47418 & ,'----------------')
47419 5400 FORMAT(1x,'*',1x,A)
47420 5500 FORMAT(1x,'*',1x,A,':')
47421 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47422 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47423 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47424 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47425 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47426 & ,1x))
47427 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47428 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47429 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47430 & .2,1x))
47431 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47432 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47433 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47434 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47435 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47436 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47437 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47438 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47439 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47440 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47441 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47442 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47443 & ,1x,F6.3,1x),'|')
47444 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47445 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47446 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47447 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47448 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47449 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47450 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47451 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47452 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47453 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47454 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47455 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47456 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47457 & ,4x,'Alpha_GUT = ',F8.2)
47458 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47459 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47460
47461 9999 RETURN
47462 END
47463
47464C*********************************************************************
47465
47466C...PYFEYN
47467C...Interface to FeynHiggs for MSSM Higgs sector.
47468C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47469C...P. Skands
47470
47471 SUBROUTINE PYFEYN(IERR)
47472
47473C...Double precision and integer declarations.
47474 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47475 IMPLICIT INTEGER(I-N)
47476 INTEGER PYK,PYCHGE,PYCOMP
47477C...Commonblocks.
47478 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47479 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47480C...SUSY blocks
47481 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47482C...FeynHiggs variables
47483 DOUBLE PRECISION RMHIGG(4)
47484 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47485 DOUBLE COMPLEX DMU,
47486 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47487 & DM1, DM2, DM3
47488C...SLHA Common Block
47489 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47490 & AU(3,3),AD(3,3),AE(3,3)
47491 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47492
47493 IERR=0
47494 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47495 IF (IERR.NE.0) THEN
47496 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47497 & //'Will not use FeynHiggs for this run.')
47498 RETURN
47499 ENDIF
47500 Q=RMSOFT(0)
47501 DMB=PMAS(5,1)
47502 DMT=PMAS(6,1)
47503 DMZ=PMAS(23,1)
47504 DMW=PMAS(24,1)
47505 DMA=PMAS(36,1)
47506 DM1=RMSOFT(1)
47507 DM2=RMSOFT(2)
47508 DM3=RMSOFT(3)
47509 DTANB=RMSS(5)
47510 DMU=RMSS(4)
47511 DM3SL=RMSOFT(33)
47512 DM3SE=RMSOFT(36)
47513 DM3SQ=RMSOFT(43)
47514 DM3SU=RMSOFT(46)
47515 DM3SD=RMSOFT(49)
47516 DM2SL=RMSOFT(32)
47517 DM2SE=RMSOFT(35)
47518 DM2SQ=RMSOFT(42)
47519 DM2SU=RMSOFT(45)
47520 DM2SD=RMSOFT(48)
47521 DM1SL=RMSOFT(31)
47522 DM1SE=RMSOFT(34)
47523 DM1SQ=RMSOFT(41)
47524 DM1SU=RMSOFT(44)
47525 DM1SD=RMSOFT(47)
47526 AE33=AE(3,3)
47527 AE22=AE(2,2)
47528 AE11=AE(1,1)
47529 AU33=AU(3,3)
47530 AU22=AU(2,2)
47531 AU11=AU(1,1)
47532 AD33=AD(3,3)
47533 AD22=AD(2,2)
47534 AD11=AD(1,1)
47535 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47536 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47537 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47538 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47539 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47540 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47541 IF (IERR.NE.0) THEN
47542 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47543 & //' Will not use FeynHiggs for this run.')
47544 RETURN
47545 ENDIF
47546C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47547 SAEFF=0D0
47548 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47549 IF (IERR.NE.0) THEN
47550 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47551 & 'GSCORR. Will not use FeynHiggs for this run.')
47552 RETURN
47553 ENDIF
47554 ALPHA = ASIN(DBLE(SAEFF))
47555 R=RMSS(18)/ALPHA
47556 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47557 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47558 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47559 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47560 ENDIF
47561 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47562 & 1.15D0*PMAS(25,1)) THEN
47563 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47564 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47565 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47566 ENDIF
47567 RMSS(18)=ALPHA
47568 PMAS(25,1)=RMHIGG(1)
47569 PMAS(35,1)=RMHIGG(2)
47570 PMAS(36,1)=RMHIGG(3)
47571 PMAS(37,1)=RMHIGG(4)
47572
47573 RETURN
47574 END
47575
47576C*********************************************************************
47577
47578C...PYRNMQ
47579C...Determines the running mass of Squarks.
47580
47581 FUNCTION PYRNMQ(ID,DTERM)
47582
47583C...Double precision and integer declarations.
47584 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47585 IMPLICIT INTEGER(I-N)
47586 INTEGER PYK,PYCHGE,PYCOMP
47587C...Commonblock.
47588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47589 SAVE /PYMSSM/
47590
47591C...Local variables.
47592 DOUBLE PRECISION PI,R
47593 DOUBLE PRECISION TOL
47594 DOUBLE PRECISION CI(3)
47595 EXTERNAL PYALPS
47596 DOUBLE PRECISION PYALPS
47597 DATA TOL/0.001D0/
47598 DATA PI,R/3.141592654D0,.61803399D0/
47599 DATA CI/0.47D0,0.07D0,0.02D0/
47600
47601 C=1D0-R
47602 CA=CI(ID)
47603 AG=(0.71D0)**2/4D0/PI
47604 AG=RMSS(20)
47605 XM0=RMSS(8)
47606 XMG=RMSS(1)
47607 XM02=XM0*XM0
47608 XMG2=XMG*XMG
47609
47610 AS=PYALPS(XM02+6D0*XMG2)
47611 CG=8D0/9D0*((AS/AG)**2-1D0)
47612 BX=XM02+(CA+CG)*XMG2+DTERM
47613 AX=MIN(50D0**2,0.5D0*BX)
47614 CX=MAX(2000D0**2,2D0*BX)
47615
47616 X0=AX
47617 X3=CX
47618 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47619 X1=BX
47620 X2=BX+C*(CX-BX)
47621 ELSE
47622 X2=BX
47623 X1=BX-C*(BX-AX)
47624 ENDIF
47625 AS1=PYALPS(X1)
47626 CG=8D0/9D0*((AS1/AG)**2-1D0)
47627 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47628 AS2=PYALPS(X2)
47629 CG=8D0/9D0*((AS2/AG)**2-1D0)
47630 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47631 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47632 IF(F2.LT.F1) THEN
47633 X0=X1
47634 X1=X2
47635 X2=R*X1+C*X3
47636 F1=F2
47637 AS2=PYALPS(X2)
47638 CG=8D0/9D0*((AS2/AG)**2-1D0)
47639 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47640 ELSE
47641 X3=X2
47642 X2=X1
47643 X1=R*X2+C*X0
47644 F2=F1
47645 AS1=PYALPS(X1)
47646 CG=8D0/9D0*((AS1/AG)**2-1D0)
47647 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47648 ENDIF
47649 GOTO 100
47650 ENDIF
47651 IF(F1.LT.F2) THEN
47652 PYRNMQ=X1
47653 XMIN=X1
47654 ELSE
47655 PYRNMQ=X2
47656 XMIN=X2
47657 ENDIF
47658
47659 RETURN
47660 END
47661
47662C*********************************************************************
47663
47664C...PYTHRG
47665C...Calculates the mass eigenstates of the third generation sfermions.
47666C...Created: 5-31-96
47667
47668 SUBROUTINE PYTHRG
47669
47670C...Double precision and integer declarations.
47671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47672 IMPLICIT INTEGER(I-N)
47673 INTEGER PYK,PYCHGE,PYCOMP
47674C...Parameter statement to help give large particle numbers.
47675 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47676 &KEXCIT=4000000,KDIMEN=5000000)
47677C...Commonblocks.
47678 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47679 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47680 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47681 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47682 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47683 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47684
47685C...Local variables.
47686 DOUBLE PRECISION BETA
47687 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47688 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47689 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47690 DOUBLE PRECISION ATR,AMQR,AMQL
47691 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47692 INTEGER IF,I,J,II,JJ,IT,L
47693 LOGICAL DTERM
47694 DATA SMALL/1D-3/
47695 DATA ID1/10,10,13/
47696 DATA ID2/5,6,15/
47697 DATA ID3/15,16,17/
47698 DATA ID4/11,12,14/
47699 DATA DTERM/.TRUE./
47700
47701 XMZ2=PMAS(23,1)**2
47702 XMW2=PMAS(24,1)**2
47703 TANB=RMSS(5)
47704 XMU=-RMSS(4)
47705 BETA=ATAN(TANB)
47706 COS2B=COS(2D0*BETA)
47707
47708C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47709
47710 IOPT=IMSS(5)
47711 IF(IOPT.EQ.1) THEN
47712 CTT=DCOS(RMSS(27))
47713 CTT2=CTT**2
47714 STT=DSIN(RMSS(27))
47715 STT2=STT**2
47716 XM12=RMSS(10)**2
47717 XM22=RMSS(12)**2
47718 XMQL2=CTT2*XM12+STT2*XM22
47719 XMQR2=STT2*XM12+CTT2*XM22
47720 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47721 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47722 RMSS(16)=ATOP
47723C......SUBTRACT OUT D-TERM AND FERMION MASS
47724 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47725 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47726 IF(XMQL2.GE.0D0) THEN
47727 RMSS(10)=SQRT(XMQL2)
47728 ELSE
47729 RMSS(10)=-SQRT(-XMQL2)
47730 ENDIF
47731 IF(XMQR2.GE.0D0) THEN
47732 RMSS(12)=SQRT(XMQR2)
47733 ELSE
47734 RMSS(12)=-SQRT(-XMQR2)
47735 ENDIF
47736
47737C SAME FOR BOTTOM SQUARK
47738 CTT=DCOS(RMSS(26))
47739 CTT2=CTT**2
47740 STT=DSIN(RMSS(26))
47741 STT2=STT**2
47742 XM22=RMSS(11)**2
47743 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47744 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47745 IF(ABS(CTT).GE..9999D0) THEN
47746 ABOT=-XMU*TANB
47747 XMQR2=RMSS(11)**2
47748 ELSEIF(ABS(CTT).LE.1D-4) THEN
47749 ABOT=-XMU*TANB
47750 XMQR2=RMSS(11)**2
47751 ELSE
47752 XM12=(XMQL2-STT2*XM22)/CTT2
47753 XMQR2=STT2*XM12+CTT2*XM22
47754 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47755 ENDIF
47756 RMSS(15)=ABOT
47757C......SUBTRACT OUT D-TERM AND FERMION MASS
47758 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47759 IF(XMQR2.GE.0D0) THEN
47760 RMSS(11)=SQRT(XMQR2)
47761 ELSE
47762 RMSS(11)=-SQRT(-XMQR2)
47763 ENDIF
47764C SAME FOR TAU SLEPTON
47765 CTT=DCOS(RMSS(28))
47766 CTT2=CTT**2
47767 STT=DSIN(RMSS(28))
47768 STT2=STT**2
47769 XM12=RMSS(13)**2
47770 XM22=RMSS(14)**2
47771 XMQL2=CTT2*XM12+STT2*XM22
47772 XMQR2=STT2*XM12+CTT2*XM22
47773 XMFR=PMAS(15,1)
47774 XMF2=XMFR**2
47775 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47776 RMSS(17)=ATAU
47777C......SUBTRACT OUT D-TERM AND FERMION MASS
47778 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47779 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47780 IF(XMQL2.GE.0D0) THEN
47781 RMSS(13)=SQRT(XMQL2)
47782 ELSE
47783 RMSS(13)=-SQRT(-XMQL2)
47784 ENDIF
47785 IF(XMQR2.GE.0D0) THEN
47786 RMSS(14)=SQRT(XMQR2)
47787 ELSE
47788 RMSS(14)=-SQRT(-XMQR2)
47789 ENDIF
47790 ENDIF
47791 DO 170 L=1,3
47792 AMQL=RMSS(ID1(L))
47793 IF(AMQL.LT.0D0) THEN
47794 XMQL2=-AMQL**2
47795 ELSE
47796 XMQL2=AMQL**2
47797 ENDIF
47798 ATR=RMSS(ID3(L))
47799 AMQR=RMSS(ID4(L))
47800 IF(AMQR.LT.0D0) THEN
47801 XMQR2=-AMQR**2
47802 ELSE
47803 XMQR2=AMQR**2
47804 ENDIF
47805 IF=ID2(L)
47806 XMF=PYMRUN(IF,PMAS(6,1)**2)
47807 XMF2=XMF**2
47808 AM2(1,1)=XMQL2+XMF2
47809 AM2(2,2)=XMQR2+XMF2
47810 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47811 IF(DTERM) THEN
47812 IF(L.EQ.1) THEN
47813 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47814 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47815 AM2(1,2)=XMF*(ATR+XMU*TANB)
47816 ELSEIF(L.EQ.2) THEN
47817 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47818 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47819 AM2(1,2)=XMF*(ATR+XMU/TANB)
47820 ELSEIF(L.EQ.3) THEN
47821 IF(IMSS(8).EQ.1) THEN
47822 AM2(1,1)=RMSS(6)**2
47823 AM2(2,2)=RMSS(7)**2
47824 AM2(1,2)=0D0
47825 RMSS(13)=RMSS(6)
47826 RMSS(14)=RMSS(7)
47827 ELSE
47828 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47829 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47830 AM2(1,2)=XMF*(ATR+XMU*TANB)
47831 ENDIF
47832 ENDIF
47833 ENDIF
47834 AM2(2,1)=AM2(1,2)
47835 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47836 IF(DETM.LT.0D0) THEN
47837 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47838 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47839 ENDIF
47840 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47841 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47842 XMF12=SAME-DIFF
47843 XMF22=SAME+DIFF
47844 IT=0
47845 IF(XMF22-XMF12.GT.0D0) THEN
47846 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47847 RT(2,2) = RT(1,1)
47848 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47849 & AM2(1,2)/(XMF22-XMF12))
47850 RT(2,1) = -RT(1,2)
47851 ELSE
47852 RT(1,1) = 1D0
47853 RT(2,2) = RT(1,1)
47854 RT(1,2) = 0D0
47855 RT(2,1) = -RT(1,2)
47856 ENDIF
47857 100 CONTINUE
47858 IT=IT+1
47859
47860 DO 140 I=1,2
47861 DO 130 JJ=1,2
47862 DI(I,JJ)=0D0
47863 DO 120 II=1,2
47864 DO 110 J=1,2
47865 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47866 110 CONTINUE
47867 120 CONTINUE
47868 130 CONTINUE
47869 140 CONTINUE
47870
47871 IF(DI(1,1).GT.DI(2,2)) THEN
47872 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47873 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47874 WRITE(MSTU(11),*) AM2
47875 WRITE(MSTU(11),*) DI
47876 WRITE(MSTU(11),*) RT
47877 DI(1,1)=-RT(2,1)
47878 DI(2,2)=RT(1,2)
47879 DI(1,2)=-RT(2,2)
47880 DI(2,1)=RT(1,1)
47881 DO 160 I=1,2
47882 DO 150 J=1,2
47883 RT(I,J)=DI(I,J)
47884 150 CONTINUE
47885 160 CONTINUE
47886 GOTO 100
47887 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47888 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47889 & ' OFF DIAGONAL ELEMENTS '
47890 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47891 WRITE(MSTU(11),*) DI
47892 WRITE(MSTU(11),*) ' ROTATION = ',RT
47893C...STOP
47894 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47895 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47896 & ' NEGATIVE MASSES '
47897 CALL PYSTOP(111)
47898 ENDIF
47899 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47900 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47901 SFMIX(IF,1)=RT(1,1)
47902 SFMIX(IF,2)=RT(1,2)
47903 SFMIX(IF,3)=RT(2,1)
47904 SFMIX(IF,4)=RT(2,2)
47905 170 CONTINUE
47906
47907C.....TAU SNEUTRINO MASS...L=3
47908
47909 XARG=AM2(1,1)+XMW2*COS2B
47910 IF(XARG.LT.0D0) THEN
47911 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47912 & ' FROM THE SUM RULE. '
47913 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47914 RETURN
47915 ELSE
47916 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47917 ENDIF
47918
47919 RETURN
47920 END
47921C*********************************************************************
47922
47923C...PYINOM
47924C...Finds the mass eigenstates and mixing matrices for neutralinos
47925C...and charginos.
47926
47927 SUBROUTINE PYINOM
47928
47929C...Double precision and integer declarations.
47930 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47931 IMPLICIT INTEGER(I-N)
47932 INTEGER PYCOMP
47933C...Parameter statement to help give large particle numbers.
47934 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47935 &KEXCIT=4000000,KDIMEN=5000000)
47936C...Commonblocks.
47937 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47938 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47939 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47940 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47941 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47942 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47943
47944C...Local variables.
47945 DOUBLE PRECISION XMW,XMZ,XM(4)
47946 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47947 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47948 DOUBLE PRECISION COSW,SINW
47949 DOUBLE PRECISION XMU
47950 DOUBLE PRECISION TANB,COSB,SINB
47951 DOUBLE PRECISION XM1,XM2,XM3,BETA
47952 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47953 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47954 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47955 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47956 DOUBLE PRECISION PYALPS,PYALEM
47957 DOUBLE PRECISION PYRNM3
47958 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47959 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47960 DATA KFNCHI/1000022,1000023,1000025,1000035/
47961
47962 IOPT=IMSS(2)
47963 IF(IMSS(1).EQ.2) THEN
47964 IOPT=1
47965 ENDIF
47966C...M1, M2, AND M3 ARE INDEPENDENT
47967 IF(IOPT.EQ.0) THEN
47968 XM1=RMSS(1)
47969 XM2=RMSS(2)
47970 XM3=RMSS(3)
47971 ELSEIF(IOPT.GE.1) THEN
47972 Q2=PMAS(23,1)**2
47973 AEM=PYALEM(Q2)
47974 A2=AEM/PARU(102)
47975 A1=AEM/(1D0-PARU(102))
47976 XM1=RMSS(1)
47977 XM2=RMSS(2)
47978 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47979 IF(IOPT.EQ.1) THEN
47980 XM2=XM1*A2/A1*3D0/5D0
47981 RMSS(2)=XM2
47982 ELSEIF(IOPT.EQ.3) THEN
47983 XM1=XM2*5D0/3D0*A1/A2
47984 RMSS(1)=XM1
47985 ENDIF
47986 XM3=PYRNM3(XM2/A2)
47987 RMSS(3)=XM3
47988 IF(XM3.LE.0D0) THEN
47989 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47990 CALL PYSTOP(105)
47991 ENDIF
47992 ENDIF
47993
47994C...GLUINO MASS
47995 IF(IMSS(3).EQ.1) THEN
47996 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
47997 ELSE
47998 AQ=0D0
47999 DO 110 I=1,4
48000 DO 100 ILR=1,2
48001 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48002 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48003 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48004 100 CONTINUE
48005 110 CONTINUE
48006
48007 DO 130 I=5,6
48008 DO 120 ILR=1,2
48009 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48010 RM2=PMAS(I,1)**2/XM3**2
48011 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48012 IF(ARG.GE.0D0) THEN
48013 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48014 AX0=ABS(X0)
48015 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48016 AX1=ABS(X1)
48017 IF(X0.EQ.1D0) THEN
48018 AT=-1D0
48019 BT=0.25D0
48020 ELSEIF(X0.EQ.0D0) THEN
48021 AT=0D0
48022 BT=-0.25D0
48023 ELSE
48024 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48025 & 0.5D0*X0**2*LOG(AX0)
48026 BT=(-1D0-2D0*X0)/4D0
48027 ENDIF
48028 IF(X1.EQ.1D0) THEN
48029 AT=-1D0+AT
48030 BT=0.25D0+BT
48031 ELSEIF(X1.EQ.0D0) THEN
48032 AT=0D0+AT
48033 BT=-0.25D0+BT
48034 ELSE
48035 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48036 & X1**2*LOG(AX1)+AT
48037 BT=(-1D0-2D0*X1)/4D0+BT
48038 ENDIF
48039 AQ=AQ+AT+BT
48040 ELSE
48041 X0=0.5D0*(1D0+RM2-RM1)
48042 Y0=-0.5D0*SQRT(-ARG)
48043 AMGX0=SQRT(X0**2+Y0**2)
48044 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48045 ARGX0=ATAN2(-X0,-Y0)
48046 AR1X0=ATAN2(1D0-X0,Y0)
48047 X1=X0
48048 Y1=-Y0
48049 AMGX1=AMGX0
48050 AM1X1=AM1X0
48051 ARGX1=ATAN2(-X1,-Y1)
48052 AR1X1=ATAN2(1D0-X1,Y1)
48053 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48054 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48055 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48056 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48057 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48058 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48059 AQ=AQ+AT+BT
48060 ENDIF
48061 120 CONTINUE
48062 130 CONTINUE
48063 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48064 & /(2D0*PARU(2))*(15D0+AQ))
48065 ENDIF
48066
48067C...NEUTRALINO MASSES
48068 DO 150 I=1,4
48069 DO 140 J=1,4
48070 AI(I,J)=0D0
48071 140 CONTINUE
48072 150 CONTINUE
48073 XMZ=PMAS(23,1)/100D0
48074 XMW=PMAS(24,1)/100D0
48075 XMU=RMSS(4)/100D0
48076 SINW=SQRT(PARU(102))
48077 COSW=SQRT(1D0-PARU(102))
48078 TANB=RMSS(5)
48079 BETA=ATAN(TANB)
48080 COSB=COS(BETA)
48081 SINB=TANB*COSB
48082
48083 XM2=XM2/100D0
48084 XM1=XM1/100D0
48085
48086
48087C... Definitions:
48088C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48089C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48090 AR(1,1) = XM1*COS(RMSS(30))
48091 AI(1,1) = XM1*SIN(RMSS(30))
48092 AR(2,2) = XM2*COS(RMSS(31))
48093 AI(2,2) = XM2*SIN(RMSS(31))
48094 AR(3,3) = 0D0
48095 AR(4,4) = 0D0
48096 AR(1,2) = 0D0
48097 AR(2,1) = 0D0
48098 AR(1,3) = -XMZ*SINW*COSB
48099 AR(3,1) = AR(1,3)
48100 AR(1,4) = XMZ*SINW*SINB
48101 AR(4,1) = AR(1,4)
48102 AR(2,3) = XMZ*COSW*COSB
48103 AR(3,2) = AR(2,3)
48104 AR(2,4) = -XMZ*COSW*SINB
48105 AR(4,2) = AR(2,4)
48106 AR(3,4) = -XMU*COS(RMSS(33))
48107 AI(3,4) = -XMU*SIN(RMSS(33))
48108 AR(4,3) = -XMU*COS(RMSS(33))
48109 AI(4,3) = -XMU*SIN(RMSS(33))
48110C CALL PYEIG4(AR,WR,ZR)
48111 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48112 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48113 & 'PROBLEM WITH PYEICG IN PYINOM ')
48114 DO 160 I=1,4
48115 INDEX(I)=I
48116 XM(I)=ABS(WR(I))
48117 160 CONTINUE
48118 DO 180 I=2,4
48119 K=I
48120 DO 170 J=I-1,1,-1
48121 IF(XM(K).LT.XM(J)) THEN
48122 ITMP=INDEX(J)
48123 XTMP=XM(J)
48124 INDEX(J)=INDEX(K)
48125 XM(J)=XM(K)
48126 INDEX(K)=ITMP
48127 XM(K)=XTMP
48128 K=K-1
48129 ELSE
48130 GOTO 180
48131 ENDIF
48132 170 CONTINUE
48133 180 CONTINUE
48134
48135
48136 DO 210 I=1,4
48137 K=INDEX(I)
48138 SMZ(I)=WR(K)*100D0
48139 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48140 S=0D0
48141 DO 190 J=1,4
48142 S=S+ZR(J,K)**2+ZI(J,K)**2
48143 190 CONTINUE
48144 DO 200 J=1,4
48145 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48146 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48147 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48148 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48149 200 CONTINUE
48150 210 CONTINUE
48151
48152C...CHARGINO MASSES
48153C.....Find eigenvectors of X X^*
48154 DO I=1,4
48155 DO J=1,4
48156 AR(I,J)=0D0
48157 AI(I,J)=0D0
48158 ENDDO
48159 ENDDO
48160 AI(1,1) = 0D0
48161 AI(2,2) = 0D0
48162 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48163 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48164 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48165 &XMU*COS(RMSS(33))*SINB)
48166 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48167 &XMU*SIN(RMSS(33))*SINB)
48168 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48169 &XMU*COS(RMSS(33))*SINB)
48170 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48171 &XMU*SIN(RMSS(33))*SINB)
48172 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48173 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48174 & 'PROBLEM WITH PYEICG IN PYINOM ')
48175 INDEX(1)=1
48176 INDEX(2)=2
48177 IF(WR(2).LT.WR(1)) THEN
48178 INDEX(1)=2
48179 INDEX(2)=1
48180 ENDIF
48181
48182
48183 DO 240 I=1,2
48184 K=INDEX(I)
48185 SMW(I)=SQRT(WR(K))*100D0
48186 S=0D0
48187 DO 220 J=1,2
48188 S=S+ZR(J,K)**2+ZI(J,K)**2
48189 220 CONTINUE
48190 DO 230 J=1,2
48191 UMIX(I,J)=ZR(J,K)/SQRT(S)
48192 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48193 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48194 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48195 230 CONTINUE
48196 240 CONTINUE
48197C...Force chargino mass > neutralino mass
48198 IFRC=0
48199 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48200 CALL PYERRM(8,'(PYINOM:) '//
48201 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48202 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48203 IFRC=1
48204 ENDIF
48205 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48206 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48207
48208C.....Find eigenvectors of X^* X
48209 DO I=1,4
48210 DO J=1,4
48211 AR(I,J)=0D0
48212 AI(I,J)=0D0
48213 ZR(I,J)=0D0
48214 ZI(I,J)=0D0
48215 ENDDO
48216 ENDDO
48217 AI(1,1) = 0D0
48218 AI(2,2) = 0D0
48219 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48220 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48221 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48222 &XMU*COS(RMSS(33))*COSB)
48223 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48224 &XMU*SIN(RMSS(33))*COSB)
48225 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48226 &XMU*COS(RMSS(33))*COSB)
48227 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48228 &XMU*SIN(RMSS(33))*COSB)
48229 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48230 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48231 & 'PROBLEM WITH PYEICG IN PYINOM ')
48232 INDEX(1)=1
48233 INDEX(2)=2
48234 IF(WR(2).LT.WR(1)) THEN
48235 INDEX(1)=2
48236 INDEX(2)=1
48237 ENDIF
48238
48239 SIMAG=0D0
48240 DO 270 I=1,2
48241 K=INDEX(I)
48242 S=0D0
48243 DO 250 J=1,2
48244 S=S+ZR(J,K)**2+ZI(J,K)**2
48245 SIMAG=SIMAG+ZI(J,K)**2
48246 250 CONTINUE
48247 DO 260 J=1,2
48248 VMIX(I,J)=ZR(J,K)/SQRT(S)
48249 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48250 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48251 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48252 260 CONTINUE
48253 270 CONTINUE
48254
48255C.....Simplify if no phases
48256 IF(SIMAG.LT.1D-6) THEN
48257 AR(1,1) = XM2*COS(RMSS(31))
48258 AR(2,2) = XMU*COS(RMSS(33))
48259 AR(1,2) = SQRT(2D0)*XMW*SINB
48260 AR(2,1) = SQRT(2D0)*XMW*COSB
48261 IKNT=0
48262 300 CONTINUE
48263 DO I=1,2
48264 DO J=1,2
48265 ZR(I,J)=0D0
48266 ENDDO
48267 ENDDO
48268
48269 DO I=1,2
48270 DO J=1,2
48271 DO K=1,2
48272 DO L=1,2
48273 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48274 ENDDO
48275 ENDDO
48276 ENDDO
48277 ENDDO
48278 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48279 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48280 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48281 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48282 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48283 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48284 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48285 IKNT=IKNT+1
48286 GOTO 300
48287 ENDIF
48288C.....Must deal with phases
48289 ELSE
48290 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48291 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48292 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48293 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48294
48295 IKNT=0
48296 310 CONTINUE
48297 DO I=1,2
48298 DO J=1,2
48299 CAI(I,J)=CMPLX(0D0,0D0)
48300 ENDDO
48301 ENDDO
48302
48303 DO I=1,2
48304 DO J=1,2
48305 DO K=1,2
48306 DO L=1,2
48307 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48308 & CMPLX(VMIX(J,L),VMIXI(J,L))
48309 ENDDO
48310 ENDDO
48311 ENDDO
48312 ENDDO
48313
48314 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48315 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48316 TEMPR=VMIX(1,1)
48317 TEMPI=VMIXI(1,1)
48318 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48319 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48320 TEMPR=VMIX(1,2)
48321 TEMPI=VMIXI(1,2)
48322 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48323 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48324 TEMPR=VMIX(2,1)
48325 TEMPI=VMIXI(2,1)
48326 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48327 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48328 TEMPR=VMIX(2,2)
48329 TEMPI=VMIXI(2,2)
48330 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48331 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48332 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48333 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48334 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48335 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48336 IKNT=IKNT+1
48337 GOTO 310
48338 ENDIF
48339 ENDIF
48340 RETURN
48341 END
48342
48343C*********************************************************************
48344
48345C...PYRNM3
48346C...Calculates the running of M3, the SU(3) gluino mass parameter.
48347
48348 FUNCTION PYRNM3(RGUT)
48349
48350C...Double precision and integer declarations.
48351 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48352 IMPLICIT INTEGER(I-N)
48353 INTEGER PYK,PYCHGE,PYCOMP
48354
48355C...Local variables.
48356 DOUBLE PRECISION R
48357 DOUBLE PRECISION TOL
48358 EXTERNAL PYALPS
48359 DOUBLE PRECISION PYALPS
48360 DATA TOL/0.001D0/
48361 DATA R/0.61803399D0/
48362
48363 C=1D0-R
48364
48365 BX=RGUT*PYALPS(RGUT**2)
48366 AX=MIN(50D0,BX*0.5D0)
48367 CX=MAX(2000D0,2D0*BX)
48368
48369 X0=AX
48370 X3=CX
48371 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48372 X1=BX
48373 X2=BX+C*(CX-BX)
48374 ELSE
48375 X2=BX
48376 X1=BX-C*(BX-AX)
48377 ENDIF
48378 AS1=PYALPS(X1**2)
48379 F1=ABS(X1-RGUT*AS1)
48380 AS2=PYALPS(X2**2)
48381 F2=ABS(X2-RGUT*AS2)
48382 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48383 IF(F2.LT.F1) THEN
48384 X0=X1
48385 X1=X2
48386 X2=R*X1+C*X3
48387 F1=F2
48388 AS2=PYALPS(X2**2)
48389 F2=ABS(X2-RGUT*AS2)
48390 ELSE
48391 X3=X2
48392 X2=X1
48393 X1=R*X2+C*X0
48394 F2=F1
48395 AS1=PYALPS(X1**2)
48396 F1=ABS(X1-RGUT*AS1)
48397 ENDIF
48398 GOTO 100
48399 ENDIF
48400 IF(F1.LT.F2) THEN
48401 PYRNM3=X1
48402 XMIN=X1
48403 ELSE
48404 PYRNM3=X2
48405 XMIN=X2
48406 ENDIF
48407
48408 RETURN
48409 END
48410
48411C*********************************************************************
48412
48413C...PYEIG4
48414C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48415C...Specific application: mixing in neutralino sector.
48416
48417 SUBROUTINE PYEIG4(A,W,Z)
48418
48419C...Double precision and integer declarations.
48420 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48421 IMPLICIT INTEGER(I-N)
48422 INTEGER PYK,PYCHGE,PYCOMP
48423
48424C...Arrays: in call and local.
48425 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48426
48427C...Coefficients of fourth-degree equation from matrix.
48428C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48429 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48430 B2=0D0
48431 DO 110 I=1,3
48432 DO 100 J=I+1,4
48433 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48434 100 CONTINUE
48435 110 CONTINUE
48436 B1=0D0
48437 B0=0D0
48438 DO 120 I=1,4
48439 I1=MOD(I,4)+1
48440 I2=MOD(I+1,4)+1
48441 I3=MOD(I+2,4)+1
48442 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48443 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48444 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48445 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48446 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48447 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48448 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48449 120 CONTINUE
48450
48451C...Coefficients of third-degree equation needed for
48452C...separation into two second-degree equations.
48453C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48454 C2=-B2
48455 C1=B1*B3-4D0*B0
48456 C0=-B1**2-B0*B3**2+4D0*B0*B2
48457 CQ=C1/3D0-C2**2/9D0
48458 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48459 CQR=CQ**3+CR**2
48460
48461C...Cases with one or three real roots.
48462 IF(CQR.GE.0D0) THEN
48463 S1=(CR+SQRT(CQR))**(1D0/3D0)
48464 S2=(CR-SQRT(CQR))**(1D0/3D0)
48465 U=S1+S2-C2/3D0
48466 ELSE
48467 SABS=SQRT(-CQ)
48468 THE=ACOS(CR/SABS**3)/3D0
48469 SRE=SABS*COS(THE)
48470 U=2D0*SRE-C2/3D0
48471 ENDIF
48472
48473C...Find and solve two second-degree equations.
48474 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48475 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48476 Q1=U/2D0+SQRT(U**2/4D0-B0)
48477 Q2=U/2D0-SQRT(U**2/4D0-B0)
48478 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48479 QSAV=Q1
48480 Q1=Q2
48481 Q2=QSAV
48482 ENDIF
48483 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48484 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48485 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48486 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48487
48488C...Order eigenvalues in asceding mass.
48489 W(1)=X(1)
48490 DO 150 I1=2,4
48491 DO 130 I2=I1-1,1,-1
48492 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48493 W(I2+1)=W(I2)
48494 130 CONTINUE
48495 140 W(I2+1)=X(I1)
48496 150 CONTINUE
48497
48498C...Find equation system for eigenvectors.
48499 DO 250 I=1,4
48500 DO 170 J1=1,4
48501 D(J1,J1)=A(J1,J1)-W(I)
48502 DO 160 J2=J1+1,4
48503 D(J1,J2)=A(J1,J2)
48504 D(J2,J1)=A(J2,J1)
48505 160 CONTINUE
48506 170 CONTINUE
48507
48508C...Find largest element in matrix.
48509 DAMAX=0D0
48510 DO 190 J1=1,4
48511 DO 180 J2=1,4
48512 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48513 JA=J1
48514 JB=J2
48515 DAMAX=ABS(D(J1,J2))
48516 180 CONTINUE
48517 190 CONTINUE
48518
48519C...Subtract others by multiple of row selected above.
48520 DAMAX=0D0
48521 DO 210 J3=JA+1,JA+3
48522 J1=J3-4*((J3-1)/4)
48523 RL=D(J1,JB)/D(JA,JB)
48524 DO 200 J2=1,4
48525 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48526 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48527 JC=J1
48528 JD=J2
48529 DAMAX=ABS(D(J1,J2))
48530 200 CONTINUE
48531 210 CONTINUE
48532
48533C...Do one more subtraction of a row.
48534 DAMAX=0D0
48535 DO 230 J3=JC+1,JC+3
48536 J1=J3-4*((J3-1)/4)
48537 IF(J1.EQ.JA) GOTO 230
48538 RL=D(J1,JD)/D(JC,JD)
48539 DO 220 J2=1,4
48540 IF(J2.EQ.JB) GOTO 220
48541 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48542 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48543 JE=J1
48544 DAMAX=ABS(D(J1,J2))
48545 220 CONTINUE
48546 230 CONTINUE
48547
48548C...Construct unnormalized eigenvector.
48549 JF1=JD+1-4*(JD/4)
48550 JF2=JD+2-4*((JD+1)/4)
48551 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48552 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48553 E(JF1)=-D(JE,JF2)
48554 E(JF2)=D(JE,JF1)
48555 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48556 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48557 & D(JA,JB)
48558
48559C...Normalize and fill in final array.
48560 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48561 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48562 DO 240 J=1,4
48563 Z(I,J)=SGN*E(J)/EA
48564 240 CONTINUE
48565 250 CONTINUE
48566
48567 RETURN
48568 END
48569
48570C*********************************************************************
48571
48572C...PYHGGM
48573C...Determines the Higgs boson mass spectrum using several inputs.
48574
48575 SUBROUTINE PYHGGM(ALPHA)
48576
48577C...Double precision and integer declarations.
48578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48579 IMPLICIT INTEGER(I-N)
48580 INTEGER PYK,PYCHGE,PYCOMP
48581C...Parameter statement to help give large particle numbers.
48582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48583 &KEXCIT=4000000,KDIMEN=5000000)
48584C...Commonblocks.
48585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48587 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48588 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48589 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48590
48591C...Local variables.
48592 DOUBLE PRECISION AT,AB,XMU,TANB
48593 DOUBLE PRECISION ALPHA
48594 INTEGER IHOPT
48595 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48596 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48597 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48598 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48599
48600 IHOPT=IMSS(4)
48601 IF(IHOPT.EQ.2) THEN
48602 ALPHA=RMSS(18)
48603 RETURN
48604 ENDIF
48605 AT=RMSS(16)
48606 AB=RMSS(15)
48607 DMGL=RMSS(3)
48608 XMU=RMSS(4)
48609 TANB=RMSS(5)
48610
48611 DMA=RMSS(19)
48612 DTANB=TANB
48613 DMQ=RMSS(10)
48614 DMUR=RMSS(12)
48615 DMDR=RMSS(11)
48616 DMTOP=PMAS(6,1)
48617 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48618 DAU=AT
48619 DAD=AB
48620 DMU=XMU
48621 RMSS(40)=0D0
48622 RMSS(41)=0D0
48623
48624 IF(IHOPT.EQ.0) THEN
48625 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48626 & DMHCH,DSA,DCA,DTANBA)
48627 ELSEIF(IHOPT.EQ.1) THEN
48628 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48629 & DMHCH,DSA,DCA,DTANBA)
48630 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48631 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48632 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48633 RMSS(40)=DDT
48634 RMSS(41)=DDB
48635 DMH=DMHP
48636 DHM=DHMP
48637 DMA=DAMP
48638 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48639 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48640 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48641 & PMAS(PYCOMP(1000006),1),DSTOP2
48642 ENDIF
48643 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48644 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48645 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48646 & PMAS(PYCOMP(2000006),1),DSTOP1
48647 ENDIF
48648 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48649 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48650 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48651 & PMAS(PYCOMP(1000005),1),DSBOT2
48652 ENDIF
48653 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48654 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48655 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48656 & PMAS(PYCOMP(2000005),1),DSBOT1
48657 ENDIF
48658
48659 ELSEIF (IHOPT.EQ.3) THEN
48660c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48661C...Currently only available for SLHA spectrum read-in.
48662 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48663 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48664 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48665 ENDIF
48666 ALPHA=RMSS(18)
48667 RETURN
48668 ENDIF
48669
48670 ALPHA=ACOS(DCA)
48671
48672 PMAS(25,1)=DMH
48673 PMAS(35,1)=DHM
48674 PMAS(36,1)=DMA
48675 PMAS(37,1)=DMHCH
48676
48677 RETURN
48678 END
48679
48680C*********************************************************************
48681
48682C...PYSUBH
48683C...This routine computes the renormalization group improved
48684C...values of Higgs masses and couplings in the MSSM.
48685
48686C...Program based on the work by M. Carena, J.R. Espinosa,
48687c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48688
48689C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48690C...All masses in GeV units. MA is the CP-odd Higgs mass,
48691C...MTOP is the physical top mass, MQ and MUR are the soft
48692C...supersymmetry breaking mass parameters of left handed
48693C...and right handed stops respectively, AU and AD are the
48694C...stop and sbottom trilinear soft breaking terms,
48695C...respectively, and MU is the supersymmetric
48696C...Higgs mass parameter. We use the conventions from
48697C...the physics report of Haber and Kane: left right
48698C...stop mixing term proportional to (AU - MU/TANB)
48699C...We use as input TANB defined at the scale MTOP
48700
48701C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48702C...where MH and HM are the lightest and heaviest CP-even
48703C...Higgs masses, MHCH is the charged Higgs mass and
48704C...ALPHA is the Higgs mixing angle
48705C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48706
48707C...Range of validity:
48708C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48709C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48710C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48711C...are the sbottom mass eigenvalues, respectively. This
48712C...range automatically excludes the existence of tachyons.
48713C...For the charged Higgs mass computation, the method is
48714C...valid if
48715C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48716C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48717C...where M_SUSY**2 is the average of the squared stop mass
48718C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48719C...masses have been assumed to be of order of the stop ones
48720C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48721
48722 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48723 &XMHCH,SA,CA,TANBA)
48724
48725C...Double precision and integer declarations.
48726 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48727 IMPLICIT INTEGER(I-N)
48728 INTEGER PYK,PYCHGE,PYCOMP
48729C...Parameter statement to help give large particle numbers.
48730 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48731 &KEXCIT=4000000,KDIMEN=5000000)
48732C...Commonblocks.
48733 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48734 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48735 COMMON/PYHTRI/HHH(7)
48736 SAVE /PYDAT1/,/PYDAT2/
48737
48738C...Local variables.
48739 DOUBLE PRECISION PYALEM,PYALPS
48740 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48741 DOUBLE PRECISION XMHCH,SA,CA
48742 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48743 DOUBLE PRECISION Q02
48744 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48745 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48746 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48747 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48748 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48749 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48750 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48751 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48752
48753 XMZ = PMAS(23,1)
48754 Q02=XMZ**2
48755 AEM=PYALEM(Q02)
48756 ALP1=AEM/(1D0-PARU(102))
48757 ALP2=AEM/PARU(102)
48758 ALPH3Z=PYALPS(Q02)
48759
48760 ALP1 = 0.0101D0
48761 ALP2 = 0.0337D0
48762 ALPH3Z = 0.12D0
48763
48764 V = 174.1D0
48765 PI = PARU(1)
48766 TANBA = TANB
48767 TANBT = TANB
48768
48769C...MBOTTOM(MTOP) = 3. GEV
48770 XMB = PYMRUN(5,XMTOP**2)
48771 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48772 &LOG(XMTOP**2/XMZ**2))
48773
48774C...RMTOP= RUNNING TOP QUARK MASS
48775 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48776 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48777 T = LOG(XMS**2/XMTOP**2)
48778 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48779 COSB = SINB/TANB
48780C...IF(MA.LE.XMTOP) TANBA = TANBT
48781 IF(XMA.GT.XMTOP)
48782 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48783 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48784 &LOG(XMA**2/XMTOP**2))
48785
48786 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48787 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48788C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48789 G1 = SQRT(ALP1*4D0*PI)
48790 G2 = SQRT(ALP2*4D0*PI)
48791 G3 = SQRT(ALP3*4D0*PI)
48792 HU = RMTOP/V/SINBT
48793 HD = XMB/V/COSBT
48794 HU2=HU*HU
48795 HD2=HD*HD
48796 HU4=HU2*HU2
48797 HD4=HD2*HD2
48798 AU2=AU**2
48799 AD2=AD**2
48800 XMS2=XMS**2
48801 XMS3=XMS**3
48802 XMS4=XMS2*XMS2
48803 XMU2=XMU*XMU
48804 PI2=PI*PI
48805
48806 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48807 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48808 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48809 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48810 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48811 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48812 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48813 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48814 &- 16D0*G3**2) *T/16D0/PI2)
48815 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48816 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48817 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48818 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48819 &- 16D0*G3**2) *T/16D0/PI2)
48820 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48821 &(HU2 + HD2)*T/16D0/PI2)
48822 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48823 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48824 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48825 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48826 &- 16D0*G3**2) *T/16D0/PI2)
48827 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48828 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48829 &- 16D0*G3**2) *T/16D0/PI2)
48830 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48831 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48832 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48833 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48834 &XMS4)*
48835 &(1+ (6D0*HU2 -2D0* HD2
48836 &- 16D0*G3**2) *T/16D0/PI2)
48837 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48838 &XMS4)*
48839 &(1+ (6D0*HD2 -2D0* HU2/2D0
48840 &- 16D0*G3**2) *T/16D0/PI2)
48841 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48842 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48843 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48844 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48845 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48846 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48847 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48848 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48849 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48850 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48851 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48852 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48853 HHH(1)=XLAM1
48854 HHH(2)=XLAM2
48855 HHH(3)=XLAM3
48856 HHH(4)=XLAM4
48857 HHH(5)=XLAM5
48858 HHH(6)=XLAM6
48859 HHH(7)=XLAM7
48860 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48861 &2D0* XLAM6*SINBT*COSBT
48862 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48863 &+ XLAM5*COSBT**2)
48864 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48865 &XLAM6*COSBT**2
48866 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48867 &2D0* XLAM6* COSBT*SINBT
48868 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48869 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48870 &((XLAM1* COSBT**2 +2D0*
48871 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48872 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48873 &*SINBT**2
48874 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48875 &+ XLAM4) + XLAM6*COSBT**2
48876 &+ XLAM7* SINBT**2))
48877
48878 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48879 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48880 XHM = SQRT(XHM2)
48881 XMH = SQRT(XMH2)
48882 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48883 XMHCH = SQRT(XMHCH2)
48884
48885 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48886 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48887 &XLAM6* COSBT*SINBT
48888 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48889 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48890 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48891 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48892
48893 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48894 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48895 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48896 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48897 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48898 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48899 &XLAM6* COSBT*SINBT
48900 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48901 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48902 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48903
48904 SA = -SINALP
48905 CA = -COSALP
48906
48907 100 CONTINUE
48908
48909 RETURN
48910 END
48911
48912C*********************************************************************
48913
48914C...PYPOLE
48915C...This subroutine computes the CP-even higgs and CP-odd pole
48916c...Higgs masses and mixing angles.
48917
48918C...Program based on the work by M. Carena, M. Quiros
48919C...and C.E.M. Wagner, "Effective potential methods and
48920C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48921
48922C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48923C...AT,AB,MU
48924C...where MCHI is the largest chargino mass, MA is the running
48925C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48926C...expectaion values at the scale MTOP, MQ is the third generation
48927C...left handed squark mass parameter, MUR is the third generation
48928C...right handed stop mass parameter, MDR is the third generation
48929C...right handed sbottom mass parameter, MTOP is the pole top quark
48930C...mass; AT,AB are the soft supersymmetry breaking trilinear
48931C...couplings of the stop and sbottoms, respectively, and MU is the
48932C...supersymmetric mass parameter
48933
48934C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48935C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48936C...masses are given, what makes the running of the program
48937c...much faster and it is quite generally a good approximation
48938c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48939C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48940c...and if IHIGGS=3, then h,H,A polarizations are computed
48941
48942C...Output: MH and MHP which are the lightest CP-even Higgs running
48943C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48944C...Higgs running and pole masses, repectively; SA and CA are the
48945C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48946C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48947C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48948C...the value of TANB at the CP-odd Higgs mass scale
48949
48950C...This subroutine makes use of CERN library subroutine
48951C...integration package, which makes the computation of the
48952C...pole Higgs masses somewhat faster. We thank P. Janot for this
48953C...improvement. Those who are not able to call the CERN
48954C...libraries, please use the subroutine SUBHPOLE2.F, which
48955C...although somewhat slower, gives identical results
48956
48957 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48958 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48959
48960C...Double precision and integer declarations.
48961 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48962 IMPLICIT INTEGER(I-N)
48963
48964C...Parameters.
48965 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48966 SAVE /PYDAT1/
48967 INTEGER PYK,PYCHGE,PYCOMP
48968
48969C...Local variables.
48970 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48971 &SSBOT2(2),B(2,2),COUPB(2,2),
48972 &HCOUPT(2,2),HCOUPB(2,2),
48973 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48974
48975 DELTA(1,1) = 1D0
48976 DELTA(2,2) = 1D0
48977 DELTA(1,2) = 0D0
48978 DELTA(2,1) = 0D0
48979 V = 174.1D0
48980 XMZ=91.18D0
48981 PI=PARU(1)
48982 RXMT=PYMRUN(6,XMT**2)
48983 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48984 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48985
48986 SINB = TANB/(TANB**2+1D0)**0.5D0
48987 COSB = 1D0/(TANB**2+1D0)**0.5D0
48988 COS2B = SINB**2 - COSB**2
48989 SINBPA = SINB*CA + COSB*SA
48990 COSBPA = COSB*CA - SINB*SA
48991 RMBOT = PYMRUN(5,XMT**2)
48992 XMQ2 = XMQ**2
48993 XMUR2 = XMUR**2
48994 IF(XMUR.LT.0D0) XMUR2=-XMUR2
48995 XMDR2 = XMDR**2
48996 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
48997 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
48998 IF(XMST11.LT.0D0) GOTO 500
48999 IF(XMST22.LT.0D0) GOTO 500
49000 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49001 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49002 IF(XMSB11.LT.0D0) GOTO 500
49003 IF(XMSB22.LT.0D0) GOTO 500
49004C WMST11 = RXMT**2 + XMQ2
49005C WMST22 = RXMT**2 + XMUR2
49006 XMST12 = RXMT*(AT - XMU/TANB)
49007 XMSB12 = RMBOT*(AB - XMU*TANB)
49008
49009CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49010C...STOP EIGENVALUES CALCULATION
49011CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49012
49013 STOP12 = 0.5D0*(XMST11+XMST22) +
49014 &0.5D0*((XMST11+XMST22)**2 -
49015 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49016 STOP22 = 0.5D0*(XMST11+XMST22) -
49017 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49018 &XMST12**2))**0.5D0
49019
49020 IF(STOP22.LT.0D0) GOTO 500
49021 SSTOP2(1) = STOP12
49022 SSTOP2(2) = STOP22
49023 STOP1 = STOP12**0.5D0
49024 STOP2 = STOP22**0.5D0
49025C STOP1W = STOP1
49026C STOP2W = STOP2
49027
49028 IF(XMST12.EQ.0D0) XST11 = 1D0
49029 IF(XMST12.EQ.0D0) XST12 = 0D0
49030 IF(XMST12.EQ.0D0) XST21 = 0D0
49031 IF(XMST12.EQ.0D0) XST22 = 1D0
49032
49033 IF(XMST12.EQ.0D0) GOTO 110
49034
49035 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49036 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49037 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49038 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49039
49040 110 T(1,1) = XST11
49041 T(2,2) = XST22
49042 T(1,2) = XST12
49043 T(2,1) = XST21
49044
49045 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49046 &0.5D0*((XMSB11+XMSB22)**2 -
49047 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49048 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49049 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49050 &XMSB12**2))**0.5D0
49051 IF(SBOT22.LT.0D0) GOTO 500
49052 SBOT1 = SBOT12**0.5D0
49053 SBOT2 = SBOT22**0.5D0
49054
49055 SSBOT2(1) = SBOT12
49056 SSBOT2(2) = SBOT22
49057
49058 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49059 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49060 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49061 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49062
49063 IF(XMSB12.EQ.0D0) GOTO 130
49064
49065 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49066 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49067 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49068 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49069
49070 130 B(1,1) = XSB11
49071 B(2,2) = XSB22
49072 B(1,2) = XSB12
49073 B(2,1) = XSB21
49074
49075
49076 SINT = 0.2320D0
49077 SQR = DSQRT(2D0)
49078 VP = 174.1D0*SQR
49079
49080CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49081C...STARTING OF LIGHT HIGGS
49082CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49083
49084 IF(IHIGGS.EQ.0) GOTO 490
49085
49086 DO 150 I = 1,2
49087 DO 140 J = 1,2
49088 COUPT(I,J) =
49089 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49090 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49091 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49092 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49093 & T(1,J)*T(2,I))
49094 140 CONTINUE
49095 150 CONTINUE
49096
49097
49098 DO 170 I = 1,2
49099 DO 160 J = 1,2
49100 COUPB(I,J) =
49101 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49102 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49103 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49104 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49105 & B(1,J)*B(2,I))
49106 160 CONTINUE
49107 170 CONTINUE
49108
49109 PRUN = XMH
49110 EPS = 1D-4*PRUN
49111 ITER = 0
49112 180 ITER = ITER + 1
49113 DO 230 I3 = 1,3
49114
49115 PR(I3)=PRUN+(I3-2)*EPS/2
49116 P2=PR(I3)**2
49117 POLT = 0D0
49118 DO 200 I = 1,2
49119 DO 190 J = 1,2
49120 POLT = POLT + COUPT(I,J)**2*3D0*
49121 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49122 190 CONTINUE
49123 200 CONTINUE
49124
49125 POLB = 0D0
49126 DO 220 I = 1,2
49127 DO 210 J = 1,2
49128 POLB = POLB + COUPB(I,J)**2*3D0*
49129 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49130 210 CONTINUE
49131 220 CONTINUE
49132C RXMT2 = RXMT**2
49133 XMT2=XMT**2
49134
49135 POLTT =
49136 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49137 & CA**2/SINB**2 *
49138 & (-2D0*XMT**2+0.5D0*P2)*
49139 & PYFINT(P2,XMT2,XMT2)
49140
49141 POL = POLT + POLB + POLTT
49142 POLAR(I3) = P2 - XMH**2 - POL
49143 230 CONTINUE
49144 DERIV = (POLAR(3)-POLAR(1))/EPS
49145 DRUN = - POLAR(2)/DERIV
49146 PRUN = PRUN + DRUN
49147 P2 = PRUN**2
49148 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49149 GOTO 180
49150 240 CONTINUE
49151
49152 XMHP = DSQRT(P2)
49153
49154CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49155C...END OF LIGHT HIGGS
49156CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49157
49158 250 IF(IHIGGS.EQ.1) GOTO 490
49159
49160CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49161C... STARTING OF HEAVY HIGGS
49162CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49163
49164 DO 270 I = 1,2
49165 DO 260 J = 1,2
49166 HCOUPT(I,J) =
49167 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49168 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49169 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49170 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49171 & T(1,J)*T(2,I))
49172 260 CONTINUE
49173 270 CONTINUE
49174
49175 DO 290 I = 1,2
49176 DO 280 J = 1,2
49177 HCOUPB(I,J) =
49178 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49179 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49180 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49181 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49182 & B(1,J)*B(2,I))
49183 HCOUPB(I,J)=0D0
49184 280 CONTINUE
49185 290 CONTINUE
49186
49187 PRUN = HM
49188 EPS = 1D-4*PRUN
49189 ITER = 0
49190 300 ITER = ITER + 1
49191 DO 350 I3 = 1,3
49192 PR(I3)=PRUN+(I3-2)*EPS/2
49193 HP2=PR(I3)**2
49194
49195 HPOLT = 0D0
49196 DO 320 I = 1,2
49197 DO 310 J = 1,2
49198 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49199 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49200 310 CONTINUE
49201 320 CONTINUE
49202
49203 HPOLB = 0D0
49204 DO 340 I = 1,2
49205 DO 330 J = 1,2
49206 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49207 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49208 330 CONTINUE
49209 340 CONTINUE
49210
49211C RXMT2 = RXMT**2
49212 XMT2 = XMT**2
49213
49214 HPOLTT =
49215 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49216 & SA**2/SINB**2 *
49217 & (-2D0*XMT**2+0.5D0*HP2)*
49218 & PYFINT(HP2,XMT2,XMT2)
49219
49220 HPOL = HPOLT + HPOLB + HPOLTT
49221 POLAR(I3) =HP2-HM**2-HPOL
49222 350 CONTINUE
49223 DERIV = (POLAR(3)-POLAR(1))/EPS
49224 DRUN = - POLAR(2)/DERIV
49225 PRUN = PRUN + DRUN
49226 HP2 = PRUN**2
49227 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49228 GOTO 300
49229 360 CONTINUE
49230
49231
49232 370 CONTINUE
49233 HMP = HP2**0.5D0
49234
49235CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49236C... END OF HEAVY HIGGS
49237CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49238
49239 IF(IHIGGS.EQ.2) GOTO 490
49240
49241CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49242C...BEGINNING OF PSEUDOSCALAR HIGGS
49243CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49244
49245 DO 390 I = 1,2
49246 DO 380 J = 1,2
49247 ACOUPT(I,J) =
49248 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49249 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49250 380 CONTINUE
49251 390 CONTINUE
49252 DO 410 I = 1,2
49253 DO 400 J = 1,2
49254 ACOUPB(I,J) =
49255 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49256 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49257 400 CONTINUE
49258 410 CONTINUE
49259
49260 PRUN = XMA
49261 EPS = 1D-4*PRUN
49262 ITER = 0
49263 420 ITER = ITER + 1
49264 DO 470 I3 = 1,3
49265 PR(I3)=PRUN+(I3-2)*EPS/2
49266 AP2=PR(I3)**2
49267 APOLT = 0D0
49268 DO 440 I = 1,2
49269 DO 430 J = 1,2
49270 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49271 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49272 430 CONTINUE
49273 440 CONTINUE
49274 APOLB = 0D0
49275 DO 460 I = 1,2
49276 DO 450 J = 1,2
49277 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49278 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49279 450 CONTINUE
49280 460 CONTINUE
49281C RXMT2 = RXMT**2
49282 XMT2=XMT**2
49283 APOLTT =
49284 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49285 & COSB**2/SINB**2 *
49286 & (-0.5D0*AP2)*
49287 & PYFINT(AP2,XMT2,XMT2)
49288 APOL = APOLT + APOLB + APOLTT
49289 POLAR(I3) = AP2 - XMA**2 -APOL
49290 470 CONTINUE
49291 DERIV = (POLAR(3)-POLAR(1))/EPS
49292 DRUN = - POLAR(2)/DERIV
49293 PRUN = PRUN + DRUN
49294 AP2 = PRUN**2
49295 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49296 GOTO 420
49297 480 CONTINUE
49298
49299 AMP = DSQRT(AP2)
49300
49301CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49302C...END OF PSEUDOSCALAR HIGGS
49303CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49304
49305 IF(IHIGGS.EQ.3) GOTO 490
49306
49307 490 CONTINUE
49308 RETURN
49309 500 CONTINUE
49310 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49311 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49312 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49313 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49314 CALL PYSTOP(107)
49315 END
49316
49317C*********************************************************************
49318
49319C...PYRGHM
49320C...Auxiliary to PYPOLE.
49321
49322 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49323 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49324 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49325 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49326C...Parameters.
49327 INTEGER MSTU,MSTJ
49328 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49329 SAVE /PYDAT1/
49330
49331 MZ = 91.18D0
49332 PI = PARU(1)
49333 V = 174.1D0
49334 ALPHA1 = 0.0101D0
49335 ALPHA2 = 0.0337D0
49336 ALPHA3Z = 0.12D0
49337 TANBA = TANB
49338 TANBT = TANB
49339C MBOTTOM(MTOP) = 3. GEV
49340 MB = PYMRUN(5,MTOP**2)
49341 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49342 *LOG(MTOP**2/MZ**2))
49343C RMTOP= RUNNING TOP QUARK MASS
49344 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49345 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49346 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49347 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49348CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49349C
49350C NEW DEFINITION, TGLU.
49351C
49352CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49353 TGLU = LOG(MGLU**2/MTOP**2)
49354 SINB = TANB/DSQRT(1D0 + TANB**2)
49355 COSB = SINB/TANB
49356 IF(MA.GT.MTOP)
49357 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49358 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49359 *LOG(MA**2/MTOP**2))
49360 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49361 SINB = TANBT/SQRT(1D0 + TANBT**2)
49362 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49363 G1 = SQRT(ALPHA1*4D0*PI)
49364 G2 = SQRT(ALPHA2*4D0*PI)
49365 G3 = SQRT(ALPHA3*4D0*PI)
49366 HU = RMTOP/V/SINB
49367 HD = MB/V/COSB
49368 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49369 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49370 IF(MQ.GT.MUR) TP = TQ - TU
49371 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49372 IF(MQ.GT.MUR) TDP = TU
49373 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49374 IF(MQ.GT.MD) TPD = TQ - TD
49375 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49376 IF(MQ.GT.MD) TDPD = TD
49377 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49378
49379 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49380 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49381 * HD**2*(G1**2/3D0+G2**2)*TPD
49382
49383 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49384 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49385 * HU**2*(-G1**2/3D0+G2**2)*TP
49386
49387CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49388C
49389C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49390C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49391C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49392C TWO STOPS.
49393C
49394C
49395CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49396
49397 DLAMBDAP2 = 0D0
49398 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49399 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49400 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49401 ENDIF
49402
49403 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49404 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49405 ENDIF
49406
49407 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49408 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49409 ENDIF
49410
49411 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49412 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49413 ENDIF
49414
49415 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49416 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49417 ENDIF
49418
49419 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49420 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49421 ENDIF
49422 ENDIF
49423 DLAMBDA3 = 0D0
49424 DLAMBDA4 = 0D0
49425 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49426 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49427 *(G2**2-G1**2/3D0)*TPD
49428 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49429 *1D0/16D0/PI**2*G1**2*HU**2*TP
49430 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49431 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49432 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49433 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49434 *HD**2*TPD
49435 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49436 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49437 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49438 *+ (3D0*HD**2/2D0 + HU**2/2D0
49439 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49440 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49441 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49442 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49443 *(TP + TDP)/8D0/PI**2)
49444 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49445 *+ (3D0*HU**2/2D0 + HD**2/2D0
49446 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49447 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49448 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49449 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49450 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49451 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49452 LAMBDA4 = (- G2**2/2D0)*(1D0
49453 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49454 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49455
49456 LAMBDA5 = 0D0
49457 LAMBDA6 = 0D0
49458 LAMBDA7 = 0D0
49459
49460 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49461 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49462
49463 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49464 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49465 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49466 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49467
49468 M2(2,1) = M2(1,2)
49469CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49470CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49471CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49472
49473 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49474
49475 IF(MCHI.GT.MSSUSY) GOTO 100
49476 IF(MCHI.LT.MTOP) MCHI=MTOP
49477
49478 TCHAR=LOG(MSSUSY**2/MCHI**2)
49479
49480 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49481 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49482 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49483
49484 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49485 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49486 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49487
49488 M2(1,1)=M2(1,1)+DELTAM112
49489 M2(2,2)=M2(2,2)+DELTAM222
49490 M2(1,2)=M2(1,2)+DELTAM122
49491 M2(2,1)=M2(2,1)+DELTAM122
49492
49493 100 CONTINUE
49494
49495CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49496CCC END OF CHARGINOS/NEUTRALINOS
49497CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49498
49499 DO 120 I = 1,2
49500 DO 110 J = 1,2
49501 M2P(I,J) = M2(I,J) + VH(I,J)
49502 110 CONTINUE
49503 120 CONTINUE
49504 TRM2P = M2P(1,1) + M2P(2,2)
49505 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49506 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49507 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49508 HMP = DSQRT(HM2P)
49509 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49510 MCH=DSQRT(MCH2)
49511 IF(MH2P.LT.0.) GOTO 130
49512 MHP = SQRT(MH2P)
49513 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49514 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49515 IF(COS2ALPHA.GE.0.) THEN
49516 ALPHA = ASIN(SIN2ALPHA)/2D0
49517 ELSE
49518 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49519 ENDIF
49520 SA = SIN(ALPHA)
49521 CA = COS(ALPHA)
49522CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49523C
49524C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49525C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49526C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49527C
49528C
49529CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49530 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49531 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49532 130 CONTINUE
49533 RETURN
49534 END
49535
49536C*********************************************************************
49537
49538C...PYGFXX
49539C...Auxiliary to PYRGHM.
49540
49541 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49542 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49543 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49544 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49545C...Commonblocks.
49546 INTEGER MSTU,MSTJ,KCHG
49547 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49548 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49549 SAVE /PYDAT1/,/PYDAT2/
49550
49551 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49552
49553 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49554 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49555
49556 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49557 MQ2 = MQ**2
49558 MUR2 = MUR**2
49559 MD2 = MD**2
49560 TANBA = TANB
49561 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49562 COSBA = SINBA/TANBA
49563
49564 SINB = TANB/DSQRT(TANB**2+1D0)
49565 COSB = SINB/TANB
49566
49567 PI = PARU(1)
49568 MZ = PMAS(23,1)
49569 MW = PMAS(24,1)
49570 SW = 1D0-MW**2/MZ**2
49571 V = 174.1D0
49572
49573 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49574 G2 = DSQRT(0.0336D0*4D0*PI)
49575 G1 = DSQRT(0.0101D0*4D0*PI)
49576
49577 IF(MQ.GT.MUR) MST = MQ
49578 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49579
49580 MSUSYT = DSQRT(MST**2 + MTOP**2)
49581
49582 IF(MQ.GT.MD) MSB = MQ
49583 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49584
49585 MB = PYMRUN(5,MSB**2)
49586 MSUSYB = DSQRT(MSB**2 + MB**2)
49587 TT = LOG(MSUSYT**2/MTOP**2)
49588 TB = LOG(MSUSYB**2/MTOP**2)
49589
49590 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49591 HT = RMTOP/(V*SINB)
49592 HTST = RMTOP/V
49593 HB = MB/V/COSB
49594 G32 = ALPHA3*4D0*PI
49595 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49596 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49597 AL2 = 3D0/8D0/PI**2*HT**2
49598C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49599C ALST = 3./8./PI**2*HTST**2
49600 AL1 = 3D0/8D0/PI**2*HB**2
49601
49602 AL(1,1) = AL1
49603 AL(1,2) = (AL2+AL1)/2D0
49604 AL(2,1) = (AL2+AL1)/2D0
49605 AL(2,2) = AL2
49606
49607 IF(MA.GT.MTOP) THEN
49608 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49609 * LOG(MTOP**2/MA**2))
49610 H1I = VI* COSBA
49611 H2I = VI*SINBA
49612 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49613 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49614 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49615 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49616 ELSE
49617 VI = V
49618 H1I = VI*COSB
49619 H2I = VI*SINB
49620 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49621 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49622 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49623 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49624 ENDIF
49625
49626 TANBST = H2T/H1T
49627 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49628
49629 TANBSB = H2B/H1B
49630 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49631 COSBB = SINBB/TANBSB
49632
49633 DELTAMT = 0D0
49634 DELTAMB = 0D0
49635
49636 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49637 MTOP2 = DSQRT(MTOP4)
49638 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49639 * /(1D0+DELTAMB)**4
49640 MBOT2 = DSQRT(MBOT4)
49641
49642 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49643 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49644 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49645 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49646 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49647 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49648 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49649 * MQ2 - MUR2)**2*0.25D0
49650 * + MTOP2*(AT-XMU/TANBST)**2)
49651 IF(STOP22.LT.0.) GOTO 120
49652 SBOT12 = (MQ2 + MD2)*.5D0
49653 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49654 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49655 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49656 SBOT22 = (MQ2 + MD2)*.5D0
49657 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49658 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49659 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49660 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49661
49662 STOP1 = DSQRT(STOP12)
49663 STOP2 = DSQRT(STOP22)
49664 SBOT1 = DSQRT(SBOT12)
49665 SBOT2 = DSQRT(SBOT22)
49666
49667CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49668C
49669C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49670C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49671C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49672C INDUCED CORRECTIONS.
49673C
49674CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49675
49676 X=SBOT1
49677 Y=SBOT2
49678 Z=XMGL
49679 IF(X.EQ.Y) X = X - 0.00001D0
49680 IF(X.EQ.Z) X = X - 0.00002D0
49681 IF(Y.EQ.Z) Y = Y - 0.00003D0
49682
49683 T1=T(X,Y,Z)
49684 X=STOP1
49685 Y=STOP2
49686 Z=XMU
49687 IF(X.EQ.Y) X = X - 0.00001D0
49688 IF(X.EQ.Z) X = X - 0.00002D0
49689 IF(Y.EQ.Z) Y = Y - 0.00003D0
49690 T2=T(X,Y,Z)
49691 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49692 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49693 X=STOP1
49694 Y=STOP2
49695 Z=XMGL
49696 IF(X.EQ.Y) X = X - 0.00001D0
49697 IF(X.EQ.Z) X = X - 0.00002D0
49698 IF(Y.EQ.Z) Y = Y - 0.00003D0
49699 T3=T(X,Y,Z)
49700 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49701
49702CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49703C
49704C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49705C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49706C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49707C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49708C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49709C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49710C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49711C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49712C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49713C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49714C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49715C
49716C
49717CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49718
49719 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49720 MTOP2 = DSQRT(MTOP4)
49721 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49722 * /(1D0+DELTAMB)**4
49723 MBOT2 = DSQRT(MBOT4)
49724
49725 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49726 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49727 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49728 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49729 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49730 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49731 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49732 * MQ2 - MUR2)**2*0.25D0
49733 * + MTOP2*(AT-XMU/TANBST)**2)
49734
49735 IF(STOP22.LT.0.) GOTO 120
49736 SBOT12 = (MQ2 + MD2)*.5D0
49737 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49738 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49739 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49740 SBOT22 = (MQ2 + MD2)*.5D0
49741 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49742 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49743 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49744 IF(SBOT22.LT.0.) GOTO 120
49745
49746
49747 STOP1 = DSQRT(STOP12)
49748 STOP2 = DSQRT(STOP22)
49749 SBOT1 = DSQRT(SBOT12)
49750 SBOT2 = DSQRT(SBOT22)
49751
49752CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49753CCC D-TERMS
49754CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49755 STW=SW
49756
49757 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49758 * LOG(STOP1/STOP2)
49759 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49760 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49761
49762 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49763 * LOG(SBOT1/SBOT2)
49764 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49765 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49766
49767 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49768 * (-.5D0*LOG(STOP12/STOP22)
49769 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49770 * G(STOP12,STOP22))
49771
49772 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49773 * (.5D0*LOG(SBOT12/SBOT22)
49774 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49775 * G(SBOT12,SBOT22))
49776
49777 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49778 * (MQ2+MBOT2)/(MD2+MBOT2))
49779 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49780 * LOG(SBOT1**2/SBOT2**2)) +
49781 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49782 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49783
49784 VH3T(1,1) =
49785 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49786 * -STOP2**2))**2*G(STOP12,STOP22)
49787
49788 VH3B(1,1)=VH3B(1,1)+
49789 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49790
49791 VH3T(1,1) = VH3T(1,1) +
49792 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49793
49794 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49795 * (MQ2+MTOP2)/(MUR2+MTOP2))
49796 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49797 * LOG(STOP1**2/STOP2**2)) +
49798 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49799 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49800
49801 VH3B(2,2) =
49802 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49803 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49804
49805 VH3T(2,2)=VH3T(2,2)+
49806 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49807 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49808 VH3T(1,2) = -
49809 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49810 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49811 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49812
49813 VH3B(1,2) =
49814 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49815 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49816 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49817
49818
49819 VH3T(1,2)=VH3T(1,2) +
49820 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49821
49822 VH3B(1,2)=VH3B(1,2) +
49823 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49824
49825 VH3T(2,1) = VH3T(1,2)
49826 VH3B(2,1) = VH3B(1,2)
49827
49828C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49829C TU = LOG((MUR2+MTOP2)/MTOP2)
49830C TQD = LOG((MQ2 + MB**2)/MB**2)
49831C TD = LOG((MD2+MB**2)/MB**2)
49832
49833 DO 110 I = 1,2
49834 DO 100 J = 1,2
49835 VH(I,J) =
49836 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49837 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49838 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49839 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49840 100 CONTINUE
49841 110 CONTINUE
49842
49843 GOTO 150
49844 120 DO 140 I =1,2
49845 DO 130 J = 1,2
49846 VH(I,J) = -1D15
49847 130 CONTINUE
49848 140 CONTINUE
49849
49850
49851 150 RETURN
49852 END
49853
49854
49855
49856
49857
49858C*********************************************************************
49859
49860C...PYFINT
49861C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49862
49863 FUNCTION PYFINT(A,B,C)
49864
49865C...Double precision and integer declarations.
49866 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49867 IMPLICIT INTEGER(I-N)
49868 INTEGER PYK,PYCHGE,PYCOMP
49869C...Commonblock.
49870 COMMON/PYINTS/XXM(20)
49871 SAVE/PYINTS/
49872
49873C...Local variables.
49874 EXTERNAL PYFISB
49875 DOUBLE PRECISION PYFISB
49876
49877 XXM(1)=A
49878 XXM(2)=B
49879 XXM(3)=C
49880 XLO=0D0
49881 XHI=1D0
49882 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49883
49884 RETURN
49885 END
49886
49887C*********************************************************************
49888
49889C...PYFISB
49890C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49891
49892 FUNCTION PYFISB(X)
49893
49894C...Double precision and integer declarations.
49895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49896 IMPLICIT INTEGER(I-N)
49897 INTEGER PYK,PYCHGE,PYCOMP
49898C...Commonblock.
49899 COMMON/PYINTS/XXM(20)
49900 SAVE/PYINTS/
49901
49902 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49903 &(X*(XXM(2)-XXM(3))+XXM(3)))
49904
49905 RETURN
49906 END
49907
49908C*********************************************************************
49909
49910C...PYSFDC
49911C...Calculates decays of sfermions.
49912
49913 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49914
49915C...Double precision and integer declarations.
49916 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49917 IMPLICIT INTEGER(I-N)
49918 INTEGER PYK,PYCHGE,PYCOMP
49919C...Parameter statement to help give large particle numbers.
49920 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49921 &KEXCIT=4000000,KDIMEN=5000000)
49922C...Commonblocks.
49923 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49924 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49925 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49926 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49927 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49928 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49929
49930C...Local variables.
49931 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49932 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49933 INTEGER KFIN,KCIN
49934 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49935 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49936 DOUBLE PRECISION PYLAMF,XL
49937 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49938 DOUBLE PRECISION AL,AR,BL,BR
49939 DOUBLE PRECISION CH1,CH2,CH3,CH4
49940 DOUBLE PRECISION XMBOT,XMTOP
49941 DOUBLE PRECISION XLAM(0:400)
49942 INTEGER IDLAM(400,3)
49943 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49944 DOUBLE PRECISION SR2
49945 DOUBLE PRECISION CBETA,SBETA
49946 DOUBLE PRECISION CW
49947 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49948 DOUBLE PRECISION COSA,SINA,TANB
49949 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49950 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49951 INTEGER IG,KF1,KF2
49952 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49953 DATA IGG/23,25,35,36/
49954 DATA PI/3.141592654D0/
49955 DATA SR2/1.4142136D0/
49956 DATA KFNCHI/1000022,1000023,1000025,1000035/
49957 DATA KFCCHI/1000024,1000037/
49958
49959C...COUNT THE NUMBER OF DECAY MODES
49960 LKNT=0
49961
49962C...NO NU_R DECAYS
49963 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49964 &KFIN.EQ.KSUSY2+16) RETURN
49965
49966 XMW=PMAS(24,1)
49967 XMW2=XMW**2
49968 XMZ=PMAS(23,1)
49969 XW=PARU(102)
49970 TANW = SQRT(XW/(1D0-XW))
49971 CW=SQRT(1D0-XW)
49972
49973 DO 110 I=1,4
49974 DO 100 J=1,4
49975 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49976 100 CONTINUE
49977 110 CONTINUE
49978 DO 130 I=1,2
49979 DO 120 J=1,2
49980 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49981 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49982 120 CONTINUE
49983 130 CONTINUE
49984
49985C...KCIN
49986 KCIN=PYCOMP(KFIN)
49987C...ILR is 1 for left and 2 for right.
49988 ILR=KFIN/KSUSY1
49989C...IFL is matching non-SUSY flavour.
49990 IFL=MOD(KFIN,KSUSY1)
49991C...IDU is weak isospin, 1 for down and 2 for up.
49992 IDU=2-MOD(IFL,2)
49993
49994 XMI=PMAS(KCIN,1)
49995 XMI2=XMI**2
49996 AEM=PYALEM(XMI2)
49997 AS =PYALPS(XMI2)
49998 C1=AEM/XW
49999 XMI3=XMI**3
50000 EI=KCHG(IFL,1)/3D0
50001
50002 XMBOT=PYMRUN(5,XMI2)
50003 XMTOP=PYMRUN(6,XMI2)
50004
50005 TANB=RMSS(5)
50006 BETA=ATAN(TANB)
50007 ALFA=RMSS(18)
50008 CBETA=COS(BETA)
50009 SBETA=TANB*CBETA
50010 SINA=SIN(ALFA)
50011 COSA=COS(ALFA)
50012 XMU=-RMSS(4)
50013 ATRIT=RMSS(16)
50014 ATRIB=RMSS(15)
50015 ATRIL=RMSS(17)
50016
50017C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50018
50019 IF(IMSS(11).EQ.1) THEN
50020 XMP=RMSS(29)
50021 IDG=39+KSUSY1
50022 XMGR=PMAS(PYCOMP(IDG),1)
50023 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50024 IF(IFL.EQ.5) THEN
50025 XMF=XMBOT
50026 ELSEIF(IFL.EQ.6) THEN
50027 XMF=XMTOP
50028 ELSE
50029 XMF=PMAS(IFL,1)
50030 ENDIF
50031 IF(XMI.GT.XMGR+XMF) THEN
50032 LKNT=LKNT+1
50033 IDLAM(LKNT,1)=IDG
50034 IDLAM(LKNT,2)=IFL
50035 IDLAM(LKNT,3)=0
50036 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50037 ENDIF
50038 ENDIF
50039
50040C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50041
50042C...CHARGED DECAYS:
50043 DO 140 IX=1,2
50044C...DI -> U CHI1-,CHI2-
50045 IF(IDU.EQ.1) THEN
50046 XMFP=PMAS(IFL+1,1)
50047 XMF =PMAS(IFL,1)
50048C...UI -> D CHI1+,CHI2+
50049 ELSE
50050 XMFP=PMAS(IFL-1,1)
50051 XMF =PMAS(IFL,1)
50052 ENDIF
50053 XMJ=SMW(IX)
50054 AXMJ=ABS(XMJ)
50055 IF(XMI.GE.AXMJ+XMFP) THEN
50056 XMA2=XMJ**2
50057 XMB2=XMFP**2
50058 IF(IDU.EQ.2) THEN
50059 IF(IFL.EQ.6) THEN
50060 XMFP=XMBOT
50061 XMF =XMTOP
50062 ELSEIF(IFL.LT.6) THEN
50063 XMF=0D0
50064 XMFP=0D0
50065 ENDIF
50066 CBL=VMIXC(IX,1)
50067 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50068 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50069 CAR=0D0
50070 ELSE
50071 IF(IFL.EQ.5) THEN
50072 XMF =XMBOT
50073 XMFP=XMTOP
50074 ELSEIF(IFL.LT.5) THEN
50075 XMF=0D0
50076 XMFP=0D0
50077 ENDIF
50078 CBL=UMIXC(IX,1)
50079 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50080 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50081 CAR=0D0
50082 ENDIF
50083
50084 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50085 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50086 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50087 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50088 CAL=CALP
50089 CBL=CBLP
50090 CAR=CARP
50091 CBR=CBRP
50092
50093C...F1 -> F` CHI
50094 IF(ILR.EQ.1) THEN
50095 CA=CAL
50096 CB=CBL
50097C...F2 -> F` CHI
50098 ELSE
50099 CA=CAR
50100 CB=CBR
50101 ENDIF
50102 LKNT=LKNT+1
50103 XL=PYLAMF(XMI2,XMA2,XMB2)
50104C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50105 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50106 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50107 IDLAM(LKNT,3)=0
50108 IF(IDU.EQ.1) THEN
50109 IDLAM(LKNT,1)=-KFCCHI(IX)
50110 IDLAM(LKNT,2)=IFL+1
50111 ELSE
50112 IDLAM(LKNT,1)=KFCCHI(IX)
50113 IDLAM(LKNT,2)=IFL-1
50114 ENDIF
50115 ENDIF
50116 140 CONTINUE
50117
50118C...NEUTRAL DECAYS
50119 DO 150 IX=1,4
50120C...DI -> D CHI10
50121 XMF=PMAS(IFL,1)
50122 XMJ=SMZ(IX)
50123 AXMJ=ABS(XMJ)
50124 IF(XMI.GE.AXMJ+XMF) THEN
50125 XMA2=XMJ**2
50126 XMB2=XMF**2
50127 IF(IDU.EQ.1) THEN
50128 IF(IFL.EQ.5) THEN
50129 XMF=XMBOT
50130 ELSEIF(IFL.LT.5) THEN
50131 XMF=0D0
50132 ENDIF
50133 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50134 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50135 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50136 CBR=CAL
50137 ELSE
50138 IF(IFL.EQ.6) THEN
50139 XMF=XMTOP
50140 ELSEIF(IFL.LT.5) THEN
50141 XMF=0D0
50142 ENDIF
50143 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50144 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50145 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50146 CBR=CAL
50147 ENDIF
50148
50149 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50150 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50151 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50152 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50153 CAL=CALP
50154 CBL=CBLP
50155 CAR=CARP
50156 CBR=CBRP
50157
50158C...F1 -> F CHI
50159 IF(ILR.EQ.1) THEN
50160 CA=CAL
50161 CB=CBL
50162C...F2 -> F CHI
50163 ELSE
50164 CA=CAR
50165 CB=CBR
50166 ENDIF
50167 LKNT=LKNT+1
50168 XL=PYLAMF(XMI2,XMA2,XMB2)
50169C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50170 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50171 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50172 IDLAM(LKNT,1)=KFNCHI(IX)
50173 IDLAM(LKNT,2)=IFL
50174 IDLAM(LKNT,3)=0
50175 ENDIF
50176 150 CONTINUE
50177
50178C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50179C...IG=23,25,35,36
50180 DO 160 II=1,4
50181 IG=IGG(II)
50182 IF(ILR.EQ.1) GOTO 160
50183 XMB=PMAS(IG,1)
50184 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50185 IF(XMI.LT.XMSF1+XMB) GOTO 160
50186 IF(IG.EQ.23) THEN
50187 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50188 BR=EI*XW/CW
50189 BLR=0D0
50190 ELSEIF(IG.EQ.25) THEN
50191 IF(IFL.EQ.5) THEN
50192 XMF=XMBOT
50193 ELSEIF(IFL.EQ.6) THEN
50194 XMF=XMTOP
50195 ELSEIF(IFL.LT.5) THEN
50196 XMF=0D0
50197 ELSE
50198 XMF=PMAS(IFL,1)
50199 ENDIF
50200 IF(IDU.EQ.2) THEN
50201 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50202 & XMF**2/XMW*COSA/SBETA
50203 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50204 & XMF**2/XMW*COSA/SBETA
50205 ELSE
50206 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50207 & XMF**2/XMW*(-SINA)/CBETA
50208 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50209 & XMF**2/XMW*(-SINA)/CBETA
50210 ENDIF
50211 IF(IFL.EQ.5) THEN
50212 AT=ATRIB
50213 ELSEIF(IFL.EQ.6) THEN
50214 AT=ATRIT
50215 ELSEIF(IFL.EQ.15) THEN
50216 AT=ATRIL
50217 ELSE
50218 AT=0D0
50219 ENDIF
50220C.........need to complexify
50221 IF(IDU.EQ.2) THEN
50222 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50223 & AT*COSA)
50224 ELSE
50225 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50226 & AT*SINA)
50227 ENDIF
50228 BL=GHLL
50229 BR=GHRR
50230 BLR=-GHLR
50231 ELSEIF(IG.EQ.35) THEN
50232 IF(IFL.EQ.5) THEN
50233 XMF=XMBOT
50234 ELSEIF(IFL.EQ.6) THEN
50235 XMF=XMTOP
50236 ELSEIF(IFL.LT.5) THEN
50237 XMF=0D0
50238 ELSE
50239 XMF=PMAS(IFL,1)
50240 ENDIF
50241 IF(IDU.EQ.2) THEN
50242 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50243 & XMF**2/XMW*SINA/SBETA
50244 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50245 & XMF**2/XMW*SINA/SBETA
50246 ELSE
50247 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50248 & XMF**2/XMW*COSA/CBETA
50249 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50250 & XMF**2/XMW*COSA/CBETA
50251 ENDIF
50252 IF(IFL.EQ.5) THEN
50253 AT=ATRIB
50254 ELSEIF(IFL.EQ.6) THEN
50255 AT=ATRIT
50256 ELSEIF(IFL.EQ.15) THEN
50257 AT=ATRIL
50258 ELSE
50259 AT=0D0
50260 ENDIF
50261C.........Need to complexify
50262 IF(IDU.EQ.2) THEN
50263 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50264 & AT*SINA)
50265 ELSE
50266 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50267 & AT*COSA)
50268 ENDIF
50269 BL=GHLL
50270 BR=GHRR
50271 BLR=GHLR
50272 ELSEIF(IG.EQ.36) THEN
50273 GHLL=0D0
50274 GHRR=0D0
50275 IF(IFL.EQ.5) THEN
50276 XMF=XMBOT
50277 ELSEIF(IFL.EQ.6) THEN
50278 XMF=XMTOP
50279 ELSEIF(IFL.LT.5) THEN
50280 XMF=0D0
50281 ELSE
50282 XMF=PMAS(IFL,1)
50283 ENDIF
50284 IF(IFL.EQ.5) THEN
50285 AT=ATRIB
50286 ELSEIF(IFL.EQ.6) THEN
50287 AT=ATRIT
50288 ELSEIF(IFL.EQ.15) THEN
50289 AT=ATRIL
50290 ELSE
50291 AT=0D0
50292 ENDIF
50293C.........Need to complexify
50294 IF(IDU.EQ.2) THEN
50295 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50296 ELSE
50297 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50298 ENDIF
50299 BL=GHLL
50300 BR=GHRR
50301 BLR=GHLR
50302 ENDIF
50303 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50304 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50305 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50306 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50307 LKNT=LKNT+1
50308 IF(IG.EQ.23) THEN
50309 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50310 ELSE
50311 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50312 ENDIF
50313 IDLAM(LKNT,3)=0
50314 IDLAM(LKNT,1)=KFIN-KSUSY1
50315 IDLAM(LKNT,2)=IG
50316 160 CONTINUE
50317
50318C...SF -> SF' + W
50319 XMB=PMAS(24,1)
50320 IF(MOD(IFL,2).EQ.0) THEN
50321 KF1=KSUSY1+IFL-1
50322 ELSE
50323 KF1=KSUSY1+IFL+1
50324 ENDIF
50325 KF2=KF1+KSUSY1
50326 XMSF1=PMAS(PYCOMP(KF1),1)
50327 XMSF2=PMAS(PYCOMP(KF2),1)
50328 IF(XMI.GT.XMB+XMSF1) THEN
50329 IF(MOD(IFL,2).EQ.0) THEN
50330 IF(ILR.EQ.1) THEN
50331 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50332 ELSE
50333 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50334 ENDIF
50335 ELSE
50336 IF(ILR.EQ.1) THEN
50337 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50338 ELSE
50339 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50340 ENDIF
50341 ENDIF
50342 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50343 LKNT=LKNT+1
50344 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50345 IDLAM(LKNT,3)=0
50346 IDLAM(LKNT,1)=KF1
50347 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50348 ENDIF
50349 IF(XMI.GT.XMB+XMSF2) THEN
50350 IF(MOD(IFL,2).EQ.0) THEN
50351 IF(ILR.EQ.1) THEN
50352 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50353 ELSE
50354 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50355 ENDIF
50356 ELSE
50357 IF(ILR.EQ.1) THEN
50358 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50359 ELSE
50360 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50361 ENDIF
50362 ENDIF
50363 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50364 LKNT=LKNT+1
50365 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50366 IDLAM(LKNT,3)=0
50367 IDLAM(LKNT,1)=KF2
50368 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50369 ENDIF
50370
50371C...SF -> SF' + HC
50372 XMB=PMAS(37,1)
50373 IF(MOD(IFL,2).EQ.0) THEN
50374 KF1=KSUSY1+IFL-1
50375 ELSE
50376 KF1=KSUSY1+IFL+1
50377 ENDIF
50378 KF2=KF1+KSUSY1
50379 XMSF1=PMAS(PYCOMP(KF1),1)
50380 XMSF2=PMAS(PYCOMP(KF2),1)
50381 IF(XMI.GT.XMB+XMSF1) THEN
50382 XMF=0D0
50383 XMFP=0D0
50384 AT=0D0
50385 AB=0D0
50386 IF(MOD(IFL,2).EQ.0) THEN
50387C...T1-> B1 HC
50388 IF(ILR.EQ.1) THEN
50389 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50390 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50391 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50392 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50393C...T2-> B1 HC
50394 ELSE
50395 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50396 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50397 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50398 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50399 ENDIF
50400 IF(IFL.EQ.6) THEN
50401 XMF=XMTOP
50402 XMFP=XMBOT
50403 AT=ATRIT
50404 AB=ATRIB
50405 ENDIF
50406 ELSE
50407C...B1 -> T1 HC
50408 IF(ILR.EQ.1) THEN
50409 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50410 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50411 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50412 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50413C...B2-> T1 HC
50414 ELSE
50415 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50416 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50417 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50418 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50419 ENDIF
50420 IF(IFL.EQ.5) THEN
50421 XMF=XMTOP
50422 XMFP=XMBOT
50423 AT=ATRIT
50424 AB=ATRIB
50425 ENDIF
50426 ENDIF
50427 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50428 LKNT=LKNT+1
50429C.......Need to complexify
50430 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50431 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50432 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50433 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50434 IDLAM(LKNT,3)=0
50435 IDLAM(LKNT,1)=KF1
50436 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50437 ENDIF
50438 IF(XMI.GT.XMB+XMSF2) THEN
50439 XMF=0D0
50440 XMFP=0D0
50441 AT=0D0
50442 AB=0D0
50443 IF(MOD(IFL,2).EQ.0) THEN
50444C...T1-> B2 HC
50445 IF(ILR.EQ.1) THEN
50446 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50447 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50448 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50449 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50450C...T2-> B2 HC
50451 ELSE
50452 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50453 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50454 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50455 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50456 ENDIF
50457 IF(IFL.EQ.6) THEN
50458 XMF=XMTOP
50459 XMFP=XMBOT
50460 AT=ATRIT
50461 AB=ATRIB
50462 ENDIF
50463 ELSE
50464C...B1 -> T2 HC
50465 IF(ILR.EQ.1) THEN
50466 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50467 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50468 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50469 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50470C...B2-> T2 HC
50471 ELSE
50472 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50473 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50474 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50475 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50476 ENDIF
50477 IF(IFL.EQ.5) THEN
50478 XMF=XMTOP
50479 XMFP=XMBOT
50480 AT=ATRIT
50481 AB=ATRIB
50482 ENDIF
50483 ENDIF
50484 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50485 LKNT=LKNT+1
50486C.......Need to complexify
50487 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50488 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50489 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50490 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50491 IDLAM(LKNT,3)=0
50492 IDLAM(LKNT,1)=KF2
50493 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50494 ENDIF
50495
50496C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50497
50498 IF(IFL.LE.6) THEN
50499 XMFP=0D0
50500 XMF=0D0
50501 IF(IFL.EQ.6) XMF=PMAS(6,1)
50502 IF(IFL.EQ.5) XMF=PMAS(5,1)
50503 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50504 AXMJ=ABS(XMJ)
50505 IF(XMI.GE.AXMJ+XMF) THEN
50506 AL=-SFMIX(IFL,3)
50507 BL=SFMIX(IFL,1)
50508 AR=-SFMIX(IFL,4)
50509 BR=SFMIX(IFL,2)
50510C...F1 -> F CHI
50511 IF(ILR.EQ.1) THEN
50512 XCA=AL
50513 XCB=BL
50514C...F2 -> F CHI
50515 ELSE
50516 XCA=AR
50517 XCB=BR
50518 ENDIF
50519 LKNT=LKNT+1
50520 XMA2=XMJ**2
50521 XMB2=XMF**2
50522 XL=PYLAMF(XMI2,XMA2,XMB2)
50523 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50524 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50525 IDLAM(LKNT,1)=KSUSY1+21
50526 IDLAM(LKNT,2)=IFL
50527 IDLAM(LKNT,3)=0
50528 ENDIF
50529 ENDIF
50530
50531C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50532 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50533 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50534C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50535C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50536C...M*M = C1**2 * G**2/(16PI**2)
50537C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50538 LKNT=LKNT+1
50539 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50540 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50541 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50542 IDLAM(LKNT,1)=KSUSY1+22
50543 IDLAM(LKNT,2)=4
50544 IDLAM(LKNT,3)=0
50545 ENDIF
50546
50547C...R-violating sfermion decays (SKANDS).
50548 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50549
50550 IKNT=LKNT
50551 XLAM(0)=0D0
50552 DO 170 I=1,IKNT
50553 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50554 XLAM(0)=XLAM(0)+XLAM(I)
50555 170 CONTINUE
50556 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50557
50558 RETURN
50559 END
50560
50561C*********************************************************************
50562
50563C...PYGLUI
50564C...Calculates gluino decay modes.
50565
50566 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50567
50568C...Double precision and integer declarations.
50569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50570 IMPLICIT INTEGER(I-N)
50571 INTEGER PYK,PYCHGE,PYCOMP
50572C...Parameter statement to help give large particle numbers.
50573 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50574 &KEXCIT=4000000,KDIMEN=5000000)
50575C...Commonblocks.
50576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50578 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50579 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50580 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50581CC &SFMIX(16,4),
50582C COMMON/PYINTS/XXM(20)
50583 COMPLEX*16 CXC
50584 COMMON/PYINTC/XXC(10),CXC(8)
50585 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50586
50587C...Local variables
50588 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50589 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50590 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50591 DOUBLE PRECISION PYLAMF,XL
50592 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50593 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50594 DOUBLE PRECISION XLAM(0:400)
50595 INTEGER IDLAM(400,3)
50596 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50597 DOUBLE PRECISION SR2
50598 DOUBLE PRECISION GAM
50599 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50600 EXTERNAL PYGAUS,PYXXZ6
50601 DOUBLE PRECISION PYGAUS,PYXXZ6
50602 DOUBLE PRECISION PREC
50603 INTEGER KFNCHI(4),KFCCHI(2)
50604 DATA PI/3.141592654D0/
50605 DATA SR2/1.4142136D0/
50606 DATA PREC/1D-2/
50607 DATA KFNCHI/1000022,1000023,1000025,1000035/
50608 DATA KFCCHI/1000024,1000037/
50609
50610C...COUNT THE NUMBER OF DECAY MODES
50611 LKNT=0
50612 IF(KFIN.NE.KSUSY1+21) RETURN
50613 KCIN=PYCOMP(KFIN)
50614
50615 XW=PARU(102)
50616 TANW = SQRT(XW/(1D0-XW))
50617
50618 XMI=PMAS(KCIN,1)
50619 AXMI=ABS(XMI)
50620 XMI2=XMI**2
50621 AEM=PYALEM(XMI2)
50622 AS =PYALPS(XMI2)
50623 C1=AEM/XW
50624 XMI3=AXMI**3
50625
50626 XMI=SIGN(XMI,RMSS(3))
50627
50628C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50629
50630 IF(IMSS(11).EQ.1) THEN
50631 XMP=RMSS(29)
50632 IDG=39+KSUSY1
50633 XMGR=PMAS(PYCOMP(IDG),1)
50634 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50635 IF(AXMI.GT.XMGR) THEN
50636 LKNT=LKNT+1
50637 IDLAM(LKNT,1)=IDG
50638 IDLAM(LKNT,2)=21
50639 IDLAM(LKNT,3)=0
50640 XLAM(LKNT)=XFAC
50641 ENDIF
50642 ENDIF
50643
50644C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50645
50646 DO 110 IFL=1,6
50647 DO 100 ILR=1,2
50648 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50649 AXMJ=ABS(XMJ)
50650 XMF=PMAS(IFL,1)
50651 IF(AXMI.GE.AXMJ+XMF) THEN
50652C...Minus sign difference from gluino-quark-squark feynman rules
50653 AL=SFMIX(IFL,1)
50654 BL=-SFMIX(IFL,3)
50655 AR=SFMIX(IFL,2)
50656 BR=-SFMIX(IFL,4)
50657C...F1 -> F CHI
50658 IF(ILR.EQ.1) THEN
50659 CA=AL
50660 CB=BL
50661C...F2 -> F CHI
50662 ELSE
50663 CA=AR
50664 CB=BR
50665 ENDIF
50666 LKNT=LKNT+1
50667 XMA2=XMJ**2
50668 XMB2=XMF**2
50669 XL=PYLAMF(XMI2,XMA2,XMB2)
50670 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50671 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50672 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50673 IDLAM(LKNT,2)=-IFL
50674 IDLAM(LKNT,3)=0
50675 LKNT=LKNT+1
50676 XLAM(LKNT)=XLAM(LKNT-1)
50677 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50678 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50679 IDLAM(LKNT,3)=0
50680 ENDIF
50681 100 CONTINUE
50682 110 CONTINUE
50683
50684C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50685C...GLUINO -> NI Q QBAR
50686 DO 170 IX=1,4
50687 XMJ=SMZ(IX)
50688 AXMJ=ABS(XMJ)
50689 IF(AXMI.GE.AXMJ) THEN
50690 DO 120 I=1,4
50691 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50692 120 CONTINUE
50693 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50694 ORPP=DCONJG(OLPP)
50695 XXC(1)=0D0
50696 XXC(2)=XMJ
50697 XXC(3)=0D0
50698 XXC(4)=XMI
50699 IA=1
50700 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50701 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50702 XXC(7)=XXC(5)
50703 XXC(8)=XXC(6)
50704 XXC(9)=1D6
50705 XXC(10)=0D0
50706 EI=KCHG(IA,1)/3D0
50707 T3I=SIGN(1D0,EI+1D-6)/2D0
50708 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50709 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50710 CXC(1)=0D0
50711 CXC(2)=-GLIJ
50712 CXC(3)=0D0
50713 CXC(4)=DCONJG(GLIJ)
50714 CXC(5)=0D0
50715 CXC(6)=GRIJ
50716 CXC(7)=0D0
50717 CXC(8)=-DCONJG(GRIJ)
50718 S12MIN=0D0
50719 S12MAX=(AXMI-AXMJ)**2
50720 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50721 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50722 LKNT=LKNT+1
50723 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50724 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50725 IDLAM(LKNT,1)=KFNCHI(IX)
50726 IDLAM(LKNT,2)=1
50727 IDLAM(LKNT,3)=-1
50728 ENDIF
50729 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50730 LKNT=LKNT+1
50731 XLAM(LKNT)=XLAM(LKNT-1)
50732 IDLAM(LKNT,1)=KFNCHI(IX)
50733 IDLAM(LKNT,2)=3
50734 IDLAM(LKNT,3)=-3
50735 ENDIF
50736 130 CONTINUE
50737 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50738 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50739 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50740 GOTO 140
50741 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50742 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50743 ENDIF
50744 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50745 LKNT=LKNT+1
50746 XLAM(LKNT)=GAM
50747 IDLAM(LKNT,1)=KFNCHI(IX)
50748 IDLAM(LKNT,2)=5
50749 IDLAM(LKNT,3)=-5
50750 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50751 ENDIF
50752C...U-TYPE QUARKS
50753 140 CONTINUE
50754 IA=2
50755 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50756 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50757C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50758 XXC(7)=XXC(5)
50759 XXC(8)=XXC(6)
50760 EI=KCHG(IA,1)/3D0
50761 T3I=SIGN(1D0,EI+1D-6)/2D0
50762 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50763 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50764 CXC(2)=-GLIJ
50765 CXC(4)=DCONJG(GLIJ)
50766 CXC(6)=GRIJ
50767 CXC(8)=-DCONJG(GRIJ)
50768 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50769 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50770 LKNT=LKNT+1
50771 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50772 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50773 IDLAM(LKNT,1)=KFNCHI(IX)
50774 IDLAM(LKNT,2)=2
50775 IDLAM(LKNT,3)=-2
50776 ENDIF
50777 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50778 LKNT=LKNT+1
50779 XLAM(LKNT)=XLAM(LKNT-1)
50780 IDLAM(LKNT,1)=KFNCHI(IX)
50781 IDLAM(LKNT,2)=4
50782 IDLAM(LKNT,3)=-4
50783 ENDIF
50784 150 CONTINUE
50785C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50786C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50787 XMF=PMAS(6,1)
50788 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50789 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50790 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50791 GOTO 160
50792 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50793 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50794 ENDIF
50795 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50796 LKNT=LKNT+1
50797 XLAM(LKNT)=GAM
50798 IDLAM(LKNT,1)=KFNCHI(IX)
50799 IDLAM(LKNT,2)=6
50800 IDLAM(LKNT,3)=-6
50801 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50802 ENDIF
50803 160 CONTINUE
50804 ENDIF
50805 170 CONTINUE
50806
50807C...GLUINO -> CI Q QBAR'
50808 DO 210 IX=1,2
50809 XMJ=SMW(IX)
50810 AXMJ=ABS(XMJ)
50811 IF(AXMI.GE.AXMJ) THEN
50812 DO 180 I=1,2
50813 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50814 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50815 180 CONTINUE
50816 S12MIN=0D0
50817 S12MAX=(AXMI-AXMJ)**2
50818 XXC(1)=0D0
50819 XXC(2)=XMJ
50820 XXC(3)=0D0
50821 XXC(4)=XMI
50822 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50823 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50824 XXC(9)=1D6
50825 XXC(10)=0D0
50826 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50827 ORPP=DCONJG(OLPP)
50828 CXC(1)=DCMPLX(0D0,0D0)
50829 CXC(3)=DCMPLX(0D0,0D0)
50830 CXC(5)=DCMPLX(0D0,0D0)
50831 CXC(7)=DCMPLX(0D0,0D0)
50832 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50833 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50834 CXC(6)=DCMPLX(0D0,0D0)
50835 CXC(8)=DCMPLX(0D0,0D0)
50836 IF(XXC(5).LT.AXMI) THEN
50837 XXC(5)=1D6
50838 ELSEIF(XXC(6).LT.AXMI) THEN
50839 XXC(6)=1D6
50840 ENDIF
50841 XXC(7)=XXC(6)
50842 XXC(8)=XXC(5)
50843 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50844 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50845 LKNT=LKNT+1
50846 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50847 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50848 IDLAM(LKNT,1)=KFCCHI(IX)
50849 IDLAM(LKNT,2)=1
50850 IDLAM(LKNT,3)=-2
50851 LKNT=LKNT+1
50852 XLAM(LKNT)=XLAM(LKNT-1)
50853 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50854 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50855 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50856 ENDIF
50857 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50858 LKNT=LKNT+1
50859 XLAM(LKNT)=XLAM(LKNT-1)
50860 IDLAM(LKNT,1)=KFCCHI(IX)
50861 IDLAM(LKNT,2)=3
50862 IDLAM(LKNT,3)=-4
50863 LKNT=LKNT+1
50864 XLAM(LKNT)=XLAM(LKNT-1)
50865 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50866 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50867 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50868 ENDIF
50869 190 CONTINUE
50870
50871 XMF=PMAS(6,1)
50872 XMFP=PMAS(5,1)
50873 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50874 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50875 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50876 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50877 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50878 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50879 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50880 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50881 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50882 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50883 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50884 CALL PYTBBC(IX,100,XMI,GAM)
50885 LKNT=LKNT+1
50886 XLAM(LKNT)=GAM
50887 IDLAM(LKNT,1)=KFCCHI(IX)
50888 IDLAM(LKNT,2)=5
50889 IDLAM(LKNT,3)=-6
50890 LKNT=LKNT+1
50891 XLAM(LKNT)=XLAM(LKNT-1)
50892 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50893 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50894 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50895 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50896 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50897 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50898 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50899 ENDIF
50900 200 CONTINUE
50901 ENDIF
50902 210 CONTINUE
50903
50904C...R-parity violating (3-body) decays.
50905 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50906
50907 IKNT=LKNT
50908 XLAM(0)=0D0
50909 DO 220 I=1,IKNT
50910 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50911 XLAM(0)=XLAM(0)+XLAM(I)
50912 220 CONTINUE
50913 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50914
50915 RETURN
50916 END
50917
50918
50919C*********************************************************************
50920
50921C...PYTBBN
50922C...Calculates the three-body decay of gluinos into
50923C...neutralinos and third generation fermions.
50924
50925 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50926
50927C...Double precision and integer declarations.
50928 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50929 IMPLICIT INTEGER(I-N)
50930 INTEGER PYK,PYCHGE,PYCOMP
50931C...Parameter statement to help give large particle numbers.
50932 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50933 &KEXCIT=4000000,KDIMEN=5000000)
50934C...Commonblocks.
50935 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50936 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50937 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50938 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50939 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50940 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50941
50942C...Local variables.
50943 EXTERNAL PYSIMP,PYLAMF
50944 DOUBLE PRECISION PYSIMP,PYLAMF
50945 INTEGER LIN,NN
50946 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50947 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50948 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50949 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50950 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50951 DOUBLE PRECISION XLN1,XLN2,B1,B2
50952 DOUBLE PRECISION E,XMGLU,GAM
50953 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50954 SAVE HRB,HLB,FLB,FRB
50955 DOUBLE PRECISION ALPHAW,ALPHAS
50956 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50957 SAVE HLT,HRT,FLT,FRT
50958 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50959 SAVE AMN,AN,ZN
50960 DOUBLE PRECISION AMBOT,SINC,COSC
50961 DOUBLE PRECISION AMTOP,SINA,COSA
50962 DOUBLE PRECISION SINW,COSW,TANW
50963 DOUBLE PRECISION ROT1(4,4)
50964 LOGICAL IFIRST
50965 SAVE IFIRST
50966 DATA IFIRST/.TRUE./
50967
50968 TANB=RMSS(5)
50969 SINB=TANB/SQRT(1D0+TANB**2)
50970 COSB=SINB/TANB
50971 XW=PARU(102)
50972 SINW=SQRT(XW)
50973 COSW=SQRT(1D0-XW)
50974 TANW=SINW/COSW
50975 AMW=PMAS(24,1)
50976 COSC=SFMIX(5,1)
50977 SINC=SFMIX(5,3)
50978 COSA=SFMIX(6,1)
50979 SINA=SFMIX(6,3)
50980 AMBOT=PYMRUN(5,XMGLU**2)
50981 AMTOP=PYMRUN(6,XMGLU**2)
50982 W2=SQRT(2D0)
50983 FAKT1=AMBOT/W2/AMW/COSB
50984 FAKT2=AMTOP/W2/AMW/SINB
50985 IF(IFIRST) THEN
50986 DO 110 II=1,4
50987 AMN(II)=SMZ(II)
50988 DO 100 J=1,4
50989 ROT1(II,J)=0D0
50990 AN(II,J)=0D0
50991 100 CONTINUE
50992 110 CONTINUE
50993 ROT1(1,1)=COSW
50994 ROT1(1,2)=-SINW
50995 ROT1(2,1)=-ROT1(1,2)
50996 ROT1(2,2)=ROT1(1,1)
50997 ROT1(3,3)=COSB
50998 ROT1(3,4)=SINB
50999 ROT1(4,3)=-ROT1(3,4)
51000 ROT1(4,4)=ROT1(3,3)
51001 DO 140 II=1,4
51002 DO 130 J=1,4
51003 DO 120 JJ=1,4
51004 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51005 120 CONTINUE
51006 130 CONTINUE
51007 140 CONTINUE
51008 DO 150 J=1,4
51009 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51010 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51011 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51012 & XW)*AN(J,2)/COSW
51013 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51014 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51015 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51016 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51017C FLU(J)=ZN(3)
51018C FRU(J)=ZN(2)
51019 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51020 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51021 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51022 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51023 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51024 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51025 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51026C FLD(J)=ZN(3)
51027C FRD(J)=ZN(2)
51028 150 CONTINUE
51029C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51030C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51031C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51032C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51033 IFIRST=.FALSE.
51034 ENDIF
51035
51036 IF(NINT(3D0*E).EQ.2) THEN
51037 HL=HLT(I)
51038 HR=HRT(I)
51039 FL=FLT(I)
51040 FR=FRT(I)
51041 COSD=SFMIX(6,1)
51042 SIND=SFMIX(6,3)
51043 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51044 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51045 XM=PMAS(6,1)
51046 ELSE
51047 HL=HLB(I)
51048 HR=HRB(I)
51049 FL=FLB(I)
51050 FR=FRB(I)
51051 COSD=SFMIX(5,1)
51052 SIND=SFMIX(5,3)
51053 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51054 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51055 XM=PMAS(5,1)
51056 ENDIF
51057 COSD2=COSD*COSD
51058 SIND2=SIND*SIND
51059 COS2D=COSD2-SIND2
51060 SIN2D=SIND*COSD*2D0
51061 HL2=HL*HL
51062 HR2=HR*HR
51063 FL2=FL*FL
51064 FR2=FR*FR
51065 FF=FL*FR
51066 HH=HL*HR
51067 HFL=HL*FL
51068 HFR=HR*FR
51069 HRFL=HR*FL
51070 HLFR=HL*FR
51071 XM2=XM*XM
51072 XMG=XMGLU
51073 XMG2=XMG*XMG
51074 ALPHAW=PYALEM(XMG2)
51075 ALPHAS=PYALPS(XMG2)
51076 XMR=AMN(I)
51077 XMR2=XMR*XMR
51078 XMQ4=XMG*XM2*XMR
51079 XM24=(XMG2+XM2)*(XM2+XMR2)
51080 SMIN=4D0*XM2
51081 SMAX=(XMG-ABS(XMR))**2
51082 XMQA=XMG2+2D0*XM2+XMR2
51083 DO 170 LIN=1,NN-1
51084 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51085 GRS=SBAR-XMQA
51086 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51087 W=DSQRT(W)
51088 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51089 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51090 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51091 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51092 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51093 & +2D0*(FF*SIND2-HH*COSD2))*W
51094 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51095 & +4D0*HFL*XM*XMR)*XLN1
51096 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51097 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51098 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51099 & +8D0*HFL*XMQ4*SIN2D)*B1
51100 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51101 & +4D0*HFR*XMR*XM)*XLN2
51102 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51103 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51104 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51105 & -8D0*HFR*XMQ4*SIN2D)*B2
51106 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51107 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51108 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51109 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51110 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51111 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51112 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51113 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51114 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51115 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51116 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51117 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51118 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51119 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51120 & +COS2D*XM*(SBAR+XMG2-XMR2))
51121 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51122 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51123 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51124 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51125 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51126 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51127 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51128 SUMME(LIN)=0D0
51129 DO 160 J=0,6
51130 SUMME(LIN)=SUMME(LIN)+G(J)
51131 160 CONTINUE
51132 170 CONTINUE
51133 SUMME(0)=0D0
51134 SUMME(NN)=0D0
51135 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51136 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51137
51138 RETURN
51139 END
51140
51141C*********************************************************************
51142
51143C...PYTBBC
51144C...Calculates the three-body decay of gluinos into
51145C...charginos and third generation fermions.
51146
51147 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51148
51149C...Double precision and integer declarations.
51150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51151 IMPLICIT INTEGER(I-N)
51152 INTEGER PYK,PYCHGE,PYCOMP
51153C...Parameter statement to help give large particle numbers.
51154 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51155 &KEXCIT=4000000,KDIMEN=5000000)
51156C...Commonblocks.
51157 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51158 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51159 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51160 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51161 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51162 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51163
51164C...Local variables.
51165 EXTERNAL PYSIMP,PYLAMF
51166 DOUBLE PRECISION PYSIMP,PYLAMF
51167 INTEGER I,NN,LIN
51168 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51169 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51170 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51171 DOUBLE PRECISION SUMME(0:100),A(4,8)
51172 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51173 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51174 DOUBLE PRECISION XMGLU,GAM
51175 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51176 &DDD(2),EEE(2),FFF(2)
51177 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51178 DOUBLE PRECISION ALPHAW,ALPHAS
51179 DOUBLE PRECISION AMC(2)
51180 SAVE AMC
51181 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51182 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51183 SAVE AMSB,AMST
51184 LOGICAL IFIRST
51185 SAVE IFIRST
51186 DATA IFIRST/.TRUE./
51187
51188 TANB=RMSS(5)
51189 SINB=TANB/SQRT(1D0+TANB**2)
51190 COSB=SINB/TANB
51191 XW=PARU(102)
51192 AMW=PMAS(24,1)
51193 COSC=SFMIX(5,1)
51194 SINC=SFMIX(5,3)
51195 COSA=SFMIX(6,1)
51196 SINA=SFMIX(6,3)
51197 AMBOT=PYMRUN(5,XMGLU**2)
51198 AMTOP=PYMRUN(6,XMGLU**2)
51199 W2=SQRT(2D0)
51200 AMW=PMAS(24,1)
51201 FAKT1=AMBOT/W2/AMW/COSB
51202 FAKT2=AMTOP/W2/AMW/SINB
51203 IF(IFIRST) THEN
51204 AMC(1)=SMW(1)
51205 AMC(2)=SMW(2)
51206 DO 100 JJ=1,2
51207 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51208 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51209 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51210 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51211 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51212 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51213 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51214 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51215 100 CONTINUE
51216 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51217 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51218 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51219 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51220 IFIRST=.FALSE.
51221 ENDIF
51222
51223 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51224 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51225 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51226 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51227
51228 COS2A=COSA**2-SINA**2
51229 SIN2A=SINA*COSA*2D0
51230 COS2C=COSC**2-SINC**2
51231 SIN2C=SINC*COSC*2D0
51232
51233 XMG=XMGLU
51234 XMT=PMAS(6,1)
51235 XMB=PMAS(5,1)
51236 XMR=AMC(I)
51237 XMG2=XMG*XMG
51238 ALPHAW=PYALEM(XMG2)
51239 ALPHAS=PYALPS(XMG2)
51240 XMT2=XMT*XMT
51241 XMB2=XMB*XMB
51242 XMR2=XMR*XMR
51243 XMQ2=XMG2+XMT2+XMB2+XMR2
51244 XMQ4=XMG*XMT*XMB*XMR
51245 XMQ3=XMG2*XMR2+XMT2*XMB2
51246 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51247 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51248
51249 XMST(1)=AMST(1)*AMST(1)
51250 XMST(2)=AMST(1)*AMST(1)
51251 XMST(3)=AMST(2)*AMST(2)
51252 XMST(4)=AMST(2)*AMST(2)
51253 XMSB(1)=AMSB(1)*AMSB(1)
51254 XMSB(2)=AMSB(2)*AMSB(2)
51255 XMSB(3)=AMSB(1)*AMSB(1)
51256 XMSB(4)=AMSB(2)*AMSB(2)
51257
51258 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51259 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51260 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51261 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51262 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51263 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51264 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51265 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51266
51267 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51268 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51269 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51270 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51271 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51272 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51273 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51274 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51275
51276 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51277 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51278 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51279 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51280 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51281 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51282 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51283 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51284
51285 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51286 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51287 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51288 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51289 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51290 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51291 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51292 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51293
51294 SMAX=(XMG-ABS(XMR))**2
51295 SMIN=(XMB+XMT)**2+0.1D0
51296
51297 DO 120 LIN=0,NN-1
51298 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51299 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51300 GRS=SBAR-XMQ2
51301 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51302 W=DSQRT(W)/2D0/SBAR
51303 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51304 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51305 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51306 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51307 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51308 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51309 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51310 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51311 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51312 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51313 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51314 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51315 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51316 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51317 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51318 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51319 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51320 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51321 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51322 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51323 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51324 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51325 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51326 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51327 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51328 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51329 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51330 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51331 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51332 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51333 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51334 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51335 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51336 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51337 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51338 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51339 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51340 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51341 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51342 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51343 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51344 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51345 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51346 DO 110 J=1,4
51347 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51348 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51349 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51350 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51351 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51352 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51353 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51354 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51355 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51356 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51357 & -A(J,6)*(XMG2+XMR2-SBAR)
51358 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51359 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51360 & /(GRS+XMSB(J)+XMST(J))
51361 110 CONTINUE
51362 120 CONTINUE
51363 SUMME(NN)=0D0
51364 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51365 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51366
51367 RETURN
51368 END
51369
51370C*********************************************************************
51371
51372C...PYNJDC
51373C...Calculates decay widths for the neutralinos (admixtures of
51374C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51375
51376C...Input: KCIN = KF code for particle
51377C...Output: XLAM = widths
51378C... IDLAM = KF codes for decay particles
51379C... IKNT = number of decay channels defined
51380C...AUTHOR: STEPHEN MRENNA
51381C...Last change:
51382C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51383C...when CHIGAMMA .NE. 0
51384C...10 FEB 96: Calculate this decay for small tan(beta)
51385
51386 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51387
51388C...Double precision and integer declarations.
51389 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51390 IMPLICIT INTEGER(I-N)
51391 INTEGER PYK,PYCHGE,PYCOMP
51392C...Parameter statement to help give large particle numbers.
51393 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51394 &KEXCIT=4000000,KDIMEN=5000000)
51395C...Commonblocks.
51396 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51397 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51398 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51399c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51400c &SFMIX(16,4)
51401 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51402 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51403C COMMON/PYINTS/XXM(20)
51404 COMPLEX*16 CXC
51405 COMMON/PYINTC/XXC(10),CXC(8)
51406 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51407
51408C...Local variables.
51409 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51410 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51411 INTEGER KFIN
51412 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51413 &XMZ,XMZ2,AXMJ,AXMI
51414 DOUBLE PRECISION S12MIN,S12MAX
51415 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51416 DOUBLE PRECISION PYLAMF,XL
51417 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51418 DOUBLE PRECISION PYX2XH,PYX2XG
51419 DOUBLE PRECISION XLAM(0:400)
51420 INTEGER IDLAM(400,3)
51421 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51422 INTEGER ITH(3),KF1,KF2
51423 INTEGER ITHC
51424 DOUBLE PRECISION DH(3),EH(3)
51425 DOUBLE PRECISION SR2
51426 DOUBLE PRECISION CBETA,SBETA
51427 DOUBLE PRECISION GAMCON,XMT1,XMT2
51428 DOUBLE PRECISION PYALEM,PI,PYALPS
51429 DOUBLE PRECISION RAT1,RAT2
51430 DOUBLE PRECISION T3T,FCOL
51431 DOUBLE PRECISION ALFA,BETA,TANB
51432 DOUBLE PRECISION PYXXGA
51433 EXTERNAL PYGAUS,PYXXZ6
51434 DOUBLE PRECISION PYGAUS,PYXXZ6
51435 DOUBLE PRECISION PREC
51436 INTEGER KFNCHI(4),KFCCHI(2)
51437 DATA ITH/25,35,36/
51438 DATA ITHC/37/
51439 DATA PREC/1D-2/
51440 DATA PI/3.141592654D0/
51441 DATA SR2/1.4142136D0/
51442 DATA KFNCHI/1000022,1000023,1000025,1000035/
51443 DATA KFCCHI/1000024,1000037/
51444
51445C...COUNT THE NUMBER OF DECAY MODES
51446 LKNT=0
51447
51448 XMW=PMAS(24,1)
51449 XMW2=XMW**2
51450 XMZ=PMAS(23,1)
51451 XMZ2=XMZ**2
51452 XW=1D0-XMW2/XMZ2
51453 XW1=1D0-XW
51454 TANW = SQRT(XW/XW1)
51455
51456C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51457 IX=1
51458 IF(KFIN.EQ.KFNCHI(2)) IX=2
51459 IF(KFIN.EQ.KFNCHI(3)) IX=3
51460 IF(KFIN.EQ.KFNCHI(4)) IX=4
51461
51462 XMI=SMZ(IX)
51463 XMI2=XMI**2
51464 AXMI=ABS(XMI)
51465 AEM=PYALEM(XMI2)
51466 AS =PYALPS(XMI2)
51467 C1=AEM/XW
51468 XMI3=ABS(XMI**3)
51469
51470 TANB=RMSS(5)
51471 BETA=ATAN(TANB)
51472 ALFA=RMSS(18)
51473 CBETA=COS(BETA)
51474 SBETA=TANB*CBETA
51475 CALFA=COS(ALFA)
51476 SALFA=SIN(ALFA)
51477
51478 DO 110 I=1,4
51479 DO 100 J=1,4
51480 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51481 100 CONTINUE
51482 110 CONTINUE
51483 DO 130 I=1,2
51484 DO 120 J=1,2
51485 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51486 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51487 120 CONTINUE
51488 130 CONTINUE
51489
51490C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51491 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51492
51493C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51494 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51495 XMJ=SMZ(1)
51496 AXMJ=ABS(XMJ)
51497 LKNT=LKNT+1
51498 GAMCON=AEM**3/8D0/PI/XMW2/XW
51499 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51500 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51501 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51502 IDLAM(LKNT,1)=KSUSY1+22
51503 IDLAM(LKNT,2)=22
51504 IDLAM(LKNT,3)=0
51505 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51506 GOTO 340
51507 ENDIF
51508
51509C...GRAVITINO DECAY MODES
51510
51511 IF(IMSS(11).EQ.1) THEN
51512 XMP=RMSS(29)
51513 IDG=39+KSUSY1
51514 XMGR=PMAS(PYCOMP(IDG),1)
51515 SINW=SQRT(XW)
51516 COSW=SQRT(1D0-XW)
51517 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51518 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51519 LKNT=LKNT+1
51520 IDLAM(LKNT,1)=IDG
51521 IDLAM(LKNT,2)=22
51522 IDLAM(LKNT,3)=0
51523 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51524 ENDIF
51525 IF(AXMI.GT.XMGR+XMZ) THEN
51526 LKNT=LKNT+1
51527 IDLAM(LKNT,1)=IDG
51528 IDLAM(LKNT,2)=23
51529 IDLAM(LKNT,3)=0
51530 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51531 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51532 & (1D0-XMZ2/XMI2)**4
51533 ENDIF
51534 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51535 LKNT=LKNT+1
51536 IDLAM(LKNT,1)=IDG
51537 IDLAM(LKNT,2)=25
51538 IDLAM(LKNT,3)=0
51539 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51540 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51541 ENDIF
51542 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51543 LKNT=LKNT+1
51544 IDLAM(LKNT,1)=IDG
51545 IDLAM(LKNT,2)=35
51546 IDLAM(LKNT,3)=0
51547 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51548 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51549 ENDIF
51550 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51551 LKNT=LKNT+1
51552 IDLAM(LKNT,1)=IDG
51553 IDLAM(LKNT,2)=36
51554 IDLAM(LKNT,3)=0
51555 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51556 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51557 ENDIF
51558 IF(IX.EQ.1) GOTO 300
51559 ENDIF
51560
51561 DO 220 IJ=1,IX-1
51562 XMJ=SMZ(IJ)
51563 AXMJ=ABS(XMJ)
51564 XMJ2=XMJ**2
51565
51566C...CHI0_I -> CHI0_J + GAMMA
51567 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51568 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51569 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51570 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51571 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51572 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51573 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51574 LKNT=LKNT+1
51575 IDLAM(LKNT,1)=KFNCHI(IJ)
51576 IDLAM(LKNT,2)=22
51577 IDLAM(LKNT,3)=0
51578 GAMCON=AEM**3/8D0/PI/XMW2/XW
51579 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51580 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51581 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51582 ENDIF
51583 ENDIF
51584
51585C...CHI0_I -> CHI0_J + Z0
51586 IF(AXMI.GE.AXMJ+XMZ) THEN
51587 LKNT=LKNT+1
51588 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51589 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51590 ORPP=-DCONJG(OLPP)
51591 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51592 GLR=DBLE(OLPP*DCONJG(ORPP))
51593 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51594 IDLAM(LKNT,1)=KFNCHI(IJ)
51595 IDLAM(LKNT,2)=23
51596 IDLAM(LKNT,3)=0
51597 ELSEIF(AXMI.GE.AXMJ) THEN
51598 XXC(1)=0D0
51599 XXC(2)=XMJ
51600 XXC(3)=0D0
51601 XXC(4)=XMI
51602 XXC(9)=XMZ
51603 XXC(10)=PMAS(23,2)
51604 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51605 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51606 ORPP=DCONJG(OLPP)
51607C...CHARGED LEPTONS
51608 FID=11
51609 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51610 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51611 EI=KCHG(FID,1)/3D0
51612 T3I=SIGN(1D0,EI+1D-6)/2D0
51613 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51614 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51615 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51616 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51617 CXC(2)=-GLIJ
51618 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51619 CXC(4)=DCONJG(GLIJ)
51620 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51621 CXC(6)=GRIJ
51622 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51623 CXC(8)=-DCONJG(GRIJ)
51624 S12MIN=0D0
51625 S12MAX=(AXMI-AXMJ)**2
51626 IF( XXC(5).LT.AXMI ) THEN
51627 XXC(5)=1D6
51628 ENDIF
51629 IF(XXC(6).LT.AXMI ) THEN
51630 XXC(6)=1D6
51631 ENDIF
51632 XXC(7)=XXC(5)
51633 XXC(8)=XXC(6)
51634
51635 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51636 LKNT=LKNT+1
51637 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51638 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51639 IDLAM(LKNT,1)=KFNCHI(IJ)
51640 IDLAM(LKNT,2)=FID
51641 IDLAM(LKNT,3)=-FID
51642 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51643 LKNT=LKNT+1
51644 XLAM(LKNT)=XLAM(LKNT-1)
51645 IDLAM(LKNT,1)=KFNCHI(IJ)
51646 IDLAM(LKNT,2)=13
51647 IDLAM(LKNT,3)=-13
51648 ENDIF
51649 ENDIF
51650 140 CONTINUE
51651 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51652 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51653 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51654 ELSE
51655 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51656 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51657 ENDIF
51658 IF( XXC(5).LT.AXMI ) THEN
51659 XXC(5)=1D6
51660 ENDIF
51661 IF(XXC(6).LT.AXMI ) THEN
51662 XXC(6)=1D6
51663 ENDIF
51664 XXC(7)=XXC(5)
51665 XXC(8)=XXC(6)
51666
51667 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51668 LKNT=LKNT+1
51669 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51670 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51671 IDLAM(LKNT,1)=KFNCHI(IJ)
51672 IDLAM(LKNT,2)=15
51673 IDLAM(LKNT,3)=-15
51674 ENDIF
51675
51676C...NEUTRINOS
51677 150 CONTINUE
51678 FID=12
51679 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51680 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51681 EI=KCHG(FID,1)/3D0
51682 T3I=SIGN(1D0,EI+1D-6)/2D0
51683 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51684 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51685 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51686 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51687 CXC(2)=-GLIJ
51688 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51689 CXC(4)=DCONJG(GLIJ)
51690 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51691 CXC(6)=GRIJ
51692 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51693 CXC(8)=-DCONJG(GRIJ)
51694 S12MIN=0D0
51695 S12MAX=(AXMI-AXMJ)**2
51696 IF( XXC(5).LT.AXMI ) THEN
51697 XXC(5)=1D6
51698 ENDIF
51699 IF( XXC(6).LT.AXMI ) THEN
51700 XXC(6)=1D6
51701 ENDIF
51702 XXC(7)=XXC(5)
51703 XXC(8)=XXC(6)
51704
51705 LKNT=LKNT+1
51706 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51707 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51708 IDLAM(LKNT,1)=KFNCHI(IJ)
51709 IDLAM(LKNT,2)=12
51710 IDLAM(LKNT,3)=-12
51711 LKNT=LKNT+1
51712 XLAM(LKNT)=XLAM(LKNT-1)
51713 IDLAM(LKNT,1)=KFNCHI(IJ)
51714 IDLAM(LKNT,2)=14
51715 IDLAM(LKNT,3)=-14
51716 160 CONTINUE
51717
51718 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51719 & THEN
51720 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51721 IF( XXC(5).LT.AXMI ) THEN
51722 XXC(5)=1D6
51723 ENDIF
51724 XXC(7)=XXC(5)
51725 LKNT=LKNT+1
51726 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51727 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51728 ELSE
51729 LKNT=LKNT+1
51730 XLAM(LKNT)=XLAM(LKNT-1)
51731 ENDIF
51732 IDLAM(LKNT,1)=KFNCHI(IJ)
51733 IDLAM(LKNT,2)=16
51734 IDLAM(LKNT,3)=-16
51735C...D-TYPE QUARKS
51736 170 CONTINUE
51737 FID=1
51738 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51739 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51740 EI=KCHG(FID,1)/3D0
51741 T3I=SIGN(1D0,EI+1D-6)/2D0
51742 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51743 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51744 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51745 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51746 CXC(2)=-GLIJ
51747 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51748 CXC(4)=DCONJG(GLIJ)
51749 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51750 CXC(6)=GRIJ
51751 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51752 CXC(8)=-DCONJG(GRIJ)
51753 S12MIN=0D0
51754 S12MAX=(AXMI-AXMJ)**2
51755 IF( XXC(5).LT.AXMI ) THEN
51756 XXC(5)=1D6
51757 ENDIF
51758 IF( XXC(6).LT.AXMI ) THEN
51759 XXC(6)=1D6
51760 ENDIF
51761 XXC(7)=XXC(5)
51762 XXC(8)=XXC(6)
51763
51764 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51765 LKNT=LKNT+1
51766 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51767 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51768 IDLAM(LKNT,1)=KFNCHI(IJ)
51769 IDLAM(LKNT,2)=1
51770 IDLAM(LKNT,3)=-1
51771 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51772 LKNT=LKNT+1
51773 XLAM(LKNT)=XLAM(LKNT-1)
51774 IDLAM(LKNT,1)=KFNCHI(IJ)
51775 IDLAM(LKNT,2)=3
51776 IDLAM(LKNT,3)=-3
51777 ENDIF
51778 ENDIF
51779 180 CONTINUE
51780 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51781 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51782 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51783 ELSE
51784 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51785 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51786 ENDIF
51787 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51788 IF(XXC(5).LT.AXMI) THEN
51789 XXC(5)=1D6
51790 ELSEIF(XXC(6).LT.AXMI) THEN
51791 XXC(6)=1D6
51792 ENDIF
51793 XXC(7)=XXC(5)
51794 XXC(8)=XXC(6)
51795 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51796 LKNT=LKNT+1
51797 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51798 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51799 IDLAM(LKNT,1)=KFNCHI(IJ)
51800 IDLAM(LKNT,2)=5
51801 IDLAM(LKNT,3)=-5
51802 ENDIF
51803
51804C...U-TYPE QUARKS
51805 190 CONTINUE
51806 FID=2
51807 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51808 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51809 EI=KCHG(FID,1)/3D0
51810 T3I=SIGN(1D0,EI+1D-6)/2D0
51811 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51812 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51813 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51814 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51815 CXC(2)=-GLIJ
51816 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51817 CXC(4)=DCONJG(GLIJ)
51818 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51819 CXC(6)=GRIJ
51820 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51821 CXC(8)=-DCONJG(GRIJ)
51822
51823 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51824 IF(XXC(5).LT.AXMI) THEN
51825 XXC(5)=1D6
51826 ELSEIF(XXC(6).LT.AXMI) THEN
51827 XXC(6)=1D6
51828 ENDIF
51829 XXC(7)=XXC(5)
51830 XXC(8)=XXC(6)
51831
51832 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51833 LKNT=LKNT+1
51834 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51835 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51836 IDLAM(LKNT,1)=KFNCHI(IJ)
51837 IDLAM(LKNT,2)=2
51838 IDLAM(LKNT,3)=-2
51839 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51840 LKNT=LKNT+1
51841 XLAM(LKNT)=XLAM(LKNT-1)
51842 IDLAM(LKNT,1)=KFNCHI(IJ)
51843 IDLAM(LKNT,2)=4
51844 IDLAM(LKNT,3)=-4
51845 ENDIF
51846 ENDIF
51847 200 CONTINUE
51848 ENDIF
51849
51850C...CHI0_I -> CHI0_J + H0_K
51851 EH(1)=SIN(ALFA)
51852 EH(2)=COS(ALFA)
51853 EH(3)=-SIN(BETA)
51854 DH(1)=COS(ALFA)
51855 DH(2)=-SIN(ALFA)
51856 DH(3)=COS(BETA)
51857 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51858 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51859 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51860 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51861 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51862 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51863 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51864 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51865 DO 210 IH=1,3
51866 XMH=PMAS(ITH(IH),1)
51867 XMH2=XMH**2
51868 IF(AXMI.GE.AXMJ+XMH) THEN
51869 LKNT=LKNT+1
51870 XL=PYLAMF(XMI2,XMJ2,XMH2)
51871 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51872 F12K=F21K
51873C...SIGN OF MASSES I,J
51874 XMK=XMJ
51875 IF(IH.EQ.3) XMK=-XMK
51876 GX2=ABS(F21K)**2+ABS(F12K)**2
51877 GLR=DBLE(F21K*DCONJG(F12K))
51878 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51879 IDLAM(LKNT,1)=KFNCHI(IJ)
51880 IDLAM(LKNT,2)=ITH(IH)
51881 IDLAM(LKNT,3)=0
51882 ENDIF
51883 210 CONTINUE
51884 220 CONTINUE
51885
51886C...CHI0_I -> CHI+_J + W-
51887 DO 260 IJ=1,2
51888 XMJ=SMW(IJ)
51889 AXMJ=ABS(XMJ)
51890 XMJ2=XMJ**2
51891 IF(AXMI.GE.AXMJ+XMW) THEN
51892 LKNT=LKNT+1
51893 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51894 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51895 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51896 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51897 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51898 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51899 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51900 IDLAM(LKNT,1)=KFCCHI(IJ)
51901 IDLAM(LKNT,2)=-24
51902 IDLAM(LKNT,3)=0
51903 LKNT=LKNT+1
51904 XLAM(LKNT)=XLAM(LKNT-1)
51905 IDLAM(LKNT,1)=-KFCCHI(IJ)
51906 IDLAM(LKNT,2)=24
51907 IDLAM(LKNT,3)=0
51908 ELSEIF(AXMI.GE.AXMJ) THEN
51909 S12MIN=0D0
51910 S12MAX=(AXMI-AXMJ)**2
51911 RT2I = 1D0/SQRT(2D0)
51912 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51913 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51914 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51915 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51916 CXC(5)=DCMPLX(0D0,0D0)
51917 CXC(7)=DCMPLX(0D0,0D0)
51918 IA=11
51919 JA=12
51920 EI=KCHG(IA,1)/3D0
51921 T3I=SIGN(1D0,EI+1D-6)/2D0
51922 EJ=KCHG(JA,1)/3D0
51923 T3J=SIGN(1D0,EJ+1D-6)/2D0
51924 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51925 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51926 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51927 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51928 CXC(6)=DCMPLX(0D0,0D0)
51929 CXC(8)=DCMPLX(0D0,0D0)
51930 XXC(1)=0D0
51931 XXC(2)=XMJ
51932 XXC(3)=0D0
51933 XXC(4)=XMI
51934 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51935 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51936 XXC(9)=PMAS(24,1)
51937 XXC(10)=PMAS(24,2)
51938 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51939 IF(XXC(5).LT.AXMI) THEN
51940 XXC(5)=1D6
51941 ELSEIF(XXC(6).LT.AXMI) THEN
51942 XXC(6)=1D6
51943 ENDIF
51944 XXC(7)=XXC(6)
51945 XXC(8)=XXC(5)
51946 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51947 LKNT=LKNT+1
51948 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51949 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51950 IDLAM(LKNT,1)=KFCCHI(IJ)
51951 IDLAM(LKNT,2)=11
51952 IDLAM(LKNT,3)=-12
51953 LKNT=LKNT+1
51954 XLAM(LKNT)=XLAM(LKNT-1)
51955 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51956 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51957 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51958 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51959 LKNT=LKNT+1
51960 XLAM(LKNT)=XLAM(LKNT-1)
51961 IDLAM(LKNT,1)=KFCCHI(IJ)
51962 IDLAM(LKNT,2)=13
51963 IDLAM(LKNT,3)=-14
51964 LKNT=LKNT+1
51965 XLAM(LKNT)=XLAM(LKNT-1)
51966 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51967 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51968 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51969 ENDIF
51970 ENDIF
51971 230 CONTINUE
51972 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51973 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51974 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51975 ELSE
51976 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51977 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51978 ENDIF
51979 IF(XXC(5).LT.AXMI) THEN
51980 XXC(5)=1D6
51981 ENDIF
51982 IF(XXC(6).LT.AXMI) THEN
51983 XXC(6)=1D6
51984 ENDIF
51985 XXC(7)=XXC(6)
51986 XXC(8)=XXC(5)
51987 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51988 LKNT=LKNT+1
51989 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51990 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51991 XLAM(LKNT)=XLAM(LKNT-1)
51992 IDLAM(LKNT,1)=KFCCHI(IJ)
51993 IDLAM(LKNT,2)=15
51994 IDLAM(LKNT,3)=-16
51995 LKNT=LKNT+1
51996 XLAM(LKNT)=XLAM(LKNT-1)
51997 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51998 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51999 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52000 ENDIF
52001
52002C...NOW, DO THE QUARKS
52003 240 CONTINUE
52004 IA=1
52005 JA=2
52006 EI=KCHG(IA,1)/3D0
52007 T3I=SIGN(1D0,EI+1D-6)/2D0
52008 EJ=KCHG(JA,1)/3D0
52009 T3J=SIGN(1D0,EJ+1D-6)/2D0
52010 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52011 & TANW+ZMIXC(IX,2)*T3J)
52012 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52013 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52014 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52015 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52016 IF(XXC(5).LT.AXMI) THEN
52017 XXC(5)=1D6
52018 ENDIF
52019 IF(XXC(6).LT.AXMI) THEN
52020 XXC(6)=1D6
52021 ENDIF
52022 XXC(7)=XXC(6)
52023 XXC(8)=XXC(5)
52024 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52025 LKNT=LKNT+1
52026 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52027 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52028 IDLAM(LKNT,1)=KFCCHI(IJ)
52029 IDLAM(LKNT,2)=1
52030 IDLAM(LKNT,3)=-2
52031 LKNT=LKNT+1
52032 XLAM(LKNT)=XLAM(LKNT-1)
52033 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52034 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52035 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52036 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52037 LKNT=LKNT+1
52038 XLAM(LKNT)=XLAM(LKNT-1)
52039 IDLAM(LKNT,1)=KFCCHI(IJ)
52040 IDLAM(LKNT,2)=3
52041 IDLAM(LKNT,3)=-4
52042 LKNT=LKNT+1
52043 XLAM(LKNT)=XLAM(LKNT-1)
52044 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52045 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52046 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52047 ENDIF
52048 ENDIF
52049 250 CONTINUE
52050 ENDIF
52051 260 CONTINUE
52052 270 CONTINUE
52053
52054C...CHI0_I -> CHI+_I + H-
52055 DO 280 IJ=1,2
52056 XMJ=SMW(IJ)
52057 AXMJ=ABS(XMJ)
52058 XMJ2=XMJ**2
52059 XMHP=PMAS(ITHC,1)
52060 IF(AXMI.GE.AXMJ+XMHP) THEN
52061 LKNT=LKNT+1
52062 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52063 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52064 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52065 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52066 & UMIXC(IJ,2)/SR2)
52067 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52068 GLR=DBLE(OLPP*DCONJG(ORPP))
52069 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52070 IDLAM(LKNT,1)=KFCCHI(IJ)
52071 IDLAM(LKNT,2)=-ITHC
52072 IDLAM(LKNT,3)=0
52073 LKNT=LKNT+1
52074 XLAM(LKNT)=XLAM(LKNT-1)
52075 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52076 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52077 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52078 ELSE
52079
52080 ENDIF
52081 280 CONTINUE
52082
52083C...2-BODY DECAYS TO FERMION SFERMION
52084 DO 290 J=1,16
52085 IF(J.GE.7.AND.J.LE.10) GOTO 290
52086 KF1=KSUSY1+J
52087 KF2=KSUSY2+J
52088 XMSF1=PMAS(PYCOMP(KF1),1)
52089 XMSF2=PMAS(PYCOMP(KF2),1)
52090 XMF=PMAS(J,1)
52091 IF(J.LE.6) THEN
52092 FCOL=3D0
52093 ELSE
52094 FCOL=1D0
52095 ENDIF
52096
52097 EI=KCHG(J,1)/3D0
52098 T3T=SIGN(1D0,EI)
52099 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52100 IF(MOD(J,2).EQ.0) THEN
52101 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52102 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52103 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52104 CBR=CAL
52105 ELSE
52106 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52107 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52108 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52109 CBR=CAL
52110 ENDIF
52111
52112C...D~ D_L
52113 IF(AXMI.GE.XMF+XMSF1) THEN
52114 LKNT=LKNT+1
52115 XMA2=XMSF1**2
52116 XMB2=XMF**2
52117 XL=PYLAMF(XMI2,XMA2,XMB2)
52118 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52119 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52120 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52121 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52122 IDLAM(LKNT,1)=KF1
52123 IDLAM(LKNT,2)=-J
52124 IDLAM(LKNT,3)=0
52125 LKNT=LKNT+1
52126 XLAM(LKNT)=XLAM(LKNT-1)
52127 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52128 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52129 IDLAM(LKNT,3)=0
52130 ENDIF
52131
52132C...D~ D_R
52133 IF(AXMI.GE.XMF+XMSF2) THEN
52134 LKNT=LKNT+1
52135 XMA2=XMSF2**2
52136 XMB2=XMF**2
52137 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52138 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52139 XL=PYLAMF(XMI2,XMA2,XMB2)
52140 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52141 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52142 IDLAM(LKNT,1)=KF2
52143 IDLAM(LKNT,2)=-J
52144 IDLAM(LKNT,3)=0
52145 LKNT=LKNT+1
52146 XLAM(LKNT)=XLAM(LKNT-1)
52147 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52148 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52149 IDLAM(LKNT,3)=0
52150 ENDIF
52151 290 CONTINUE
52152 300 CONTINUE
52153C...3-BODY DECAY TO Q Q~ GLUINO
52154 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52155 IF(AXMI.GE.XMJ) THEN
52156 RT2I = 1D0/SQRT(2D0)
52157 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52158 ORPP=DCONJG(OLPP)
52159 AXMJ=ABS(XMJ)
52160 XXC(1)=0D0
52161 XXC(2)=XMJ
52162 XXC(3)=0D0
52163 XXC(4)=XMI
52164 FID=1
52165 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52166 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52167 XXC(7)=XXC(5)
52168 XXC(8)=XXC(6)
52169 XXC(9)=1D6
52170 XXC(10)=0D0
52171 EI=KCHG(FID,1)/3D0
52172 T3I=SIGN(1D0,EI+1D-6)/2D0
52173 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52174 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52175 CXC(1)=0D0
52176 CXC(2)=-GLIJ
52177 CXC(3)=0D0
52178 CXC(4)=DCONJG(GLIJ)
52179 CXC(5)=0D0
52180 CXC(6)=GRIJ
52181 CXC(7)=0D0
52182 CXC(8)=-DCONJG(GRIJ)
52183 S12MIN=0D0
52184 S12MAX=(AXMI-AXMJ)**2
52185CMRENNA.This statement must be here to define S12MAX
52186 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52187C...ALL QUARKS BUT T
52188 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52189 LKNT=LKNT+1
52190 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52191 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52192 IDLAM(LKNT,1)=KSUSY1+21
52193 IDLAM(LKNT,2)=1
52194 IDLAM(LKNT,3)=-1
52195 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52196 LKNT=LKNT+1
52197 XLAM(LKNT)=XLAM(LKNT-1)
52198 IDLAM(LKNT,1)=KSUSY1+21
52199 IDLAM(LKNT,2)=3
52200 IDLAM(LKNT,3)=-3
52201 ENDIF
52202 ENDIF
52203 310 CONTINUE
52204 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52205 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52206 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52207 ELSE
52208 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52209 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52210 ENDIF
52211 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52212 XXC(7)=XXC(5)
52213 XXC(8)=XXC(6)
52214 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52215 LKNT=LKNT+1
52216 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52217 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52218 IDLAM(LKNT,1)=KSUSY1+21
52219 IDLAM(LKNT,2)=5
52220 IDLAM(LKNT,3)=-5
52221 ENDIF
52222C...U-TYPE QUARKS
52223 320 CONTINUE
52224 FID=2
52225 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52226 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52227 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52228 XXC(7)=XXC(5)
52229 XXC(8)=XXC(6)
52230 EI=KCHG(FID,1)/3D0
52231 T3I=SIGN(1D0,EI+1D-6)/2D0
52232 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52233 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52234 CXC(2)=-GLIJ
52235 CXC(4)=DCONJG(GLIJ)
52236 CXC(6)=GRIJ
52237 CXC(8)=-DCONJG(GRIJ)
52238 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52239 LKNT=LKNT+1
52240 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52241 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52242 IDLAM(LKNT,1)=KSUSY1+21
52243 IDLAM(LKNT,2)=2
52244 IDLAM(LKNT,3)=-2
52245 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52246 LKNT=LKNT+1
52247 XLAM(LKNT)=XLAM(LKNT-1)
52248 IDLAM(LKNT,1)=KSUSY1+21
52249 IDLAM(LKNT,2)=4
52250 IDLAM(LKNT,3)=-4
52251 ENDIF
52252 ENDIF
52253 330 CONTINUE
52254 ENDIF
52255
52256C...R-violating decay modes (SKANDS).
52257 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52258
52259 340 IKNT=LKNT
52260 XLAM(0)=0D0
52261 DO 350 I=1,IKNT
52262 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52263 XLAM(0)=XLAM(0)+XLAM(I)
52264 350 CONTINUE
52265 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52266
52267 RETURN
52268 END
52269
52270C*********************************************************************
52271
52272C...PYCJDC
52273C...Calculate decay widths for the charginos (admixtures of
52274C...charged Wino and charged Higgsino.
52275
52276C...Input: KCIN = KF code for particle
52277C...Output: XLAM = widths
52278C... IDLAM = KF codes for decay particles
52279C... IKNT = number of decay channels defined
52280C...AUTHOR: STEPHEN MRENNA
52281C...Last change:
52282C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52283C...when CHIENU .NE. 0
52284
52285 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52286
52287C...Double precision and integer declarations.
52288 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52289 IMPLICIT INTEGER(I-N)
52290 INTEGER PYK,PYCHGE,PYCOMP
52291C...Parameter statement to help give large particle numbers.
52292 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52293 &KEXCIT=4000000,KDIMEN=5000000)
52294C...Commonblocks.
52295 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52296 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52297 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52298 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52299 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52300CC &SFMIX(16,4),
52301C COMMON/PYINTS/XXM(20)
52302 COMPLEX*16 CXC
52303 COMMON/PYINTC/XXC(10),CXC(8)
52304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52305
52306C...Local variables
52307 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52308 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52309 INTEGER KFIN,KCIN
52310 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52311 &XMZ,XMZ2,AXMJ,AXMI
52312 DOUBLE PRECISION S12MIN,S12MAX
52313 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52314 DOUBLE PRECISION PYLAMF,XL
52315 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52316 DOUBLE PRECISION PYX2XH,PYX2XG
52317 DOUBLE PRECISION XLAM(0:400)
52318 INTEGER IDLAM(400,3)
52319 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52320 INTEGER ITH(3)
52321 INTEGER ITHC
52322 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52323 DOUBLE PRECISION SR2
52324 DOUBLE PRECISION CBETA,SBETA,TANB
52325
52326 DOUBLE PRECISION PYALEM,PI,PYALPS
52327 DOUBLE PRECISION FCOL
52328 INTEGER KF1,KF2,ISF
52329 INTEGER KFNCHI(4),KFCCHI(2)
52330
52331 DOUBLE PRECISION TEMP
52332 EXTERNAL PYGAUS,PYXXZ6
52333 DOUBLE PRECISION PYGAUS,PYXXZ6
52334 DOUBLE PRECISION PREC
52335 DATA ITH/25,35,36/
52336 DATA ITHC/37/
52337 DATA ETAH/1D0,1D0,-1D0/
52338 DATA SR2/1.4142136D0/
52339 DATA PI/3.141592654D0/
52340 DATA PREC/1D-2/
52341 DATA KFNCHI/1000022,1000023,1000025,1000035/
52342 DATA KFCCHI/1000024,1000037/
52343
52344C...COUNT THE NUMBER OF DECAY MODES
52345 LKNT=0
52346 XMW=PMAS(24,1)
52347 XMW2=XMW**2
52348 XMZ=PMAS(23,1)
52349 XMZ2=XMZ**2
52350 XW=1D0-XMW2/XMZ2
52351 XW1=1D0-XW
52352 TANW = SQRT(XW/XW1)
52353
52354C...1 OR 2 DEPENDING ON CHARGINO TYPE
52355 IX=1
52356 IF(KFIN.EQ.KFCCHI(2)) IX=2
52357 KCIN=PYCOMP(KFIN)
52358
52359 XMI=SMW(IX)
52360 XMI2=XMI**2
52361 AXMI=ABS(XMI)
52362 AEM=PYALEM(XMI2)
52363 AS =PYALPS(XMI2)
52364 C1=AEM/XW
52365 XMI3=ABS(XMI**3)
52366 TANB=RMSS(5)
52367 BETA=ATAN(TANB)
52368 CBETA=COS(BETA)
52369 SBETA=TANB*CBETA
52370 ALFA=RMSS(18)
52371
52372 DO 110 I=1,2
52373 DO 100 J=1,2
52374 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52375 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52376 100 CONTINUE
52377 110 CONTINUE
52378
52379C...GRAVITINO DECAY MODES
52380
52381 IF(IMSS(11).EQ.1) THEN
52382 XMP=RMSS(29)
52383 IDG=39+KSUSY1
52384 XMGR=PMAS(PYCOMP(IDG),1)
52385C SINW=SQRT(XW)
52386C COSW=SQRT(1D0-XW)
52387 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52388 IF(AXMI.GT.XMGR+XMW) THEN
52389 LKNT=LKNT+1
52390 IDLAM(LKNT,1)=IDG
52391 IDLAM(LKNT,2)=24
52392 IDLAM(LKNT,3)=0
52393 XLAM(LKNT)=XFAC*(
52394 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52395 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52396 & (1D0-XMW2/XMI2)**4
52397 ENDIF
52398 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52399 LKNT=LKNT+1
52400 IDLAM(LKNT,1)=IDG
52401 IDLAM(LKNT,2)=37
52402 IDLAM(LKNT,3)=0
52403 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52404 & (ABS(UMIXC(IX,2))*SBETA)**2))
52405 & *(1D0-PMAS(37,1)**2/XMI2)**4
52406 ENDIF
52407 ENDIF
52408
52409C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52410 IF(IX.EQ.1) GOTO 170
52411 XMJ=SMW(1)
52412 AXMJ=ABS(XMJ)
52413 XMJ2=XMJ**2
52414
52415C...CHI_2+ -> CHI_1+ + Z0
52416 IF(AXMI.GE.AXMJ+XMZ) THEN
52417 LKNT=LKNT+1
52418 IJ=1
52419 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52420 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52421 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52422 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52423 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52424 GLR=DBLE(OLPP*DCONJG(ORPP))
52425 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52426 IDLAM(LKNT,1)=KFCCHI(1)
52427 IDLAM(LKNT,2)=23
52428 IDLAM(LKNT,3)=0
52429
52430C...CHARGED LEPTONS
52431 ELSEIF(AXMI.GE.AXMJ) THEN
52432 S12MIN=0D0
52433 S12MAX=(AXMI-AXMJ)**2
52434 IA=11
52435 JA=12
52436 EI=KCHG(IABS(IA),1)/3D0
52437 T3I=SIGN(1D0,EI+1D-6)/2D0
52438 XXC(1)=0D0
52439 XXC(2)=XMJ
52440 XXC(3)=0D0
52441 XXC(4)=XMI
52442 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52443 XXC(6)=1D6
52444 XXC(9)=PMAS(23,1)
52445 XXC(10)=PMAS(23,2)
52446 IJ=1
52447 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52448 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52449 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52450 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52451 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52452 CXC(2)=DCMPLX(0D0,0D0)
52453 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52454 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52455 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52456 CXC(6)=DCMPLX(0D0,0D0)
52457 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52458 CXC(8)=DCMPLX(0D0,0D0)
52459 IF( XXC(5).LT.AXMI ) THEN
52460 XXC(5)=1D6
52461 ENDIF
52462 XXC(7)=XXC(5)
52463 XXC(8)=XXC(6)
52464 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52465 LKNT=LKNT+1
52466 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52467 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52468 IDLAM(LKNT,1)=KFCCHI(1)
52469 IDLAM(LKNT,2)=11
52470 IDLAM(LKNT,3)=-11
52471 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52472 LKNT=LKNT+1
52473 XLAM(LKNT)=XLAM(LKNT-1)
52474 IDLAM(LKNT,1)=KFCCHI(1)
52475 IDLAM(LKNT,2)=13
52476 IDLAM(LKNT,3)=-13
52477 ENDIF
52478 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52479 LKNT=LKNT+1
52480 XLAM(LKNT)=XLAM(LKNT-1)
52481 IDLAM(LKNT,1)=KFCCHI(1)
52482 IDLAM(LKNT,2)=15
52483 IDLAM(LKNT,3)=-15
52484 ENDIF
52485 ENDIF
52486
52487C...NEUTRINOS
52488 120 CONTINUE
52489 IA=12
52490 JA=11
52491 EI=KCHG(IABS(IA),1)/3D0
52492 T3I=SIGN(1D0,EI+1D-6)/2D0
52493 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52494 XXC(6)=1D6
52495 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52496 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52497 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52498 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52499 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52500 IF( XXC(5).LT.AXMI ) THEN
52501 XXC(5)=1D6
52502 ENDIF
52503 XXC(7)=XXC(5)
52504 XXC(8)=XXC(6)
52505 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52506 LKNT=LKNT+1
52507 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52508 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52509 IDLAM(LKNT,1)=KFCCHI(1)
52510 IDLAM(LKNT,2)=12
52511 IDLAM(LKNT,3)=-12
52512 LKNT=LKNT+1
52513 XLAM(LKNT)=XLAM(LKNT-1)
52514 IDLAM(LKNT,1)=KFCCHI(1)
52515 IDLAM(LKNT,2)=14
52516 IDLAM(LKNT,3)=-14
52517 ENDIF
52518 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52519 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52520 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52521 ELSE
52522 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52523 ENDIF
52524 IF( XXC(5).LT.AXMI ) THEN
52525 XXC(5)=1D6
52526 ENDIF
52527 XXC(7)=XXC(5)
52528 LKNT=LKNT+1
52529 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52530 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52531 IDLAM(LKNT,1)=KFCCHI(1)
52532 IDLAM(LKNT,2)=16
52533 IDLAM(LKNT,3)=-16
52534 ENDIF
52535
52536C...D-TYPE QUARKS
52537 130 CONTINUE
52538 IA=1
52539 JA=2
52540 EI=KCHG(IABS(IA),1)/3D0
52541 T3I=SIGN(1D0,EI+1D-6)/2D0
52542 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52543 XXC(6)=1D6
52544 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52545 CXC(2)=DCMPLX(0D0,0D0)
52546 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52547 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52548 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52549 CXC(6)=DCMPLX(0D0,0D0)
52550 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52551 CXC(8)=DCMPLX(0D0,0D0)
52552 IF( XXC(5).LT.AXMI ) THEN
52553 XXC(5)=1D6
52554 ENDIF
52555 XXC(7)=XXC(5)
52556 XXC(8)=XXC(6)
52557 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52558 LKNT=LKNT+1
52559 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52560 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52561 IDLAM(LKNT,1)=KFCCHI(1)
52562 IDLAM(LKNT,2)=1
52563 IDLAM(LKNT,3)=-1
52564 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52565 LKNT=LKNT+1
52566 XLAM(LKNT)=XLAM(LKNT-1)
52567 IDLAM(LKNT,1)=KFCCHI(1)
52568 IDLAM(LKNT,2)=3
52569 IDLAM(LKNT,3)=-3
52570 ENDIF
52571 ENDIF
52572 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52573 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52574 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52575 ELSE
52576 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52577 ENDIF
52578 IF( XXC(5).LT.AXMI ) THEN
52579 XXC(5)=1D6
52580 ENDIF
52581 XXC(7)=XXC(5)
52582 LKNT=LKNT+1
52583 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52584 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52585 IDLAM(LKNT,1)=KFCCHI(1)
52586 IDLAM(LKNT,2)=5
52587 IDLAM(LKNT,3)=-5
52588 ENDIF
52589
52590C...U-TYPE QUARKS
52591 140 CONTINUE
52592 IA=2
52593 JA=1
52594 EI=KCHG(IABS(IA),1)/3D0
52595 T3I=SIGN(1D0,EI+1D-6)/2D0
52596 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52597 XXC(6)=1D6
52598 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52599 CXC(2)=DCMPLX(0D0,0D0)
52600 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52601 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52602 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52603 CXC(6)=DCMPLX(0D0,0D0)
52604 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52605 CXC(8)=DCMPLX(0D0,0D0)
52606 IF( XXC(5).LT.AXMI ) THEN
52607 XXC(5)=1D6
52608 ENDIF
52609 XXC(7)=XXC(5)
52610 XXC(8)=XXC(6)
52611 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52612 LKNT=LKNT+1
52613 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52614 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52615 IDLAM(LKNT,1)=KFCCHI(1)
52616 IDLAM(LKNT,2)=2
52617 IDLAM(LKNT,3)=-2
52618 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52619 LKNT=LKNT+1
52620 XLAM(LKNT)=XLAM(LKNT-1)
52621 IDLAM(LKNT,1)=KFCCHI(1)
52622 IDLAM(LKNT,2)=4
52623 IDLAM(LKNT,3)=-4
52624 ENDIF
52625 ENDIF
52626 150 CONTINUE
52627 ENDIF
52628
52629C...CHI_2+ -> CHI_1+ + H0_K
52630 EH(2)=COS(ALFA)
52631 EH(1)=SIN(ALFA)
52632 EH(3)=-SBETA
52633 DH(2)=-SIN(ALFA)
52634 DH(1)=COS(ALFA)
52635 DH(3)=COS(BETA)
52636 DO 160 IH=1,3
52637 XMH=PMAS(ITH(IH),1)
52638 XMH2=XMH**2
52639C...NO 3-BODY OPTION
52640 IF(AXMI.GE.AXMJ+XMH) THEN
52641 LKNT=LKNT+1
52642 XL=PYLAMF(XMI2,XMJ2,XMH2)
52643 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52644 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52645 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52646 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52647 XMK=XMJ*ETAH(IH)
52648 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52649 GLR=DBLE(OLPP*DCONJG(ORPP))
52650 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52651 IDLAM(LKNT,1)=KFCCHI(1)
52652 IDLAM(LKNT,2)=ITH(IH)
52653 IDLAM(LKNT,3)=0
52654 ENDIF
52655 160 CONTINUE
52656
52657C...CHI1 JUMPS TO HERE
52658 170 CONTINUE
52659
52660C...CHI+_I -> CHI0_J + W+
52661 DO 220 IJ=1,4
52662 XMJ=SMZ(IJ)
52663 AXMJ=ABS(XMJ)
52664 XMJ2=XMJ**2
52665 IF(AXMI.GE.AXMJ+XMW) THEN
52666 LKNT=LKNT+1
52667 DO 180 I=1,4
52668 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52669 180 CONTINUE
52670 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52671 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52672 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52673 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52674 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52675 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52676 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52677 IDLAM(LKNT,1)=KFNCHI(IJ)
52678 IDLAM(LKNT,2)=24
52679 IDLAM(LKNT,3)=0
52680C...LEPTONS
52681 ELSEIF(AXMI.GE.AXMJ) THEN
52682 S12MIN=0D0
52683 S12MAX=(AXMI-AXMJ)**2
52684 DO 190 I=1,4
52685 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52686 190 CONTINUE
52687 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52688 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52689 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52690 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52691 CXC(5)=DCMPLX(0D0,0D0)
52692 CXC(7)=DCMPLX(0D0,0D0)
52693 IA=11
52694 JA=12
52695 EI=KCHG(IA,1)/3D0
52696 T3I=SIGN(1D0,EI+1D-6)/2D0
52697 EJ=KCHG(JA,1)/3D0
52698 T3J=SIGN(1D0,EJ+1D-6)/2D0
52699 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52700 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52701 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52702 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52703 CXC(6)=DCMPLX(0D0,0D0)
52704 CXC(8)=DCMPLX(0D0,0D0)
52705 XXC(1)=0D0
52706 XXC(2)=XMJ
52707 XXC(3)=0D0
52708 XXC(4)=XMI
52709 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52710 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52711 XXC(9)=PMAS(24,1)
52712 XXC(10)=PMAS(24,2)
52713CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52714 IF(XXC(5).LT.AXMI) THEN
52715 XXC(5)=1D6
52716 ELSEIF(XXC(6).LT.AXMI) THEN
52717 XXC(6)=1D6
52718 ENDIF
52719 XXC(7)=XXC(6)
52720 XXC(8)=XXC(5)
52721C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52722C...--> 1/(16PI)/M**3*(AEM/XW)**2
52723 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52724 LKNT=LKNT+1
52725 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52726 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52727 IDLAM(LKNT,1)=KFNCHI(IJ)
52728 IDLAM(LKNT,2)=-11
52729 IDLAM(LKNT,3)=12
52730C...ONLY DECAY CHI+1 -> E+ NU_E
52731 IF( IMSS(12).NE. 0 ) GOTO 260
52732 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52733 LKNT=LKNT+1
52734 XLAM(LKNT)=XLAM(LKNT-1)
52735 IDLAM(LKNT,1)=KFNCHI(IJ)
52736 IDLAM(LKNT,2)=-13
52737 IDLAM(LKNT,3)=14
52738 ENDIF
52739 ENDIF
52740 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52741 LKNT=LKNT+1
52742 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52743 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52744 ELSE
52745 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52746 ENDIF
52747 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52748 IF(XXC(5).LT.AXMI) THEN
52749 XXC(5)=1D6
52750 ELSEIF(XXC(6).LT.AXMI) THEN
52751 XXC(6)=1D6
52752 ENDIF
52753 XXC(7)=XXC(6)
52754 XXC(8)=XXC(5)
52755 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52756 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52757 IDLAM(LKNT,1)=KFNCHI(IJ)
52758 IDLAM(LKNT,2)=-15
52759 IDLAM(LKNT,3)=16
52760 ENDIF
52761
52762C...NOW, DO THE QUARKS
52763 200 CONTINUE
52764 IA=1
52765 JA=2
52766 EI=KCHG(IA,1)/3D0
52767 T3I=SIGN(1D0,EI+1D-6)/2D0
52768 EJ=KCHG(JA,1)/3D0
52769 T3J=SIGN(1D0,EJ+1D-6)/2D0
52770 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52771 & TANW+ZMIXC(IJ,2)*T3J)
52772 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52773 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52774 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52775 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52776 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52777 IF(XXC(5).LT.AXMI) THEN
52778 XXC(5)=1D6
52779 ENDIF
52780 IF(XXC(6).LT.AXMI) THEN
52781 XXC(6)=1D6
52782 ENDIF
52783 XXC(7)=XXC(6)
52784 XXC(8)=XXC(5)
52785 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52786 LKNT=LKNT+1
52787 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52788 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52789 IDLAM(LKNT,1)=KFNCHI(IJ)
52790 IDLAM(LKNT,2)=-1
52791 IDLAM(LKNT,3)=2
52792 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52793 LKNT=LKNT+1
52794 XLAM(LKNT)=XLAM(LKNT-1)
52795 IDLAM(LKNT,1)=KFNCHI(IJ)
52796 IDLAM(LKNT,2)=-3
52797 IDLAM(LKNT,3)=4
52798 ENDIF
52799 ENDIF
52800 210 CONTINUE
52801 ENDIF
52802 220 CONTINUE
52803
52804C...CHI+_I -> CHI0_J + H+
52805 DO 230 IJ=1,4
52806 XMJ=SMZ(IJ)
52807 AXMJ=ABS(XMJ)
52808 XMJ2=XMJ**2
52809 XMHP=PMAS(ITHC,1)
52810 IF(AXMI.GE.AXMJ+XMHP) THEN
52811 LKNT=LKNT+1
52812 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52813 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52814 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52815 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52816 & UMIXC(IX,2)/SR2)
52817 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52818 GLR=DBLE(OLPP*DCONJG(ORPP))
52819 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52820 IDLAM(LKNT,1)=KFNCHI(IJ)
52821 IDLAM(LKNT,2)=ITHC
52822 IDLAM(LKNT,3)=0
52823 ELSE
52824
52825 ENDIF
52826 230 CONTINUE
52827
52828C...2-BODY DECAYS TO FERMION SFERMION
52829 DO 240 J=1,16
52830 IF(J.GE.7.AND.J.LE.10) GOTO 240
52831 IF(MOD(J,2).EQ.0) THEN
52832 KF1=KSUSY1+J-1
52833 ELSE
52834 KF1=KSUSY1+J+1
52835 ENDIF
52836 KF2=KF1+KSUSY1
52837 XMSF1=PMAS(PYCOMP(KF1),1)
52838 XMSF2=PMAS(PYCOMP(KF2),1)
52839 XMF=PMAS(J,1)
52840 IF(J.LE.6) THEN
52841 FCOL=3D0
52842 ELSE
52843 FCOL=1D0
52844 ENDIF
52845
52846C...U~ D_L
52847 IF(MOD(J,2).EQ.0) THEN
52848 XMFP=PMAS(J-1,1)
52849 CAL=UMIXC(IX,1)
52850 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52851 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52852 CBR=0D0
52853 ISF=J-1
52854 ELSE
52855 XMFP=PMAS(J+1,1)
52856 CAL=VMIXC(IX,1)
52857 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52858 CBR=0D0
52859 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52860 ISF=J+1
52861 ENDIF
52862
52863C...~U_L D
52864 IF(AXMI.GE.XMF+XMSF1) THEN
52865 LKNT=LKNT+1
52866 XMA2=XMSF1**2
52867 XMB2=XMF**2
52868 XL=PYLAMF(XMI2,XMA2,XMB2)
52869 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52870 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52871 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52872 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52873 IDLAM(LKNT,3)=0
52874 IF(MOD(J,2).EQ.0) THEN
52875 IDLAM(LKNT,1)=-KF1
52876 IDLAM(LKNT,2)=J
52877 ELSE
52878 IDLAM(LKNT,1)=KF1
52879 IDLAM(LKNT,2)=-J
52880 ENDIF
52881 ENDIF
52882
52883C...U~ D_R
52884 IF(AXMI.GE.XMF+XMSF2) THEN
52885 LKNT=LKNT+1
52886 XMA2=XMSF2**2
52887 XMB2=XMF**2
52888 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52889 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52890 XL=PYLAMF(XMI2,XMA2,XMB2)
52891 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52892 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52893 IDLAM(LKNT,3)=0
52894 IF(MOD(J,2).EQ.0) THEN
52895 IDLAM(LKNT,1)=-KF2
52896 IDLAM(LKNT,2)=J
52897 ELSE
52898 IDLAM(LKNT,1)=KF2
52899 IDLAM(LKNT,2)=-J
52900 ENDIF
52901 ENDIF
52902 240 CONTINUE
52903
52904C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52905C...A 2-BODY -- 2-BODY CHAIN
52906 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52907 IF(AXMI.GE.XMJ) THEN
52908 AXMJ=ABS(XMJ)
52909 S12MIN=0D0
52910 S12MAX=(AXMI-AXMJ)**2
52911 XXC(1)=0D0
52912 XXC(2)=XMJ
52913 XXC(3)=0D0
52914 XXC(4)=XMI
52915 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52916 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52917 XXC(9)=1D6
52918 XXC(10)=0D0
52919 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52920 ORPP=DCONJG(OLPP)
52921 CXC(1)=DCMPLX(0D0,0D0)
52922 CXC(3)=DCMPLX(0D0,0D0)
52923 CXC(5)=DCMPLX(0D0,0D0)
52924 CXC(7)=DCMPLX(0D0,0D0)
52925 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52926 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52927 CXC(6)=DCMPLX(0D0,0D0)
52928 CXC(8)=DCMPLX(0D0,0D0)
52929 IF(XXC(5).LT.AXMI) THEN
52930 XXC(5)=1D6
52931 ELSEIF(XXC(6).LT.AXMI) THEN
52932 XXC(6)=1D6
52933 ENDIF
52934 XXC(7)=XXC(6)
52935 XXC(8)=XXC(5)
52936 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52937 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52938 LKNT=LKNT+1
52939 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52940 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52941 IDLAM(LKNT,1)=KSUSY1+21
52942 IDLAM(LKNT,2)=-1
52943 IDLAM(LKNT,3)=2
52944 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52945 LKNT=LKNT+1
52946 XLAM(LKNT)=XLAM(LKNT-1)
52947 IDLAM(LKNT,1)=KSUSY1+21
52948 IDLAM(LKNT,2)=-3
52949 IDLAM(LKNT,3)=4
52950 ENDIF
52951 ENDIF
52952 250 CONTINUE
52953 ENDIF
52954
52955C...R-violating decay modes (SKANDS).
52956 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52957
52958 260 IKNT=LKNT
52959 XLAM(0)=0D0
52960 DO 270 I=1,IKNT
52961 XLAM(0)=XLAM(0)+XLAM(I)
52962 IF(XLAM(I).LT.0D0) THEN
52963 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52964 & (IDLAM(I,J),J=1,3)
52965 XLAM(I)=0D0
52966 ENDIF
52967 270 CONTINUE
52968 IF(XLAM(0).EQ.0D0) THEN
52969 XLAM(0)=1D-6
52970 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52971 WRITE(MSTU(11),*) LKNT
52972 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52973 ENDIF
52974
52975 RETURN
52976 END
52977
52978C*********************************************************************
52979
52980C...PYXXZ6
52981C...Used in the calculation of inoi -> inoj + f + ~f.
52982
52983 FUNCTION PYXXZ6(X)
52984
52985C...Double precision and integer declarations.
52986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52987 IMPLICIT INTEGER(I-N)
52988 INTEGER PYK,PYCHGE,PYCOMP
52989C...Parameter statement to help give large particle numbers.
52990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52991 &KEXCIT=4000000,KDIMEN=5000000)
52992C...Commonblocks.
52993 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52994C COMMON/PYINTS/XXM(20)
52995 COMPLEX*16 CXC
52996 COMMON/PYINTC/XXC(10),CXC(8)
52997 SAVE /PYDAT1/,/PYINTC/
52998
52999C...Local variables.
53000 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53001 DOUBLE PRECISION PYXXZ6,X
53002 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53003 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53004 DOUBLE PRECISION SIJ
53005 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53006 DOUBLE PRECISION OL2
53007 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53008 INTEGER I
53009
53010C...Statement functions.
53011C...Integral from x to y of (t-a)(b-t) dt.
53012 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53013C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53014 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53015 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53016C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53017 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53018 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53019C...Integral from x to y of (t-a)/(b-t) dt.
53020 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53021C...Integral from x to y of 1/(t-a) dt.
53022 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53023
53024 XM12=XXC(1)**2
53025 XM22=XXC(2)**2
53026 XM32=XXC(3)**2
53027 S=XXC(4)**2
53028 S13=X
53029
53030 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53031 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53032 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53033
53034 S23MIN=(S23AVE-S23DEL)
53035 S23MAX=(S23AVE+S23DEL)
53036
53037 XMSD1=XXC(5)**2
53038 XMSD2=XXC(7)**2
53039 XMSU1=XXC(6)**2
53040 XMSU2=XXC(8)**2
53041
53042 XMV=XXC(9)
53043 XMG=XXC(10)
53044 QLLS=CXC(1)
53045 QLLU=CXC(2)
53046 QLRS=CXC(3)
53047 QLRT=CXC(4)
53048 QRLS=CXC(5)
53049 QRLT=CXC(6)
53050 QRRS=CXC(7)
53051 QRRU=CXC(8)
53052 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53053 SIJ=2D0*XXC(2)*XXC(4)*S13
53054 IF(XMV.LE.1000D0) THEN
53055 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53056 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53057 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53058 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53059 IF(XXC(5).LE.10000D0) THEN
53060 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53061 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53062 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53063 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53064 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53065 & *(S13-XMV**2)/WPROP2
53066 ELSE
53067 WFL1=0D0
53068 ENDIF
53069
53070 IF(XXC(6).LE.10000D0) THEN
53071 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53072 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53073 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53074 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53075 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53076 & *(S13-XMV**2)/WPROP2
53077 ELSE
53078 WFL2=0D0
53079 ENDIF
53080 ELSE
53081 WW=0D0
53082 WFL1=0D0
53083 WFL2=0D0
53084 ENDIF
53085 IF(XXC(5).LE.10000D0) THEN
53086 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53087 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53088 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53089 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53090 ELSE
53091 WF1=0D0
53092 ENDIF
53093 IF(XXC(6).LE.10000D0) THEN
53094 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53095 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53096 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53097 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53098 ELSE
53099 WF2=0D0
53100 ENDIF
53101
53102 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53103
53104 IF(PYXXZ6.LT.0D0) THEN
53105 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53106 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53107 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53108 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53109 WRITE(MSTU(11),*) S23MIN,S23MAX
53110 PYXXZ6=0D0
53111 ENDIF
53112
53113 RETURN
53114 END
53115
53116
53117C*********************************************************************
53118
53119C...PYXXGA
53120C...Calculates chi0_i -> chi0_j + gamma.
53121
53122 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53123
53124C...Double precision and integer declarations.
53125 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53126 IMPLICIT INTEGER(I-N)
53127 INTEGER PYK,PYCHGE,PYCOMP
53128
53129C...Local variables.
53130 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53131 DOUBLE PRECISION F1,F2
53132
53133 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53134 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53135 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53136 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53137
53138 RETURN
53139 END
53140
53141C*********************************************************************
53142
53143C...PYX2XG
53144C...Calculates the decay rate for ino -> ino + gauge boson.
53145
53146 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53147
53148C...Double precision and integer declarations.
53149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53150 IMPLICIT INTEGER(I-N)
53151 INTEGER PYK,PYCHGE,PYCOMP
53152
53153C...Local variables.
53154 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53155 DOUBLE PRECISION XL,PYLAMF,C1
53156 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53157
53158 XMI2=XM1**2
53159 XMI3=ABS(XM1**3)
53160 XMJ2=XM2**2
53161 XMV2=XM3**2
53162 XL=PYLAMF(XMI2,XMJ2,XMV2)
53163 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53164 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53165 &12D0*GLR*XM1*XM2*XMV2)
53166
53167 RETURN
53168 END
53169
53170C*********************************************************************
53171
53172C...PYX2XH
53173C...Calculates the decay rate for ino -> ino + H.
53174
53175 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53176
53177C...Double precision and integer declarations.
53178 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53179 IMPLICIT INTEGER(I-N)
53180 INTEGER PYK,PYCHGE,PYCOMP
53181
53182C...Local variables.
53183 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53184 DOUBLE PRECISION XL,PYLAMF,C1
53185 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53186
53187 XMI2=XM1**2
53188 XMI3=ABS(XM1**3)
53189 XMJ2=XM2**2
53190 XMV2=XM3**2
53191 XL=PYLAMF(XMI2,XMJ2,XMV2)
53192 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53193 &*(GX2*(XMI2+XMJ2-XMV2)+
53194 &4D0*GLR*XM1*XM2)
53195
53196 RETURN
53197 END
53198
53199C*********************************************************************
53200
53201C...PYHEXT
53202C...Calculates the non-standard decay modes of the Higgs boson.
53203C...
53204C...Author: Stephen Mrenna
53205C...Last Update: April 2001
53206C......Allow complex values for Z,U, and V
53207
53208 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53209
53210C...Double precision and integer declarations.
53211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53212 IMPLICIT INTEGER(I-N)
53213 INTEGER PYK,PYCHGE,PYCOMP
53214C...Parameter statement to help give large particle numbers.
53215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53216 &KEXCIT=4000000,KDIMEN=5000000)
53217C...Commonblocks.
53218 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53219 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53220 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53221 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53222 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53223 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53224 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53225
53226C...Local variables.
53227 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53228 COMPLEX*16 QIJ,RIJ,F21K,F12K
53229 INTEGER KFIN
53230 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53231 DOUBLE PRECISION XMI2,XMI3,XMJ2
53232 DOUBLE PRECISION PYLAMF,XL,CF,EI
53233 INTEGER IDU,IFL
53234 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53235 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53236 DOUBLE PRECISION XLAM(0:400)
53237 INTEGER IDLAM(400,3)
53238 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53239 INTEGER ITH(4)
53240 INTEGER KFNCHI(4),KFCCHI(2)
53241 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53242 DOUBLE PRECISION SR2
53243 DOUBLE PRECISION BETA,ALFA
53244 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53245 DOUBLE PRECISION PYALEM
53246 DOUBLE PRECISION AL,AR,ALR
53247 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53248 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53249 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53250 DATA ITH/25,35,36,37/
53251 DATA ETAH/1D0,1D0,-1D0/
53252 DATA SR2/1.4142136D0/
53253 DATA KFNCHI/1000022,1000023,1000025,1000035/
53254 DATA KFCCHI/1000024,1000037/
53255
53256C...COUNT THE NUMBER OF DECAY MODES
53257 LKNT=IKNT
53258
53259 XMW=PMAS(24,1)
53260 XMW2=XMW**2
53261 XMZ=PMAS(23,1)
53262 XW=PARU(102)
53263 TANW = SQRT(XW/(1D0-XW))
53264 CW=SQRT(1D0-XW)
53265
53266C...1 - 4 DEPENDING ON Higgs species.
53267 IH=1
53268 IF(KFIN.EQ.ITH(2)) IH=2
53269 IF(KFIN.EQ.ITH(3)) IH=3
53270 IF(KFIN.EQ.ITH(4)) IH=4
53271
53272 XMI=PMAS(KFIN,1)
53273 XMI2=XMI**2
53274 AXMI=ABS(XMI)
53275 AEM=PYALEM(XMI2)
53276 C1=AEM/XW
53277 XMI3=ABS(XMI**3)
53278
53279 TANB=RMSS(5)
53280 BETA=ATAN(TANB)
53281 CBETA=COS(BETA)
53282 SBETA=TANB*CBETA
53283 ALFA=RMSS(18)
53284 COSA=COS(ALFA)
53285 SINA=SIN(ALFA)
53286 ATRIT=RMSS(16)
53287 ATRIB=RMSS(15)
53288 ATRIL=RMSS(17)
53289 XMUZ=-RMSS(4)
53290
53291 DO 110 I=1,4
53292 DO 100 J=1,4
53293 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53294 100 CONTINUE
53295 110 CONTINUE
53296 DO 130 I=1,2
53297 DO 120 J=1,2
53298 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53299 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53300 120 CONTINUE
53301 130 CONTINUE
53302
53303
53304 IF(IH.EQ.4) GOTO 220
53305
53306C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53307C...H0_K -> CHI0_I + CHI0_J
53308 EH(2)=SINA
53309 EH(1)=COSA
53310 EH(3)=CBETA
53311 DH(2)=COSA
53312 DH(1)=-SINA
53313 DH(3)=SBETA
53314 DO 150 IJ=1,4
53315 XMJ=SMZ(IJ)
53316 AXMJ=ABS(XMJ)
53317 DO 140 IK=1,IJ
53318 XMK=SMZ(IK)
53319 AXMK=ABS(XMK)
53320 IF(AXMI.GE.AXMJ+AXMK) THEN
53321 LKNT=LKNT+1
53322 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53323 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53324 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53325 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53326 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53327 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53328 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53329 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53330 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53331 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53332C...SIGN OF MASSES I,J
53333 XML=XMK*ETAH(IH)
53334 GX2=ABS(F12K)**2+ABS(F21K)**2
53335 GLR=DBLE(F12K*DCONJG(F21K))
53336 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53337 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53338 IDLAM(LKNT,1)=KFNCHI(IJ)
53339 IDLAM(LKNT,2)=KFNCHI(IK)
53340 IDLAM(LKNT,3)=0
53341 ENDIF
53342 140 CONTINUE
53343 150 CONTINUE
53344
53345C...H0_K -> CHI+_I CHI-_J
53346 DO 170 IJ=1,2
53347 XMJ=SMW(IJ)
53348 AXMJ=ABS(XMJ)
53349 DO 160 IK=1,2
53350 XMK=SMW(IK)
53351 AXMK=ABS(XMK)
53352 IF(AXMI.GE.AXMJ+AXMK) THEN
53353 LKNT=LKNT+1
53354 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53355 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53356 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53357 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53358 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53359 GLR=DBLE(OLPP*DCONJG(ORPP))
53360 XML=XMK*ETAH(IH)
53361 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53362 IDLAM(LKNT,1)=KFCCHI(IJ)
53363 IDLAM(LKNT,2)=-KFCCHI(IK)
53364 IDLAM(LKNT,3)=0
53365 ENDIF
53366 160 CONTINUE
53367 170 CONTINUE
53368
53369C...HIGGS TO SFERMION SFERMION
53370 DO 200 IFL=1,16
53371 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53372 IJ=KSUSY1+IFL
53373 XMJL=PMAS(PYCOMP(IJ),1)
53374 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53375 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53376 XMJ=XMJL
53377 XMJ2=XMJ**2
53378 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53379 XMF=PMAS(IFL,1)
53380 EI=KCHG(IFL,1)/3D0
53381 IDU=2-MOD(IFL,2)
53382
53383 IF(IH.EQ.1) THEN
53384 IF(IDU.EQ.1) THEN
53385 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53386 & XMF**2/XMW*SINA/CBETA
53387 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53388 & XMF**2/XMW*SINA/CBETA
53389 IF(IFL.EQ.5) THEN
53390 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53391 & ATRIB*SINA)
53392 ELSEIF(IFL.EQ.15) THEN
53393 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53394 & ATRIL*SINA)
53395 ELSE
53396 GHLR=0D0
53397 ENDIF
53398 ELSE
53399 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53400 & XMF**2/XMW*COSA/SBETA
53401 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53402 & XMF**2/XMW*COSA/SBETA
53403 IF(IFL.EQ.6) THEN
53404 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53405 & ATRIT*COSA)
53406 ELSE
53407 GHLR=0D0
53408 ENDIF
53409 ENDIF
53410
53411 ELSEIF(IH.EQ.2) THEN
53412 IF(IDU.EQ.1) THEN
53413 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53414 & XMF**2/XMW*COSA/CBETA
53415 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53416 & XMF**2/XMW*COSA/CBETA
53417 IF(IFL.EQ.5) THEN
53418 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53419 & ATRIB*COSA)
53420 ELSEIF(IFL.EQ.15) THEN
53421 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53422 & ATRIL*COSA)
53423 ELSE
53424 GHLR=0D0
53425 ENDIF
53426 ELSE
53427 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53428 & XMF**2/XMW*SINA/SBETA
53429 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53430 & XMF**2/XMW*SINA/SBETA
53431 IF(IFL.EQ.6) THEN
53432 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53433 & ATRIT*SINA)
53434 ELSE
53435 GHLR=0D0
53436 ENDIF
53437 ENDIF
53438
53439 ELSEIF(IH.EQ.3) THEN
53440 GHLL=0D0
53441 GHRR=0D0
53442 GHLR=0D0
53443 IF(IDU.EQ.1) THEN
53444 IF(IFL.EQ.5) THEN
53445 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53446 ELSEIF(IFL.EQ.15) THEN
53447 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53448 ENDIF
53449 ELSE
53450 IF(IFL.EQ.6) THEN
53451 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53452 ENDIF
53453 ENDIF
53454 ENDIF
53455 IF(IH.EQ.3) GOTO 180
53456
53457 AL=SFMIX(IFL,1)**2
53458 AR=SFMIX(IFL,2)**2
53459 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53460 IF(IFL.LE.6) THEN
53461 CF=3D0
53462 ELSE
53463 CF=1D0
53464 ENDIF
53465
53466 IF(AXMI.GE.2D0*XMJ) THEN
53467 LKNT=LKNT+1
53468 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53469 & (GHLL*AL+GHRR*AR
53470 & +2D0*GHLR*ALR)**2
53471 IDLAM(LKNT,1)=IJ
53472 IDLAM(LKNT,2)=-IJ
53473 IDLAM(LKNT,3)=0
53474 ENDIF
53475
53476 IF(AXMI.GE.2D0*XMJR) THEN
53477 LKNT=LKNT+1
53478 AL=SFMIX(IFL,3)**2
53479 AR=SFMIX(IFL,4)**2
53480 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53481 XMJ=XMJR
53482 XMJ2=XMJ**2
53483 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53484 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53485 & (GHLL*AL+GHRR*AR
53486 & +2D0*GHLR*ALR)**2
53487 IDLAM(LKNT,1)=IJ+KSUSY1
53488 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53489 IDLAM(LKNT,3)=0
53490 ENDIF
53491 180 CONTINUE
53492
53493 IF(AXMI.GE.XMJL+XMJR) THEN
53494 LKNT=LKNT+1
53495 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53496 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53497 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53498 XMJ=XMJR
53499 XMJ2=XMJ**2
53500 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53501 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53502 & (GHLL*AL+GHRR*AR)**2
53503 IDLAM(LKNT,1)=IJ
53504 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53505 IDLAM(LKNT,3)=0
53506 LKNT=LKNT+1
53507 IDLAM(LKNT,1)=-IJ
53508 IDLAM(LKNT,2)=IJ+KSUSY1
53509 IDLAM(LKNT,3)=0
53510 XLAM(LKNT)=XLAM(LKNT-1)
53511 ENDIF
53512 ENDIF
53513 190 CONTINUE
53514 200 CONTINUE
53515 210 CONTINUE
53516
53517 GOTO 270
53518 220 CONTINUE
53519
53520C...H+ -> CHI+_I + CHI0_J
53521 DO 240 IJ=1,4
53522 XMJ=SMZ(IJ)
53523 AXMJ=ABS(XMJ)
53524 XMJ2=XMJ**2
53525 DO 230 IK=1,2
53526 XMK=SMW(IK)
53527 AXMK=ABS(XMK)
53528 IF(AXMI.GE.AXMJ+AXMK) THEN
53529 LKNT=LKNT+1
53530 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53531 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53532 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53533 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53534 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53535 GLR=DBLE(OLPP*DCONJG(ORPP))
53536 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53537 IDLAM(LKNT,1)=KFNCHI(IJ)
53538 IDLAM(LKNT,2)=KFCCHI(IK)
53539 IDLAM(LKNT,3)=0
53540 ENDIF
53541 230 CONTINUE
53542 240 CONTINUE
53543
53544 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53545 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53546 AL=0D0
53547 AR=0D0
53548 CF=3D0
53549
53550C...H+ -> T_1 B_1~
53551 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53552 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53553 IF(XMI.GE.XM1+XM2) THEN
53554 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53555 LKNT=LKNT+1
53556 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53557 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53558 IDLAM(LKNT,1)=KSUSY1+6
53559 IDLAM(LKNT,2)=-(KSUSY1+5)
53560 IDLAM(LKNT,3)=0
53561 ENDIF
53562
53563C...H+ -> T_2 B_1~
53564 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53565 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53566 IF(XMI.GE.XM1+XM2) THEN
53567 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53568 LKNT=LKNT+1
53569 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53570 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53571 IDLAM(LKNT,1)=KSUSY2+6
53572 IDLAM(LKNT,2)=-(KSUSY1+5)
53573 IDLAM(LKNT,3)=0
53574 ENDIF
53575
53576C...H+ -> T_1 B_2~
53577 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53578 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53579 IF(XMI.GE.XM1+XM2) THEN
53580 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53581 LKNT=LKNT+1
53582 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53583 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53584 IDLAM(LKNT,1)=KSUSY1+6
53585 IDLAM(LKNT,2)=-(KSUSY2+5)
53586 IDLAM(LKNT,3)=0
53587 ENDIF
53588
53589C...H+ -> T_2 B_2~
53590 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53591 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53592 IF(XMI.GE.XM1+XM2) THEN
53593 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53594 LKNT=LKNT+1
53595 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53596 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53597 IDLAM(LKNT,1)=KSUSY2+6
53598 IDLAM(LKNT,2)=-(KSUSY2+5)
53599 IDLAM(LKNT,3)=0
53600 ENDIF
53601
53602C...H+ -> UL DL~
53603 GL=-XMW/SR2*SIN(2D0*BETA)
53604 DO 250 IJ=1,3,2
53605 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53606 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53607 IF(XMI.GE.XM1+XM2) THEN
53608 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53609 LKNT=LKNT+1
53610 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53611 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53612 IDLAM(LKNT,2)=KSUSY1+IJ+1
53613 IDLAM(LKNT,3)=0
53614 ENDIF
53615 250 CONTINUE
53616
53617C...H+ -> EL~ NUL
53618 CF=1D0
53619 DO 260 IJ=11,13,2
53620 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53621 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53622 IF(XMI.GE.XM1+XM2) THEN
53623 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53624 LKNT=LKNT+1
53625 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53626 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53627 IDLAM(LKNT,2)=KSUSY1+IJ+1
53628 IDLAM(LKNT,3)=0
53629 ENDIF
53630 260 CONTINUE
53631
53632C...H+ -> TAU1 NUTAUL
53633 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53634 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53635 IF(XMI.GE.XM1+XM2) THEN
53636 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53637 LKNT=LKNT+1
53638 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53639 IDLAM(LKNT,1)=-(KSUSY1+15)
53640 IDLAM(LKNT,2)= KSUSY1+16
53641 IDLAM(LKNT,3)=0
53642 ENDIF
53643
53644C...H+ -> TAU2 NUTAUL
53645 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53646 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53647 IF(XMI.GE.XM1+XM2) THEN
53648 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53649 LKNT=LKNT+1
53650 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53651 IDLAM(LKNT,1)=-(KSUSY2+15)
53652 IDLAM(LKNT,2)= KSUSY1+16
53653 IDLAM(LKNT,3)=0
53654 ENDIF
53655
53656 270 CONTINUE
53657 IKNT=LKNT
53658 XLAM(0)=0D0
53659 DO 280 I=1,IKNT
53660 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53661 XLAM(0)=XLAM(0)+XLAM(I)
53662 280 CONTINUE
53663 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53664
53665 RETURN
53666 END
53667
53668C*********************************************************************
53669
53670C...PYH2XX
53671C...Calculates the decay rate for a Higgs to an ino pair.
53672
53673 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53674
53675C...Double precision and integer declarations.
53676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53677 IMPLICIT INTEGER(I-N)
53678 INTEGER PYK,PYCHGE,PYCOMP
53679C...Commonblocks.
53680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53681 SAVE /PYDAT1/
53682
53683C...Local variables.
53684 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53685 DOUBLE PRECISION XL,PYLAMF,C1
53686 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53687
53688 XMI2=XM1**2
53689 XMI3=ABS(XM1**3)
53690 XMJ2=XM2**2
53691 XMK2=XM3**2
53692 XL=PYLAMF(XMI2,XMJ2,XMK2)
53693 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53694 &*(GX2*(XMI2-XMJ2-XMK2)-
53695 &4D0*GLR*XM3*XM2)
53696 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53697
53698 RETURN
53699 END
53700
53701C*********************************************************************
53702
53703C...PYGAUS
53704C...Integration by adaptive Gaussian quadrature.
53705C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53706
53707 FUNCTION PYGAUS(F, A, B, EPS)
53708
53709C...Double precision and integer declarations.
53710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53711 IMPLICIT INTEGER(I-N)
53712 INTEGER PYK,PYCHGE,PYCOMP
53713
53714C...Local declarations.
53715 EXTERNAL F
53716 DOUBLE PRECISION F,W(12), X(12)
53717 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53718 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53719 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53720 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53721 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53722 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53723 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53724 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53725 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53726 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53727 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53728 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53729
53730C...The Gaussian quadrature algorithm.
53731 H = 0D0
53732 IF(B .EQ. A) GOTO 140
53733 CONST = 5D-3 / ABS(B-A)
53734 BB = A
53735 100 CONTINUE
53736 AA = BB
53737 BB = B
53738 110 CONTINUE
53739 C1 = 0.5D0*(BB+AA)
53740 C2 = 0.5D0*(BB-AA)
53741 S8 = 0D0
53742 DO 120 I = 1, 4
53743 U = C2*X(I)
53744 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53745 120 CONTINUE
53746 S16 = 0D0
53747 DO 130 I = 5, 12
53748 U = C2*X(I)
53749 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53750 130 CONTINUE
53751 S16 = C2*S16
53752 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53753 H = H + S16
53754 IF(BB .NE. B) GOTO 100
53755 ELSE
53756 BB = C1
53757 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53758 H = 0D0
53759 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53760 GOTO 140
53761 ENDIF
53762 140 CONTINUE
53763 PYGAUS = H
53764
53765 RETURN
53766 END
53767
53768C*********************************************************************
53769
53770C...PYGAU2
53771C...Integration by adaptive Gaussian quadrature.
53772C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53773C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53774
53775 FUNCTION PYGAU2(F, A, B, EPS)
53776
53777C...Double precision and integer declarations.
53778 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53779 IMPLICIT INTEGER(I-N)
53780 INTEGER PYK,PYCHGE,PYCOMP
53781
53782C...Local declarations.
53783 EXTERNAL F
53784 DOUBLE PRECISION F,W(12), X(12)
53785 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53786 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53787 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53788 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53789 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53790 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53791 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53792 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53793 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53794 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53795 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53796 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53797
53798C...The Gaussian quadrature algorithm.
53799 H = 0D0
53800 IF(B .EQ. A) GOTO 140
53801 CONST = 5D-3 / ABS(B-A)
53802 BB = A
53803 100 CONTINUE
53804 AA = BB
53805 BB = B
53806 110 CONTINUE
53807 C1 = 0.5D0*(BB+AA)
53808 C2 = 0.5D0*(BB-AA)
53809 S8 = 0D0
53810 DO 120 I = 1, 4
53811 U = C2*X(I)
53812 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53813 120 CONTINUE
53814 S16 = 0D0
53815 DO 130 I = 5, 12
53816 U = C2*X(I)
53817 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53818 130 CONTINUE
53819 S16 = C2*S16
53820 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53821 H = H + S16
53822 IF(BB .NE. B) GOTO 100
53823 ELSE
53824 BB = C1
53825 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53826 H = 0D0
53827 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53828 GOTO 140
53829 ENDIF
53830 140 CONTINUE
53831 PYGAU2 = H
53832
53833 RETURN
53834 END
53835
53836C*********************************************************************
53837
53838C...PYSIMP
53839C...Simpson formula for an integral.
53840
53841 FUNCTION PYSIMP(Y,X0,X1,N)
53842
53843C...Double precision and integer declarations.
53844 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53845 IMPLICIT INTEGER(I-N)
53846 INTEGER PYK,PYCHGE,PYCOMP
53847
53848C...Local variables.
53849 DOUBLE PRECISION Y,X0,X1,H,S
53850 DIMENSION Y(0:N)
53851
53852 S=0D0
53853 H=(X1-X0)/N
53854 DO 100 I=0,N-2,2
53855 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53856 100 CONTINUE
53857 PYSIMP=S*H/3D0
53858
53859 RETURN
53860 END
53861
53862C*********************************************************************
53863
53864C...PYLAMF
53865C...The standard lambda function.
53866
53867 FUNCTION PYLAMF(X,Y,Z)
53868
53869C...Double precision and integer declarations.
53870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53871 IMPLICIT INTEGER(I-N)
53872 INTEGER PYK,PYCHGE,PYCOMP
53873
53874C...Local variables.
53875 DOUBLE PRECISION PYLAMF,X,Y,Z
53876
53877 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53878 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53879
53880 RETURN
53881 END
53882
53883C*********************************************************************
53884
53885C...PYTBDY
53886C...Generates 3-body decays of gauginos.
53887
53888 SUBROUTINE PYTBDY(IDIN)
53889
53890C...Double precision and integer declarations.
53891 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53892 IMPLICIT INTEGER(I-N)
53893 INTEGER PYK,PYCHGE,PYCOMP
53894C...Parameter statement to help give large particle numbers.
53895 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53896 &KEXCIT=4000000,KDIMEN=5000000)
53897C...Commonblocks.
53898 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53899 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53900 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53901C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53902C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53903 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53904 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53905C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53906 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53907
53908C...Local variables.
53909 DOUBLE PRECISION XM(5)
53910 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53911 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53912 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53913 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53914 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53915 DOUBLE PRECISION CPHI1,SPHI1
53916 DOUBLE PRECISION S23DEL,EPS
53917 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53918 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53919 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53920 INTEGER INOID(4)
53921 DATA INOID/22,23,25,35/
53922 DATA EPS/1D-6/
53923
53924 ID=IDIN
53925 ISKIP=1
53926 XM(1)=P(N+1,5)
53927 XM(2)=P(N+2,5)
53928 XM(3)=P(N+3,5)
53929 XM(5)=P(ID,5)
53930
53931C...GENERATE S12
53932 S12MIN=(XM(1)+XM(2))**2
53933 S12MAX=(XM(5)-XM(3))**2
53934 YJACO1=S12MAX-S12MIN
53935
53936C...Initialize some parameters
53937 XW=PARU(102)
53938 XW1=1D0-XW
53939 TANW=SQRT(XW/XW1)
53940 IZID1=0
53941 IWID1=0
53942 IZID2=0
53943 IWID2=0
53944
53945 IA=K(N+2,2)
53946 JA=K(N+3,2)
53947
53948C...Mrenna: check that we are indeed decaying a SUSY particle
53949 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53950
53951 ELSE
53952 DO 100 I1=1,4
53953 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53954 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53955 100 CONTINUE
53956 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53957 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53958 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53959 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53960 ZM12=XM(5)**2
53961 ZM22=XM(1)**2
53962 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53963 T3I=SIGN(1D0,EI+1D-6)/2D0
53964 ENDIF
53965
53966 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53967 ISKIP=0
53968 ELSEIF(IZID1*IZID2.NE.0) THEN
53969 SQMZ=PMAS(23,1)**2
53970 GMMZ=PMAS(23,1)*PMAS(23,2)
53971 DO 110 I=1,4
53972 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53973 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53974 110 CONTINUE
53975 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53976 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53977 ORPP=DCONJG(OLPP)
53978 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53979 XLR2=XLL2
53980 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53981 XRL2=XRR2
53982 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53983 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53984 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53985 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53986 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53987 QLLU=-GLIJ
53988 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53989 QLRT=DCONJG(GLIJ)
53990 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
53991 QRLT=GRIJ
53992 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
53993 QRRU=-DCONJG(GRIJ)
53994 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
53995 IF(IZID1.NE.0) THEN
53996 XM1M2=SMZ(IZID1)*SMW(IWID2)
53997 IZID1=IWID2
53998 IZID2=IZID1
53999 ELSE
54000 XM1M2=SMZ(IZID2)*SMW(IWID1)
54001 IZID1=IWID1
54002 ENDIF
54003 RT2I = 1D0/SQRT(2D0)
54004 SQMZ=PMAS(24,1)**2
54005 GMMZ=PMAS(24,1)*PMAS(24,2)
54006 DO 120 I=1,2
54007 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54008 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54009 120 CONTINUE
54010 DO 130 I=1,4
54011 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54012 130 CONTINUE
54013 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54014 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54015 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54016 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54017 EJ=KCHG(IABS(JA),1)/3D0
54018 T3J=SIGN(1D0,EJ+1D-6)/2D0
54019 QRLS=DCMPLX(0D0,0D0)
54020 QRLT=QRLS
54021 QRRS=QRLS
54022 QRRU=QRLS
54023 XRR2=1D6**2
54024 XRL2=XRR2
54025 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54026 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54027 IF(MOD(IA,2).EQ.0) THEN
54028 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54029 & TANW+ZMIXC(IZID2,2)*T3I)
54030 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54031 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54032 ELSE
54033 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54034 & TANW+ZMIXC(IZID2,2)*T3J)
54035 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54036 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54037 ENDIF
54038 ELSEIF(IWID1*IWID2.NE.0) THEN
54039 IZID1=IWID1
54040 IZID2=IWID2
54041 XM1M2=SMW(IWID1)*SMW(IWID2)
54042 SQMZ=PMAS(23,1)**2
54043 GMMZ=PMAS(23,1)*PMAS(23,2)
54044 DO 140 I=1,2
54045 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54046 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54047 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54048 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54049 140 CONTINUE
54050 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54051 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54052 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54053 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54054 QRLS=-DCMPLX(EI/XW1)*ORPP
54055 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54056 QRRS=-DCMPLX(EI/XW1)*OLPP
54057 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54058 IF(MOD(IA,2).EQ.0) THEN
54059 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54060 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54061 ELSE
54062 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54063 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54064 ENDIF
54065 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54066 &THEN
54067 ISKIP=0
54068 ELSE
54069 ISKIP=0
54070 ENDIF
54071
54072 IF(ISKIP.NE.0) THEN
54073 WTMAX=0D0
54074 DO 160 KT=1,100
54075 S12=S12MIN+YJACO1*(KT-1)/99
54076 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54077 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54078 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54079 & -(2D0*XM(1)*XM(2))**2
54080 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54081 & -(2D0*XM(3)*XM(5))**2
54082 S23DF1=S23DF1*EPS
54083 S23DF2=S23DF2*EPS
54084 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54085 S23DEL=S23DEL/EPS
54086 S23MIN=S23AVE-S23DEL
54087 S23MAX=S23AVE+S23DEL
54088 YJACO2=S23MAX-S23MIN
54089 TH=S12
54090 DO 150 KS=1,100
54091 S23=S23MIN+YJACO2*(KS-1)/99
54092 SH=S23
54093 UH=ZM12+ZM22-SH-TH
54094 WU2 = (UH-ZM12)*(UH-ZM22)
54095 WT2 = (TH-ZM12)*(TH-ZM22)
54096 WS2 = XM1M2*SH
54097 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54098 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54099 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54100 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54101 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54102 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54103 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54104 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54105 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54106 IF(WT0.GT.WTMAX) WTMAX=WT0
54107 150 CONTINUE
54108 160 CONTINUE
54109
54110 WTMAX=WTMAX*1.05D0
54111 ENDIF
54112
54113C...FIND S12*
54114 AX=S12MIN
54115 CX=S12MAX
54116 BX=S12MIN+0.5D0*YJACO1
54117 X0=AX
54118 X3=CX
54119 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54120 X1=BX
54121 X2=BX+C*(CX-BX)
54122 ELSE
54123 X2=BX
54124 X1=BX-C*(BX-AX)
54125 ENDIF
54126
54127C...SOLVE FOR F1 AND F2
54128 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54129 &-(2D0*XM(1)*XM(2))**2
54130 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54131 &-(2D0*XM(3)*XM(5))**2
54132 S23DF1=S23DF1*EPS
54133 S23DF2=S23DF2*EPS
54134 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54135 F1=-2D0*S23DEL/EPS
54136 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54137 &-(2D0*XM(1)*XM(2))**2
54138 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54139 &-(2D0*XM(3)*XM(5))**2
54140 S23DF1=S23DF1*EPS
54141 S23DF2=S23DF2*EPS
54142 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54143 F2=-2D0*S23DEL/EPS
54144
54145 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54146C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54147 IF(F2.LE.F1)THEN
54148 X0=X1
54149 X1=X2
54150 X2=R*X1+C*X3
54151 F1=F2
54152 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54153 & -(2D0*XM(1)*XM(2))**2
54154 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54155 & -(2D0*XM(3)*XM(5))**2
54156 S23DF1=S23DF1*EPS
54157 S23DF2=S23DF2*EPS
54158 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54159 F2=-2D0*S23DEL/EPS
54160 ELSE
54161 X3=X2
54162 X2=X1
54163 X1=R*X2+C*X0
54164 F2=F1
54165 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54166 & -(2D0*XM(1)*XM(2))**2
54167 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54168 & -(2D0*XM(3)*XM(5))**2
54169 S23DF1=S23DF1*EPS
54170 S23DF2=S23DF2*EPS
54171 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54172 F1=-2D0*S23DEL/EPS
54173 ENDIF
54174 GOTO 170
54175 ENDIF
54176C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54177 IF(F1.LT.F2)THEN
54178 GOLDEN=-F1
54179 XMIN=X1
54180 ELSE
54181 GOLDEN=-F2
54182 XMIN=X2
54183 ENDIF
54184
54185 IKNT=0
54186 180 S12=S12MIN+PYR(0)*YJACO1
54187 IKNT=IKNT+1
54188C...GENERATE S23
54189 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54190 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54191 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54192 &-(2D0*XM(1)*XM(2))**2
54193 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54194 &-(2D0*XM(3)*XM(5))**2
54195 S23DF1=S23DF1*EPS
54196 S23DF2=S23DF2*EPS
54197 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54198 S23DEL=S23DEL/EPS
54199 S23MIN=S23AVE-S23DEL
54200 S23MAX=S23AVE+S23DEL
54201 YJACO2=S23MAX-S23MIN
54202 S23=S23MIN+PYR(0)*YJACO2
54203
54204C...CHECK THE SAMPLING
54205 IF(IKNT.GT.100) THEN
54206 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54207 GOTO 190
54208 ENDIF
54209 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54210
54211 IF(ISKIP.EQ.0) GOTO 190
54212
54213 SH=S23
54214 TH=S12
54215 UH=ZM12+ZM22-SH-TH
54216
54217 WU2 = (UH-ZM12)*(UH-ZM22)
54218 WT2 = (TH-ZM12)*(TH-ZM22)
54219 WS2 = XM1M2*SH
54220 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54221 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54222
54223 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54224 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54225 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54226 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54227c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54228c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54229c &/DCMPLX(TH-XML2)
54230c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54231c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54232c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54233 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54234 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54235 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54236
54237 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54238 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54239
54240 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54241 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54242 D2=XM(5)-D1-D3
54243 P1=SQRT(D1*D1-XM(1)**2)
54244 P2=SQRT(D2*D2-XM(2)**2)
54245 P3=SQRT(D3*D3-XM(3)**2)
54246 CTHE1=2D0*PYR(0)-1D0
54247 ANG1=2D0*PYR(0)*PARU(1)
54248 CPHI1=COS(ANG1)
54249 SPHI1=SIN(ANG1)
54250 ARG=1D0-CTHE1**2
54251 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54252 STHE1=SQRT(ARG)
54253 P(N+1,1)=P1*STHE1*CPHI1
54254 P(N+1,2)=P1*STHE1*SPHI1
54255 P(N+1,3)=P1*CTHE1
54256 P(N+1,4)=D1
54257
54258C...GET CPHI3
54259 ANG3=2D0*PYR(0)*PARU(1)
54260 CPHI3=COS(ANG3)
54261 SPHI3=SIN(ANG3)
54262 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54263 ARG=1D0-CTHE3**2
54264 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54265 STHE3=SQRT(ARG)
54266 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54267 &+P3*STHE3*SPHI3*SPHI1
54268 &+P3*CTHE3*STHE1*CPHI1
54269 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54270 &-P3*STHE3*SPHI3*CPHI1
54271 &+P3*CTHE3*STHE1*SPHI1
54272 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54273 &+P3*CTHE3*CTHE1
54274 P(N+3,4)=D3
54275
54276 DO 200 I=1,3
54277 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54278 200 CONTINUE
54279 P(N+2,4)=D2
54280
54281 RETURN
54282 END
54283
54284
54285C*********************************************************************
54286
54287C...PYTECM
54288C...Finds the s-hat dependent eigenvalues of the inverse propagator
54289C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54290C...phase space generation. Extended to include techni-a meson, and
54291C...to return the width.
54292
54293 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54294
54295C...Double precision and integer declarations.
54296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54297 IMPLICIT INTEGER(I-N)
54298 INTEGER PYK,PYCHGE,PYCOMP
54299C...Parameter statement to help give large particle numbers.
54300 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54301 &KEXCIT=4000000,KDIMEN=5000000)
54302C...Commonblocks.
54303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54305 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54306 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54307 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54308
54309C...Local variables.
54310 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54311 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54312 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54313 INTEGER i,j,ierr
54314
54315 SH=SMIN
54316 SHR=SQRT(SH)
54317 AEM=PYALEM(SH)
54318
54319 SINW=MIN(SQRT(PARU(102)),1D0)
54320 COSW=SQRT(1D0-SINW**2)
54321 TANW=SINW/COSW
54322 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54323 QUPD=2D0*RTCM(2)-1D0
54324
54325 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54326 FAR=SQRT(AEM/ALPRHT)
54327 FAO=FAR*QUPD
54328 FZR=FAR*CT2W
54329 FZO=-FAO*TANW
54330 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54331 FWR=FAR/(2D0*SINW)
54332 FWX=-FWR/RTCM(47)
54333
54334 DO 110 I=1,5
54335 DO 100 J=1,5
54336 AT(I,J)=0D0
54337 100 CONTINUE
54338 110 CONTINUE
54339
54340C...NC
54341 IF(IOPT.EQ.1) THEN
54342 AR(1,1) = SH
54343 AR(2,2) = SH-PMAS(23,1)**2
54344 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54345 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54346 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54347 AR(1,2) = 0D0
54348 AR(2,1) = 0D0
54349 AR(1,3) = SH*FAR
54350 AR(3,1) = AR(1,3)
54351 AR(1,4) = SH*FAO
54352 AR(4,1) = AR(1,4)
54353 AR(2,3) = SH*FZR
54354 AR(3,2) = AR(2,3)
54355 AR(2,4) = SH*FZO
54356 AR(4,2) = AR(2,4)
54357 AR(3,4) = 0D0
54358 AR(4,3) = 0D0
54359 AR(2,5) = SH*FZX
54360 AR(5,2) = AR(2,5)
54361 AR(1,5) = 0D0
54362 AR(5,1) = AR(1,5)
54363 AR(3,5) = 0D0
54364 AR(5,3) = AR(3,5)
54365 AR(4,5) = 0D0
54366 AR(5,4) = AR(4,5)
54367 CALL PYWIDT(23,SH,WDTP,WDTE)
54368 AT(2,2) = WDTP(0)*SHR
54369 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54370 AT(3,3) = WDTP(0)*SHR
54371 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54372 AT(4,4) = WDTP(0)*SHR
54373 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54374 AT(5,5) = WDTP(0)*SHR
54375 IDIM=5
54376C...CC
54377 ELSE
54378 AR(1,1) = SH-PMAS(24,1)**2
54379 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54380 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54381 AR(1,2) = SH*FWR
54382 AR(2,1) = AR(1,2)
54383 AR(1,3) = SH*FWX
54384 AR(3,1) = AR(1,3)
54385 AR(2,3) = 0D0
54386 AR(3,2) = 0D0
54387 CALL PYWIDT(24,SH,WDTP,WDTE)
54388 AT(1,1) = WDTP(0)*SHR
54389 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54390 AT(2,2) = WDTP(0)*SHR
54391 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54392 AT(3,3) = WDTP(0)*SHR
54393 IDIM=3
54394 ENDIF
54395 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54396
54397 IMIN=1
54398 SXMN=1D20
54399 DO 120 I=1,IDIM
54400 WX(I)=SQRT(ABS(SH-WR(I)))
54401 WR(I)=ABS(WR(I))
54402 IF(WR(I).LT.SXMN) THEN
54403 SXMN=WR(I)
54404 IMIN=I
54405 ENDIF
54406 120 CONTINUE
54407 SMOU=WX(IMIN)**2
54408 WIDO=WI(IMIN)/SHR
54409
54410 RETURN
54411 END
54412C*********************************************************************
54413
54414C...PYXDIN
54415C...Universal Extra Dimensions Model (UED)
54416C...Initialize the xd masses and widths
54417C...M. ELKACIMI 4/03/2006
54418C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54419
54420 SUBROUTINE PYXDIN
54421
54422C...Double precision and integer declarations.
54423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54424 IMPLICIT INTEGER(I-N)
54425 INTEGER PYK,PYCHGE,PYCOMP
54426C...Commonblocks.
54427 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54428 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54429 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54430C...UED Pythia common
54431 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54432
54433C...SAVE statements
54434 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54435
54436C...Print out some info about the UED model
54437 WRITE(MSTU(11),7000)
54438 & ' ',
54439 & '********** PYXDIN: initialization of UED ******************',
54440 & ' ',
54441 & 'Universal Extra Dimensions (UED) switched on ',
54442 & ' ',
54443 & 'This implementation is courtesy of',
54444 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54445 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54446 & ' ',
54447 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54448 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54449 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54450 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54451 & '(Cheng, Matchev, Schmaltz).'
54452 WRITE(MSTU(11),7000)
54453 & ' ',
54454 & 'SM particles can propagate into one small extra dimension ',
54455 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54456 & 'graviton is further allowed to propagate into N = IUED(4)',
54457 & 'large (eV^-1) extra dimensions.'
54458 WRITE(MSTU(11),7000)
54459 & ' ',
54460 & 'The switches and parameters for UED are:',
54461 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54462 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54463 & ' IUED(3): (D=5) number of quark flavours',
54464 & ' IUED(4): (D=6) number of large extra dimensions into',
54465 & ' which the graviton propagates',
54466 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54467 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54468 & ' ',
54469 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54470 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54471 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54472 & ' when IUED(5)=0',
54473 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54474 WRITE(MSTU(11),7000)
54475 & ' ',
54476 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54477 & 'model, but is set through pmas(25,1).',
54478 & ' '
54479
54480C...Hardcoded switch, required by current implementation
54481 CALL PYGIVE('MSTP(42)=0')
54482
54483C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54484 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54485
54486C...Calculated the radiative corrections to the KK particle masses
54487 CALL PYUEDC
54488
54489C...Initialize the graviton mass
54490C...only if the KK particles decays gravitationally
54491 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54492
54493 WRITE(MSTU(11),7000)
54494 & '********** PYXDIN: UED initialization completed ***********'
54495
54496C...Format to use for comments
54497 7000 FORMAT(' * ',A)
54498
54499 RETURN
54500 END
54501C*********************************************************************
54502
54503C...PYUEDC
54504C...Auxiliary to PYXDIN
54505C...Mass kk states radiative corrections
54506C...Radiative corrections are included (hep/ph0204342)
54507
54508 SUBROUTINE PYUEDC
54509
54510C...Double precision and integer declarations.
54511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54512 IMPLICIT INTEGER(I-N)
54513 INTEGER PYK,PYCHGE,PYCOMP
54514
54515 PARAMETER(KKPART=25,KKFLA=450)
54516
54517C...UED Pythia common
54518 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54519C...Pythia common: particles properties
54520 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54521C...Parameters.
54522 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54523C...Decay information.
54524 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54525C...Resonance width and secondary decay treatment.
54526 COMMON/PYINT4/MWID(500),WIDS(500,5)
54527 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54528
54529C...Local variables
54530 DOUBLE PRECISION PI,QUP,QDW
54531 DOUBLE PRECISION WDTP,WDTE
54532 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54533 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54534 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54535 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54536 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54537 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54538 DOUBLE PRECISION SWW1,CWW1
54539 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54540 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54541 DOUBLE PRECISION SW21,CW21,SW021,CW021
54542 COMMON/SW1/SW021,CW021
54543C...UED related declarations:
54544C...equivalences between ordered particles (451->475)
54545C...and UED particle code (5 000 000 + id)
54546 DIMENSION IUEDEQ(475)
54547 DATA (IUEDEQ(I),I=451,475)/
54548C...Singlet quarks
54549 & 6100001,6100002,6100003,6100004,6100005,6100006,
54550C...Doublet quarks
54551 & 5100001,5100002,5100003,5100004,5100005,5100006,
54552C...Singlet leptons
54553 & 6100011,6100013,6100015,
54554C...Doublet leptons
54555 & 5100012,5100011,5100014,5100013,5100016,5100015,
54556C...Gauge boson KK excitations
54557 & 5100021,5100022,5100023,5100024/
54558
54559C...N.B. rinv=rued(1)
54560 IF(RUED(1).LE.0.)THEN
54561 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54562 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54563 RETURN
54564 ENDIF
54565
54566 PI=DACOS(-1.D0)
54567 RMZ = PMAS(23,1)
54568 RMZ2 = RMZ**2
54569 RMW = PMAS(24,1)
54570 RMW2 = RMW**2
54571 ALPHEM = PARU(101)
54572 QUP = 2./3.
54573 QDW = -1./3.
54574
54575c...qt is q-tilde, qs is q-star
54576c...strong coupling value
54577 Q2 = RUED(1)**2
54578 ALPHS=PYALPS(Q2)
54579
54580c...weak mixing angle
54581 SW2=PARU(102)
54582 CW2=1D0-PARU(102)
54583
54584c...for the mass corrections
54585 RMKK = RUED(1)
54586 RMKK2 = RMKK**2
54587 ZETA3= 1.2
54588
54589C... Either fix the cutoff scale LAMUED
54590 IF(IUED(5).EQ.0)THEN
54591 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54592C... or the ratio LAMUED/RINV (=product Lambda*R)
54593 ELSEIF(IUED(5).EQ.1)THEN
54594 LOGLAM = DLOG(RUED(4)**2)
54595 ELSE
54596 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54597 CALL PYSTOP(6000)
54598 ENDIF
54599
54600C...Calculate the radiative corrections for the UED KK masses
54601 IF(IUED(6).EQ.1)THEN
54602 RFACT=1.D0
54603C...or induce a minute mass difference
54604C...keeping the UED KK mass values nearly equal to 1/R
54605 ELSEIF(IUED(6).EQ.0)THEN
54606 RFACT=0.01D0
54607 ELSE
54608 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54609 CALL PYSTOP(6001)
54610 ENDIF
54611
54612c...Take into account only the strong interactions:
54613
54614c...The space bulk corrections :
54615 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54616c...The boundary terms:
54617 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54618
54619c...Mass corrections for fermions are extracted from
54620c...Phys. Rev. D66 036005(2002)9
54621 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54622 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54623 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54624 . +(ALPHEM/4./PI/CW2))*LOGLAM
54625 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54626 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54627
54628 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54629 . (ALPHEM/4./PI/CW2))*LOGLAM
54630 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54631
54632c...Vector boson masss matrix diagonalization
54633 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54634 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54635 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54636 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54637
54638c...Elements of the mass matrix
54639 A = RMZ2*SW2 + DBMB2 + DSMB2
54640 B = RMZ2*CW2 + DBMA2 + DSMA2
54641 C = RMZ2*DSQRT(SW2*CW2)
54642 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54643
54644c...Eigenvalues: corrections to X1 and Z1 masses
54645 DMB2 = (A+B-SQRDEL)/2.
54646 DMA2 = (A+B+SQRDEL)/2.
54647
54648c...Rotation angles
54649 SWW1 = 2*C
54650 CWW1 = A-B-SQRDEL
54651C...Weinberg angle
54652 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54653 CW21= 1. - SW21
54654
54655 SW021=SW21
54656 CW021=CW21
54657
54658c...Masses:
54659 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54660
54661 RMDQST=RMKK+RFACT*DBMQDO
54662 RMSQUS=RMKK+RFACT*DBMQU
54663 RMSQDS=RMKK+RFACT*DBMQD
54664
54665C...Note: MZ mass is included in ma2
54666 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54667 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54668 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54669
54670 RMLSLD=RMKK+RFACT*DBMLDO
54671 RMLSLE=RMKK+RFACT*DBMLE
54672
54673 DO 100 IPART=1,5,2
54674 PMAS(KKFLA+IPART,1)=RMSQDS
54675 100 CONTINUE
54676 DO 110 IPART=2,6,2
54677 PMAS(KKFLA+IPART,1)=RMSQUS
54678 110 CONTINUE
54679 DO 120 IPART=7,12
54680 PMAS(KKFLA+IPART,1)=RMDQST
54681 120 CONTINUE
54682 DO 130 IPART=13,15
54683 PMAS(KKFLA+IPART,1)=RMLSLE
54684 130 CONTINUE
54685 DO 140 IPART=16,21
54686 PMAS(KKFLA+IPART,1)=RMLSLD
54687 140 CONTINUE
54688 PMAS(KKFLA+22,1)=RMGST
54689 PMAS(KKFLA+23,1)=RMPHST
54690 PMAS(KKFLA+24,1)=RMZST
54691 PMAS(KKFLA+25,1)=RMWST
54692
54693 WRITE(MSTU(11),7000) ' PYUEDC: ',
54694 & 'UED Mass Spectrum (GeV) :'
54695 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54696 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54697 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54698 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54699 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54700 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54701 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54702 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54703 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54704 WRITE(MSTU(11),7000) ' '
54705
54706C...Initialize widths, branching ratios and life time
54707 DO 199 IPART=1,25
54708 KC=KKFLA+IPART
54709 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54710 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54711 IF(WDTP(0).LE.0)THEN
54712 WRITE(MSTU(11),*)
54713 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54714 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54715 GOTO 199
54716 ELSE
54717 DO 180 IDC=1,MDCY(KC,3)
54718 IC=IDC+MDCY(KC,2)-1
54719 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54720C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54721 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54722 BRAT(IC)=WDTP(IDC)/WDTP(0)
54723 ENDIF
54724 180 CONTINUE
54725 ENDIF
54726 ENDIF
54727 199 CONTINUE
54728
54729C...Format to use for comments
54730 7000 FORMAT(' * ',A)
54731 7100 FORMAT(' * ',A,F12.3)
54732
54733 END
54734C********************************************************************
54735C...PYXUED
54736C... Last change:
54737C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54738C... Original version:
54739C... M. El Kacimi
54740C... 05/07/2005
54741C Universal Extra Dimensions Subprocess cross sections
54742C The expressions used are from atl-com-phys-2005-003
54743C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54744C For each UED subprocess, the color flow used is the same
54745C as the equivalent QCD subprocess. Different configuration
54746C color flows are considered to have the same probability.
54747C
54748C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54749C by G.Azuelos and P.H.Beauchemin.
54750C
54751C This routine is called from pysigh.
54752
54753 SUBROUTINE PYXUED(NCHN,SIGS)
54754
54755C...Double precision and integer declarations
54756 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54757 IMPLICIT INTEGER(I-N)
54758C...
54759 INTEGER NGRDEC
54760 COMMON/DECMOD/NGRDEC
54761C...
54762 PARAMETER(KKPART=25,KKFLA=450)
54763C...Commonblocks
54764 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54765 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54766 COMMON/PYINT1/MINT(400),VINT(400)
54767 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54768 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54769 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54770 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54771 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54772 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54773C...UED Pythia common
54774 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54775C...Local arrays and complex variables
54776 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54777 + ,FAC1,XMNKK,XMUED,SIGS
54778 INTEGER NCHN
54779
54780C...Return if UED not switched on
54781 IF (IUED(1).LE.0) THEN
54782 RETURN
54783 ENDIF
54784
54785C...Energy scale of the parton processus
54786C...taken equal to the mass of the final state kk
54787c Q2=XMNKK**2
54788
54789C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54790 XMNKK=PMAS(KKFLA+23,1)
54791
54792C...To compare the cross section with phys-pub-2005-03
54793C...(no radiative corrections),
54794C...take xmnkk=rinv and q2=rinv**2
54795c++lnk
54796C...n.b. (rinv=rued(1))
54797c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54798 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54799c--lnk
54800
54801 SHAT=VINT(44)
54802 SP=SHAT
54803 THAT=VINT(45)
54804 TP=THAT-XMNKK**2
54805 UHAT=VINT(46)
54806 UP=UHAT-XMNKK**2
54807 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54808 PI=DACOS(-1.D0)
54809c++lnk
54810c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54811 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54812
54813c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54814 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54815c--lnk
54816
54817C...Strong coupling value
54818 ALPHAS=PYALPS(Q2)
54819
54820 IF(ISUB.EQ.311)THEN
54821C...gg --> g* g*
54822 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54823 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54824 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54825 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54826 & 12.*TP**2*UP**3+6*TP*UP**4)
54827 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54828 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54829 & 6.*TP*UP**5+2.*UP**6)
54830 NCHN=NCHN+1
54831 ISIG(NCHN,1)=21
54832 ISIG(NCHN,2)=21
54833C...Three color flow configurations (qcd g+g->g+g)
54834 XCOL=PYR(0)
54835 IF(XCOL.LE.1./3.)THEN
54836 ISIG(NCHN,3)=1
54837 ELSEIF(XCOL.LE.2./3.)THEN
54838 ISIG(NCHN,3)=2
54839 ELSE
54840 ISIG(NCHN,3)=3
54841 ENDIF
54842 SIGH(NCHN)=COMFAC*XMUED
54843 ELSEIF(ISUB.EQ.312)THEN
54844C...q + g -> q*_D + g*, q*_S + g*
54845C...(the two channels have the same cross section)
54846 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54847 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54848 & 5.*SP**4*UP**2+12.*SP**5*UP)
54849 XMUED=COMFAC*2.*XMUED
54850
54851 DO 190 I=MMINA,MMAXA
54852 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54853 DO 180 ISDE=1,2
54854
54855 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54856 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54857 NCHN=NCHN+1
54858 ISIG(NCHN,ISDE)=I
54859 ISIG(NCHN,3-ISDE)=21
54860 ISIG(NCHN,3)=1
54861 SIGH(NCHN)=XMUED
54862 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54863 180 CONTINUE
54864 190 CONTINUE
54865
54866 ELSEIF(ISUB.EQ.313)THEN
54867C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54868C...(the two channels have the same cross section)
54869C...qi and qj have the same charge sign
54870 DO 100 I=MMIN1,MMAX1
54871 IA=IABS(I)
54872 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54873 DO 101 J=MMIN2,MMAX2
54874 JA=IABS(J)
54875 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54876 & EQ.0) GOTO 101
54877 IF(J*I.LE.0)GOTO 101
54878 NCHN=NCHN+1
54879 ISIG(NCHN,1)=I
54880 ISIG(NCHN,2)=J
54881 IF(J.EQ.I)THEN
54882 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54883 XMUED=FAC1*
54884 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54885 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54886 & 20.*TP**2*UP**2+56./3.*
54887 & TP*UP**3+8.*UP**4)
54888 SIGH(NCHN)=COMFAC*2.*XMUED
54889 ISIG(NCHN,3)=1
54890 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54891 ELSE
54892 FAC1=2./9.*ALPHAS**2/TP**2
54893 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54894 SIGH(NCHN)=COMFAC*2.*XMUED
54895 ISIG(NCHN,3)=1
54896 ENDIF
54897 101 CONTINUE
54898 100 CONTINUE
54899 ELSEIF(ISUB.EQ.314)THEN
54900C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54901C...(the two channels have the same cross section)
54902 NCHN=NCHN+1
54903 ISIG(NCHN,1)=21
54904 ISIG(NCHN,2)=21
54905 ISIG(NCHN,3)=INT(1.5+PYR(0))
54906
54907 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54908 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54909 + +4.*UP**4+4*TP**4)
54910 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54911 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54912 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54913
54914 SIGH(NCHN)=COMFAC*XMUED
54915C...has been multiplied by 5: all possible quark flavors in final state
54916
54917 ELSEIF(ISUB.EQ.315)THEN
54918C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54919C...(the two channels have the same cross section)
54920 DO 141 I=MMIN1,MMAX1
54921 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54922 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54923 DO 142 J=MMIN2,MMAX2
54924 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54925 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54926 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54927 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54928 & 2./3.*SP**3*TP+SP**4)
54929 NCHN=NCHN+1
54930 ISIG(NCHN,1)=I
54931 ISIG(NCHN,2)=-I
54932 ISIG(NCHN,3)=1
54933 SIGH(NCHN)=COMFAC*2.*XMUED
54934 142 CONTINUE
54935 141 CONTINUE
54936 ELSEIF(ISUB.EQ.316)THEN
54937C...q + qbar' -> q*_D + q*_Sbar'
54938 FAC1=2./9.*ALPHAS**2
54939 DO 300 I=MMIN1,MMAX1
54940 IA=IABS(I)
54941 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54942 DO 301 J=MMIN2,MMAX2
54943 JA=IABS(J)
54944 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54945 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54946 NCHN=NCHN+1
54947 ISIG(NCHN,1)=I
54948 ISIG(NCHN,2)=J
54949 ISIG(NCHN,3)=1
54950 FAC1=2./9.*ALPHAS**2/TP**2
54951 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54952 SIGH(NCHN)=COMFAC*XMUED
54953 301 CONTINUE
54954 300 CONTINUE
54955
54956 ELSEIF(ISUB.EQ.317)THEN
54957C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54958C...(the two channels have the same cross section)
54959 DO 400 I=MMIN1,MMAX1
54960 IA=IABS(I)
54961 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54962 DO 401 J=MMIN1,MMAX1
54963 JA=IABS(J)
54964 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54965 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54966 NCHN=NCHN+1
54967 ISIG(NCHN,1)=I
54968 ISIG(NCHN,2)=J
54969 ISIG(NCHN,3)=1
54970 FAC1=1./18.*ALPHAS**2/TP**2
54971 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54972 SIGH(NCHN)=COMFAC*2.*XMUED
54973 401 CONTINUE
54974 400 CONTINUE
54975 ELSEIF(ISUB.EQ.318)THEN
54976C...q + q' -> q*_D + q*_S'
54977 DO 500 I=MMIN1,MMAX1
54978 IA=IABS(I)
54979 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54980 DO 501 J=MMIN2,MMAX2
54981 JA=IABS(J)
54982 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54983 IF(J*I.LE.0)GOTO 501
54984 IF(IA.EQ.JA)THEN
54985 NCHN=NCHN+1
54986 ISIG(NCHN,1)=I
54987 ISIG(NCHN,2)=J
54988 ISIG(NCHN,3)=INT(1.5+PYR(0))
54989 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54990 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
54991 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
54992 SIGH(NCHN)=COMFAC*XMUED
54993 ELSE
54994 NCHN=NCHN+1
54995 ISIG(NCHN,1)=I
54996 ISIG(NCHN,2)=J
54997 ISIG(NCHN,3)=1
54998 FAC1=1./18.*ALPHAS**2/TP**2
54999 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55000 SIGH(NCHN)=COMFAC*2.*XMUED
55001 ENDIF
55002 501 CONTINUE
55003 500 CONTINUE
55004 ELSEIF(ISUB.EQ.319)THEN
55005C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55006C...(the two channels have the same cross section)
55007 DO 741 I=MMIN1,MMAX1
55008 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55009 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55010 DO 742 J=MMIN2,MMAX2
55011 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55012 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55013 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55014 NCHN=NCHN+1
55015 ISIG(NCHN,1)=I
55016 ISIG(NCHN,2)=-I
55017 ISIG(NCHN,3)=1
55018 SIGH(NCHN)=COMFAC*2.*XMUED
55019 742 CONTINUE
55020 741 CONTINUE
55021
55022 ENDIF
55023
55024 RETURN
55025 END
55026C*********************************************************************
55027
55028C...PYGRAM
55029C...Universal Extra Dimensions Model (UED)
55030C...Computation of the Graviton mass.
55031
55032 SUBROUTINE PYGRAM(IN)
55033
55034C...Double precision and integer declarations
55035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55036 IMPLICIT INTEGER(I-N)
55037
55038C...Pythia commonblocks
55039 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55040 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55041C...UED Pythia common
55042 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55043
55044C...Local variables
55045 INTEGER KCFLA,NMAX
55046 PARAMETER(KCFLA=450,NMAX=5000)
55047 DIMENSION YVEC(5000),RESVEC(5000)
55048 COMMON/INTSAV/YSAV,YMAX,RESMAX
55049 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55050 COMMON/KAPPA/XKAPPA
55051
55052C...External function (used in call to PYGAUS)
55053 EXTERNAL PYGRAW
55054
55055C...SAVE statements
55056 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55057
55058C...Initialization
55059 NDIM=IUED(4)
55060 RINV=RUED(1)
55061 XMD=RUED(2)
55062 PI=PARU(1)
55063
55064C...Initialize for numerical integration
55065 XMPLNK=2.4D+18
55066 XKAPPA=DSQRT(2.D0)/XMPLNK
55067
55068C...For NDIM=2, compute graviton mass distribution numerically
55069 IF(NDIM.EQ.2)THEN
55070
55071C... For first event: tabulate distribution of stepwise integrals:
55072C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55073 IF(IN.EQ.0)THEN
55074 RESMAX = 0D0
55075 YMAX = 0D0
55076 DO 100 I=1,NMAX
55077 YSAV = (I-0.5)/DBLE(NMAX)
55078 TOL = 1D-6
55079C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55080 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55081 YVEC(I) = YSAV
55082 RESVEC(I) = RESINT
55083C... Save max of distribution (for accept/reject below)
55084 IF(RESINT.GT.RESMAX)THEN
55085 RESMAX = RESINT
55086 YMAX = YVEC(I)
55087 ENDIF
55088 100 CONTINUE
55089 ENDIF
55090
55091C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55092 PCUJET=1D0
55093 KCGAKK=KCFLA+23
55094 XMGAMK=PMAS(KCGAKK,1)
55095
55096C... Pick random graviton mass, accept according to stored integrals
55097 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55098 110 RMG=AMMAX*PYR(0)
55099 X=RMG/XMGAMK
55100
55101C... Bin enumeration starts at 1, but make sure always in range
55102 IBIN=INT(NMAX*X)+1
55103 IBIN=MIN(IBIN,NMAX)
55104 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55105
55106C... For NDIM=4 and 6, the analytical expression for the
55107C... graviton mass distribution integral is used.
55108 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55109
55110C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55111 PCUJET=1D0
55112
55113C... KK photon (?) compressed code and mass
55114 KCGAKK=KCFLA+23
55115 XMGAMK=PMAS(KCGAKK,1)
55116
55117C... Find maximum of (dGamma/dMg)
55118 IF(IN.EQ.0)THEN
55119 RESMAX=0D0
55120 YMAX=0D0
55121 DO 120 I=1,NMAX-1
55122 Y=I/DBLE(NMAX)
55123 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55124 IF(RESINT.GE.RESMAX)THEN
55125 RESMAX=RESINT
55126 YMAX=Y
55127 ENDIF
55128 120 CONTINUE
55129 ENDIF
55130
55131C... Pick random graviton mass, accept/reject
55132 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55133 130 RMG=AMMAX*PYR(0)
55134 X=RMG/XMGAMK
55135 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55136 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55137
55138C... If the user has not chosen N=2,4 or 6, STOP
55139 ELSE
55140 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55141 & ' (MUST BE 2, 4, OR 6) '
55142 CALL PYSTOP(6002)
55143 ENDIF
55144
55145C... Now store the sampled Mg
55146 PMAS(39,1)=RMG
55147
55148 RETURN
55149 END
55150
55151C*********************************************************************
55152
55153C...PYGRAW
55154C...Universal Extra Dimensions Model (UED)
55155C...
55156C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55157C...
55158C...Integrand for the KK boson -> SM boson + graviton
55159C...graviton mass distribution (and gravity mediated total width),
55160C...which contains (see 0201300 and below for the full product)
55161C...the gravity mediated partial decay width Gamma(xx, yy)
55162C... i.e. GRADEN(YY)*PYWDKK(XXA)
55163C... where xx is exclusive to gravity
55164C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55165C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55166
55167 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55168
55169C...Double precision and integer declarations
55170 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55171 IMPLICIT INTEGER (I-N)
55172
55173C...Pythia commonblocks
55174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55175
55176C...Local UED commonblocks and variables
55177 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55178 COMMON/INTSAV/YSAV,YMAX,RESMAX
55179
55180C...SAVE statements
55181 SAVE /PYDAT1/,/INTSAV/
55182
55183C...External: Pythia's Gamma function
55184 EXTERNAL PYGAMM
55185
55186C...Pi
55187 PI=PARU(1)
55188 PI2=PI*PI
55189
55190 YMIN=1.D-9/RINV
55191 YY=YSAV
55192 XX=DSQRT(1.-YY**2)*YIN
55193 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55194 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55195 XND=(NDIM-1.)/2.
55196 GAMMN=PYGAMM(XND)
55197 FAC=FAC/GAMMN
55198 XXA=DSQRT(XX**2+YY**2)
55199 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55200
55201 PYGRAW=DJAC*
55202 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55203
55204 RETURN
55205 END
55206C*********************************************************************
55207
55208C...PYWDKK
55209C...Universal Extra Dimensions Model (UED)
55210C...
55211C...Multiplied by the square modulus of a form factor
55212C...(see GRADEN in function PYGRAW)
55213C...PYWDKK is the KK boson -> SM boson + graviton
55214C...gravity mediated partial decay width Gamma(xx, yy)
55215C... where xx is exclusive to gravity
55216C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55217C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55218C...
55219C...N.B. The Feynman rules for the couplings of the graviton fields
55220C...to the UED fields are related to the corresponding couplings of
55221C...the graviton fields to the SM fields by the form factor.
55222
55223 DOUBLE PRECISION FUNCTION PYWDKK(X)
55224
55225C...Double precision and integer declarations
55226 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55227 IMPLICIT INTEGER (I-N)
55228
55229C...Pythia commonblocks
55230 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55231 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55232
55233C...Local UED commonblocks and variables
55234 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55235 COMMON/KAPPA/XKAPPA
55236
55237C...SAVE statements
55238 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55239
55240 PI=PARU(1)
55241
55242C...gamma* mass 473
55243 KCQKK=473
55244 XMNKK=PMAS(KCQKK,1)
55245
55246C...Bosons partial width Macesanu hep-ph/0201300
55247 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55248 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55249
55250 RETURN
55251 END
55252
55253C*********************************************************************
55254
55255C...PYEIGC
55256C...Finds eigenvalues of a general complex matrix
55257C
55258C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55259C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55260C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55261C OF A COMPLEX GENERAL MATRIX.
55262C
55263C ON INPUT
55264C
55265C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55266C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55267C DIMENSION STATEMENT.
55268C
55269C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55270C
55271C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55272C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55273C
55274C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55275C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55276C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55277C
55278C ON OUTPUT
55279C
55280C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55281C RESPECTIVELY, OF THE EIGENVALUES.
55282C
55283C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55284C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55285C
55286C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55287C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55288C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55289C
55290C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55291C
55292C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55293C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55294C
55295C THIS VERSION DATED AUGUST 1983.
55296C
55297
55298 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55299
55300 INTEGER N,NM,IS1,IS2,IERR,MATZ
55301 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55302 X FV1(5),FV2(5),FV3(5)
55303 IF (N .LE. NM) GOTO 100
55304 IERR = 10 * N
55305 GOTO 120
55306C
55307 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55308 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55309 IF (MATZ .NE. 0) GOTO 110
55310C .......... FIND EIGENVALUES ONLY ..........
55311 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55312 GOTO 120
55313C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55314 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55315 IF (IERR .NE. 0) GOTO 120
55316 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55317 120 RETURN
55318 END
55319
55320C*********************************************************************
55321
55322C...PYCMQR
55323C...Auxiliary to PYEICG.
55324C
55325C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55326C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55327C AND WILKINSON.
55328C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55329C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55330C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55331C
55332C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55333C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55334C
55335C ON INPUT
55336C
55337C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55338C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55339C DIMENSION STATEMENT.
55340C
55341C N IS THE ORDER OF THE MATRIX.
55342C
55343C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55344C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55345C SET LOW=1, IGH=N.
55346C
55347C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55348C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55349C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55350C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55351C THE REDUCTION BY CORTH, IF PERFORMED.
55352C
55353C ON OUTPUT
55354C
55355C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55356C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55357C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55358C EIGENVECTORS IS TO BE PERFORMED.
55359C
55360C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55361C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55362C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55363C FOR INDICES IERR+1,...,N.
55364C
55365C IERR IS SET TO
55366C ZERO FOR NORMAL RETURN,
55367C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55368C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55369C
55370C CALLS PYCDIV FOR COMPLEX DIVISION.
55371C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55372C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55373C
55374C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55375C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55376C
55377C THIS VERSION DATED AUGUST 1983.
55378C
55379
55380 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55381
55382 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55383 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55384 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55385 X PYTHAG
55386
55387 IERR = 0
55388 IF (LOW .EQ. IGH) GOTO 130
55389C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55390 L = LOW + 1
55391C
55392 DO 120 I = L, IGH
55393 LL = MIN0(I+1,IGH)
55394 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55395 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55396 YR = HR(I,I-1) / NORM
55397 YI = HI(I,I-1) / NORM
55398 HR(I,I-1) = NORM
55399 HI(I,I-1) = 0.0D0
55400C
55401 DO 100 J = I, IGH
55402 SI = YR * HI(I,J) - YI * HR(I,J)
55403 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55404 HI(I,J) = SI
55405 100 CONTINUE
55406C
55407 DO 110 J = LOW, LL
55408 SI = YR * HI(J,I) + YI * HR(J,I)
55409 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55410 HI(J,I) = SI
55411 110 CONTINUE
55412C
55413 120 CONTINUE
55414C .......... STORE ROOTS ISOLATED BY CBAL ..........
55415 130 DO 140 I = 1, N
55416 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55417 WR(I) = HR(I,I)
55418 WI(I) = HI(I,I)
55419 140 CONTINUE
55420C
55421 EN = IGH
55422 TR = 0.0D0
55423 TI = 0.0D0
55424 ITN = 30*N
55425C .......... SEARCH FOR NEXT EIGENVALUE ..........
55426 150 IF (EN .LT. LOW) GOTO 320
55427 ITS = 0
55428 ENM1 = EN - 1
55429C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55430C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55431 160 DO 170 LL = LOW, EN
55432 L = EN + LOW - LL
55433 IF (L .EQ. LOW) GOTO 180
55434 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55435 X + DABS(HR(L,L)) + DABS(HI(L,L))
55436 TST2 = TST1 + DABS(HR(L,L-1))
55437 IF (TST2 .EQ. TST1) GOTO 180
55438 170 CONTINUE
55439C .......... FORM SHIFT ..........
55440 180 IF (L .EQ. EN) GOTO 300
55441 IF (ITN .EQ. 0) GOTO 310
55442 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55443 SR = HR(EN,EN)
55444 SI = HI(EN,EN)
55445 XR = HR(ENM1,EN) * HR(EN,ENM1)
55446 XI = HI(ENM1,EN) * HR(EN,ENM1)
55447 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55448 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55449 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55450 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55451 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55452 ZZR = -ZZR
55453 ZZI = -ZZI
55454 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55455 SR = SR - XR
55456 SI = SI - XI
55457 GOTO 210
55458C .......... FORM EXCEPTIONAL SHIFT ..........
55459 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55460 SI = 0.0D0
55461C
55462 210 DO 220 I = LOW, EN
55463 HR(I,I) = HR(I,I) - SR
55464 HI(I,I) = HI(I,I) - SI
55465 220 CONTINUE
55466C
55467 TR = TR + SR
55468 TI = TI + SI
55469 ITS = ITS + 1
55470 ITN = ITN - 1
55471C .......... REDUCE TO TRIANGLE (ROWS) ..........
55472 LP1 = L + 1
55473C
55474 DO 240 I = LP1, EN
55475 SR = HR(I,I-1)
55476 HR(I,I-1) = 0.0D0
55477 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55478 XR = HR(I-1,I-1) / NORM
55479 WR(I-1) = XR
55480 XI = HI(I-1,I-1) / NORM
55481 WI(I-1) = XI
55482 HR(I-1,I-1) = NORM
55483 HI(I-1,I-1) = 0.0D0
55484 HI(I,I-1) = SR / NORM
55485C
55486 DO 230 J = I, EN
55487 YR = HR(I-1,J)
55488 YI = HI(I-1,J)
55489 ZZR = HR(I,J)
55490 ZZI = HI(I,J)
55491 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55492 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55493 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55494 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55495 230 CONTINUE
55496C
55497 240 CONTINUE
55498C
55499 SI = HI(EN,EN)
55500 IF (SI .EQ. 0.0D0) GOTO 250
55501 NORM = PYTHAG(HR(EN,EN),SI)
55502 SR = HR(EN,EN) / NORM
55503 SI = SI / NORM
55504 HR(EN,EN) = NORM
55505 HI(EN,EN) = 0.0D0
55506C .......... INVERSE OPERATION (COLUMNS) ..........
55507 250 DO 280 J = LP1, EN
55508 XR = WR(J-1)
55509 XI = WI(J-1)
55510C
55511 DO 270 I = L, J
55512 YR = HR(I,J-1)
55513 YI = 0.0D0
55514 ZZR = HR(I,J)
55515 ZZI = HI(I,J)
55516 IF (I .EQ. J) GOTO 260
55517 YI = HI(I,J-1)
55518 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55519 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55520 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55521 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55522 270 CONTINUE
55523C
55524 280 CONTINUE
55525C
55526 IF (SI .EQ. 0.0D0) GOTO 160
55527C
55528 DO 290 I = L, EN
55529 YR = HR(I,EN)
55530 YI = HI(I,EN)
55531 HR(I,EN) = SR * YR - SI * YI
55532 HI(I,EN) = SR * YI + SI * YR
55533 290 CONTINUE
55534C
55535 GOTO 160
55536C .......... A ROOT FOUND ..........
55537 300 WR(EN) = HR(EN,EN) + TR
55538 WI(EN) = HI(EN,EN) + TI
55539 EN = ENM1
55540 GOTO 150
55541C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55542C CONVERGED AFTER 30*N ITERATIONS ..........
55543 310 IERR = EN
55544 320 RETURN
55545 END
55546
55547C*********************************************************************
55548
55549C...PYCMQ2
55550C...Auxiliary to PYEICG.
55551C
55552C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55553C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55554C AND WILKINSON.
55555C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55556C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55557C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55558C
55559C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55560C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55561C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55562C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55563C THIS GENERAL MATRIX TO HESSENBERG FORM.
55564C
55565C ON INPUT
55566C
55567C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55568C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55569C DIMENSION STATEMENT.
55570C
55571C N IS THE ORDER OF THE MATRIX.
55572C
55573C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55574C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55575C SET LOW=1, IGH=N.
55576C
55577C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55578C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55579C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55580C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55581C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55582C
55583C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55584C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55585C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55586C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55587C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55588C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55589C ARBITRARY.
55590C
55591C ON OUTPUT
55592C
55593C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55594C HAVE BEEN DESTROYED.
55595C
55596C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55597C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55598C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55599C FOR INDICES IERR+1,...,N.
55600C
55601C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55602C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55603C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55604C THE EIGENVECTORS HAS BEEN FOUND.
55605C
55606C IERR IS SET TO
55607C ZERO FOR NORMAL RETURN,
55608C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55609C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55610C
55611C CALLS PYCDIV FOR COMPLEX DIVISION.
55612C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55613C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55614C
55615C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55616C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55617C
55618C THIS VERSION DATED OCTOBER 1989.
55619C
55620C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55621C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55622C
55623
55624 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55625
55626 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55627 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55628 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55629 X ORTR(5),ORTI(5)
55630 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55631 X PYTHAG
55632
55633 IERR = 0
55634C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55635 DO 110 J = 1, N
55636C
55637 DO 100 I = 1, N
55638 ZR(I,J) = 0.0D0
55639 ZI(I,J) = 0.0D0
55640 100 CONTINUE
55641 ZR(J,J) = 1.0D0
55642 110 CONTINUE
55643C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55644C FROM THE INFORMATION LEFT BY CORTH ..........
55645 IEND = IGH - LOW - 1
55646 IF (IEND.LT.0) GOTO 220
55647 IF (IEND.EQ.0) GOTO 170
55648C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55649 DO 160 II = 1, IEND
55650 I = IGH - II
55651 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55652 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55653C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55654 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55655 IP1 = I + 1
55656C
55657 DO 120 K = IP1, IGH
55658 ORTR(K) = HR(K,I-1)
55659 ORTI(K) = HI(K,I-1)
55660 120 CONTINUE
55661C
55662 DO 150 J = I, IGH
55663 SR = 0.0D0
55664 SI = 0.0D0
55665C
55666 DO 130 K = I, IGH
55667 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55668 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55669 130 CONTINUE
55670C
55671 SR = SR / NORM
55672 SI = SI / NORM
55673C
55674 DO 140 K = I, IGH
55675 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55676 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55677 140 CONTINUE
55678C
55679 150 CONTINUE
55680C
55681 160 CONTINUE
55682C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55683 170 L = LOW + 1
55684C
55685 DO 210 I = L, IGH
55686 LL = MIN0(I+1,IGH)
55687 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55688 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55689 YR = HR(I,I-1) / NORM
55690 YI = HI(I,I-1) / NORM
55691 HR(I,I-1) = NORM
55692 HI(I,I-1) = 0.0D0
55693C
55694 DO 180 J = I, N
55695 SI = YR * HI(I,J) - YI * HR(I,J)
55696 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55697 HI(I,J) = SI
55698 180 CONTINUE
55699C
55700 DO 190 J = 1, LL
55701 SI = YR * HI(J,I) + YI * HR(J,I)
55702 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55703 HI(J,I) = SI
55704 190 CONTINUE
55705C
55706 DO 200 J = LOW, IGH
55707 SI = YR * ZI(J,I) + YI * ZR(J,I)
55708 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55709 ZI(J,I) = SI
55710 200 CONTINUE
55711C
55712 210 CONTINUE
55713C .......... STORE ROOTS ISOLATED BY CBAL ..........
55714 220 DO 230 I = 1, N
55715 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55716 WR(I) = HR(I,I)
55717 WI(I) = HI(I,I)
55718 230 CONTINUE
55719C
55720 EN = IGH
55721 TR = 0.0D0
55722 TI = 0.0D0
55723 ITN = 30*N
55724C .......... SEARCH FOR NEXT EIGENVALUE ..........
55725 240 IF (EN .LT. LOW) GOTO 430
55726 ITS = 0
55727 ENM1 = EN - 1
55728C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55729C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55730 250 DO 260 LL = LOW, EN
55731 L = EN + LOW - LL
55732 IF (L .EQ. LOW) GOTO 270
55733 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55734 X + DABS(HR(L,L)) + DABS(HI(L,L))
55735 TST2 = TST1 + DABS(HR(L,L-1))
55736 IF (TST2 .EQ. TST1) GOTO 270
55737 260 CONTINUE
55738C .......... FORM SHIFT ..........
55739 270 IF (L .EQ. EN) GOTO 420
55740 IF (ITN .EQ. 0) GOTO 550
55741 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55742 SR = HR(EN,EN)
55743 SI = HI(EN,EN)
55744 XR = HR(ENM1,EN) * HR(EN,ENM1)
55745 XI = HI(ENM1,EN) * HR(EN,ENM1)
55746 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55747 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55748 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55749 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55750 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55751 ZZR = -ZZR
55752 ZZI = -ZZI
55753 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55754 SR = SR - XR
55755 SI = SI - XI
55756 GOTO 300
55757C .......... FORM EXCEPTIONAL SHIFT ..........
55758 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55759 SI = 0.0D0
55760C
55761 300 DO 310 I = LOW, EN
55762 HR(I,I) = HR(I,I) - SR
55763 HI(I,I) = HI(I,I) - SI
55764 310 CONTINUE
55765C
55766 TR = TR + SR
55767 TI = TI + SI
55768 ITS = ITS + 1
55769 ITN = ITN - 1
55770C .......... REDUCE TO TRIANGLE (ROWS) ..........
55771 LP1 = L + 1
55772C
55773 DO 330 I = LP1, EN
55774 SR = HR(I,I-1)
55775 HR(I,I-1) = 0.0D0
55776 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55777 XR = HR(I-1,I-1) / NORM
55778 WR(I-1) = XR
55779 XI = HI(I-1,I-1) / NORM
55780 WI(I-1) = XI
55781 HR(I-1,I-1) = NORM
55782 HI(I-1,I-1) = 0.0D0
55783 HI(I,I-1) = SR / NORM
55784C
55785 DO 320 J = I, N
55786 YR = HR(I-1,J)
55787 YI = HI(I-1,J)
55788 ZZR = HR(I,J)
55789 ZZI = HI(I,J)
55790 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55791 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55792 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55793 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55794 320 CONTINUE
55795C
55796 330 CONTINUE
55797C
55798 SI = HI(EN,EN)
55799 IF (SI .EQ. 0.0D0) GOTO 350
55800 NORM = PYTHAG(HR(EN,EN),SI)
55801 SR = HR(EN,EN) / NORM
55802 SI = SI / NORM
55803 HR(EN,EN) = NORM
55804 HI(EN,EN) = 0.0D0
55805 IF (EN .EQ. N) GOTO 350
55806 IP1 = EN + 1
55807C
55808 DO 340 J = IP1, N
55809 YR = HR(EN,J)
55810 YI = HI(EN,J)
55811 HR(EN,J) = SR * YR + SI * YI
55812 HI(EN,J) = SR * YI - SI * YR
55813 340 CONTINUE
55814C .......... INVERSE OPERATION (COLUMNS) ..........
55815 350 DO 390 J = LP1, EN
55816 XR = WR(J-1)
55817 XI = WI(J-1)
55818C
55819 DO 370 I = 1, J
55820 YR = HR(I,J-1)
55821 YI = 0.0D0
55822 ZZR = HR(I,J)
55823 ZZI = HI(I,J)
55824 IF (I .EQ. J) GOTO 360
55825 YI = HI(I,J-1)
55826 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55827 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55828 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55829 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55830 370 CONTINUE
55831C
55832 DO 380 I = LOW, IGH
55833 YR = ZR(I,J-1)
55834 YI = ZI(I,J-1)
55835 ZZR = ZR(I,J)
55836 ZZI = ZI(I,J)
55837 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55838 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55839 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55840 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55841 380 CONTINUE
55842C
55843 390 CONTINUE
55844C
55845 IF (SI .EQ. 0.0D0) GOTO 250
55846C
55847 DO 400 I = 1, EN
55848 YR = HR(I,EN)
55849 YI = HI(I,EN)
55850 HR(I,EN) = SR * YR - SI * YI
55851 HI(I,EN) = SR * YI + SI * YR
55852 400 CONTINUE
55853C
55854 DO 410 I = LOW, IGH
55855 YR = ZR(I,EN)
55856 YI = ZI(I,EN)
55857 ZR(I,EN) = SR * YR - SI * YI
55858 ZI(I,EN) = SR * YI + SI * YR
55859 410 CONTINUE
55860C
55861 GOTO 250
55862C .......... A ROOT FOUND ..........
55863 420 HR(EN,EN) = HR(EN,EN) + TR
55864 WR(EN) = HR(EN,EN)
55865 HI(EN,EN) = HI(EN,EN) + TI
55866 WI(EN) = HI(EN,EN)
55867 EN = ENM1
55868 GOTO 240
55869C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55870C VECTORS OF UPPER TRIANGULAR FORM ..........
55871 430 NORM = 0.0D0
55872C
55873 DO 440 I = 1, N
55874C
55875 DO 440 J = I, N
55876 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55877 IF (TR .GT. NORM) NORM = TR
55878 440 CONTINUE
55879C
55880 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55881C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55882 DO 500 NN = 2, N
55883 EN = N + 2 - NN
55884 XR = WR(EN)
55885 XI = WI(EN)
55886 HR(EN,EN) = 1.0D0
55887 HI(EN,EN) = 0.0D0
55888 ENM1 = EN - 1
55889C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55890 DO 490 II = 1, ENM1
55891 I = EN - II
55892 ZZR = 0.0D0
55893 ZZI = 0.0D0
55894 IP1 = I + 1
55895C
55896 DO 450 J = IP1, EN
55897 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55898 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55899 450 CONTINUE
55900C
55901 YR = XR - WR(I)
55902 YI = XI - WI(I)
55903 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55904 TST1 = NORM
55905 YR = TST1
55906 460 YR = 0.01D0 * YR
55907 TST2 = NORM + YR
55908 IF (TST2 .GT. TST1) GOTO 460
55909 470 CONTINUE
55910 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55911C .......... OVERFLOW CONTROL ..........
55912 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55913 IF (TR .EQ. 0.0D0) GOTO 490
55914 TST1 = TR
55915 TST2 = TST1 + 1.0D0/TST1
55916 IF (TST2 .GT. TST1) GOTO 490
55917 DO 480 J = I, EN
55918 HR(J,EN) = HR(J,EN)/TR
55919 HI(J,EN) = HI(J,EN)/TR
55920 480 CONTINUE
55921C
55922 490 CONTINUE
55923C
55924 500 CONTINUE
55925C .......... END BACKSUBSTITUTION ..........
55926C .......... VECTORS OF ISOLATED ROOTS ..........
55927 DO 520 I = 1, N
55928 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55929C
55930 DO 510 J = I, N
55931 ZR(I,J) = HR(I,J)
55932 ZI(I,J) = HI(I,J)
55933 510 CONTINUE
55934C
55935 520 CONTINUE
55936C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55937C VECTORS OF ORIGINAL FULL MATRIX.
55938C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55939 DO 540 JJ = LOW, N
55940 J = N + LOW - JJ
55941 M = MIN0(J,IGH)
55942C
55943 DO 540 I = LOW, IGH
55944 ZZR = 0.0D0
55945 ZZI = 0.0D0
55946C
55947 DO 530 K = LOW, M
55948 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55949 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55950 530 CONTINUE
55951C
55952 ZR(I,J) = ZZR
55953 ZI(I,J) = ZZI
55954 540 CONTINUE
55955C
55956 GOTO 560
55957C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55958C CONVERGED AFTER 30*N ITERATIONS ..........
55959 550 IERR = EN
55960 560 RETURN
55961 END
55962
55963C*********************************************************************
55964
55965C...PYCDIV
55966C...Auxiliary to PYCMQR
55967C
55968C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55969C
55970
55971 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55972
55973 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55974 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55975
55976 S = DABS(BR) + DABS(BI)
55977 ARS = AR/S
55978 AIS = AI/S
55979 BRS = BR/S
55980 BIS = BI/S
55981 S = BRS**2 + BIS**2
55982 CR = (ARS*BRS + AIS*BIS)/S
55983 CI = (AIS*BRS - ARS*BIS)/S
55984 RETURN
55985 END
55986
55987C*********************************************************************
55988
55989C...PYCSRT
55990C...Auxiliary to PYCMQR
55991C
55992C (YR,YI) = COMPLEX DSQRT(XR,XI)
55993C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
55994C
55995
55996 SUBROUTINE PYCSRT(XR,XI,YR,YI)
55997
55998 DOUBLE PRECISION XR,XI,YR,YI
55999 DOUBLE PRECISION S,TR,TI,PYTHAG
56000
56001 TR = XR
56002 TI = XI
56003 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56004 IF (TR .GE. 0.0D0) YR = S
56005 IF (TI .LT. 0.0D0) S = -S
56006 IF (TR .LE. 0.0D0) YI = S
56007 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56008 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56009 RETURN
56010 END
56011
56012 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56013 DOUBLE PRECISION A,B
56014C
56015C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56016C
56017 DOUBLE PRECISION P,R,S,T,U
56018 P = DMAX1(DABS(A),DABS(B))
56019 IF (P .EQ. 0.0D0) GOTO 110
56020 R = (DMIN1(DABS(A),DABS(B))/P)**2
56021 100 CONTINUE
56022 T = 4.0D0 + R
56023 IF (T .EQ. 4.0D0) GOTO 110
56024 S = R/T
56025 U = 1.0D0 + 2.0D0*S
56026 P = U*P
56027 R = (S/U)**2 * R
56028 GOTO 100
56029 110 PYTHAG = P
56030 RETURN
56031 END
56032
56033C*********************************************************************
56034
56035C...PYCBAL
56036C...Auxiliary to PYEICG
56037C
56038C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56039C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56040C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56041C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56042C
56043C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56044C EIGENVALUES WHENEVER POSSIBLE.
56045C
56046C ON INPUT
56047C
56048C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56049C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56050C DIMENSION STATEMENT.
56051C
56052C N IS THE ORDER OF THE MATRIX.
56053C
56054C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56055C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56056C
56057C ON OUTPUT
56058C
56059C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56060C RESPECTIVELY, OF THE BALANCED MATRIX.
56061C
56062C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56063C ARE EQUAL TO ZERO IF
56064C (1) I IS GREATER THAN J AND
56065C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56066C
56067C SCALE CONTAINS INFORMATION DETERMINING THE
56068C PERMUTATIONS AND SCALING FACTORS USED.
56069C
56070C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56071C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56072C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56073C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56074C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56075C = D(J,J) J = LOW,...,IGH
56076C = P(J) J = IGH+1,...,N.
56077C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56078C THEN 1 TO LOW-1.
56079C
56080C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56081C
56082C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56083C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56084C K,L HAVE BEEN REVERSED.)
56085C
56086C ARITHMETIC IS REAL THROUGHOUT.
56087C
56088C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56089C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56090C
56091C THIS VERSION DATED AUGUST 1983.
56092C
56093
56094 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56095
56096 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56097 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56098 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56099 LOGICAL NOCONV
56100
56101 RADIX = 16.0D0
56102C
56103 B2 = RADIX * RADIX
56104 K = 1
56105 L = N
56106 GOTO 150
56107C .......... IN-LINE PROCEDURE FOR ROW AND
56108C COLUMN EXCHANGE ..........
56109 100 SCALE(M) = J
56110 IF (J .EQ. M) GOTO 130
56111C
56112 DO 110 I = 1, L
56113 F = AR(I,J)
56114 AR(I,J) = AR(I,M)
56115 AR(I,M) = F
56116 F = AI(I,J)
56117 AI(I,J) = AI(I,M)
56118 AI(I,M) = F
56119 110 CONTINUE
56120C
56121 DO 120 I = K, N
56122 F = AR(J,I)
56123 AR(J,I) = AR(M,I)
56124 AR(M,I) = F
56125 F = AI(J,I)
56126 AI(J,I) = AI(M,I)
56127 AI(M,I) = F
56128 120 CONTINUE
56129C
56130 130 IF(IEXC.EQ.1) GOTO 140
56131 IF(IEXC.EQ.2) GOTO 180
56132C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56133C AND PUSH THEM DOWN ..........
56134 140 IF (L .EQ. 1) GOTO 320
56135 L = L - 1
56136C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56137 150 DO 170 JJ = 1, L
56138 J = L + 1 - JJ
56139C
56140 DO 160 I = 1, L
56141 IF (I .EQ. J) GOTO 160
56142 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56143 160 CONTINUE
56144C
56145 M = L
56146 IEXC = 1
56147 GOTO 100
56148 170 CONTINUE
56149C
56150 GOTO 190
56151C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56152C AND PUSH THEM LEFT ..........
56153 180 K = K + 1
56154C
56155 190 DO 210 J = K, L
56156C
56157 DO 200 I = K, L
56158 IF (I .EQ. J) GOTO 200
56159 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56160 200 CONTINUE
56161C
56162 M = K
56163 IEXC = 2
56164 GOTO 100
56165 210 CONTINUE
56166C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56167 DO 220 I = K, L
56168 220 SCALE(I) = 1.0D0
56169C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56170 230 NOCONV = .FALSE.
56171C
56172 DO 310 I = K, L
56173 C = 0.0D0
56174 R = 0.0D0
56175C
56176 DO 240 J = K, L
56177 IF (J .EQ. I) GOTO 240
56178 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56179 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56180 240 CONTINUE
56181C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56182 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56183 G = R / RADIX
56184 F = 1.0D0
56185 S = C + R
56186 250 IF (C .GE. G) GOTO 260
56187 F = F * RADIX
56188 C = C * B2
56189 GOTO 250
56190 260 G = R * RADIX
56191 270 IF (C .LT. G) GOTO 280
56192 F = F / RADIX
56193 C = C / B2
56194 GOTO 270
56195C .......... NOW BALANCE ..........
56196 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56197 G = 1.0D0 / F
56198 SCALE(I) = SCALE(I) * F
56199 NOCONV = .TRUE.
56200C
56201 DO 290 J = K, N
56202 AR(I,J) = AR(I,J) * G
56203 AI(I,J) = AI(I,J) * G
56204 290 CONTINUE
56205C
56206 DO 300 J = 1, L
56207 AR(J,I) = AR(J,I) * F
56208 AI(J,I) = AI(J,I) * F
56209 300 CONTINUE
56210C
56211 310 CONTINUE
56212C
56213 IF (NOCONV) GOTO 230
56214C
56215 320 LOW = K
56216 IGH = L
56217 RETURN
56218 END
56219
56220C*********************************************************************
56221
56222C...PYCBA2
56223C...Auxiliary to PYEICG.
56224C
56225C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56226C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56227C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56228C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56229C
56230C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56231C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56232C BALANCED MATRIX DETERMINED BY CBAL.
56233C
56234C ON INPUT
56235C
56236C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56237C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56238C DIMENSION STATEMENT.
56239C
56240C N IS THE ORDER OF THE MATRIX.
56241C
56242C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56243C
56244C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56245C AND SCALING FACTORS USED BY CBAL.
56246C
56247C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56248C
56249C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56250C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56251C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56252C
56253C ON OUTPUT
56254C
56255C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56256C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56257C IN THEIR FIRST M COLUMNS.
56258C
56259C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56260C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56261C
56262C THIS VERSION DATED AUGUST 1983.
56263C
56264
56265 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56266
56267 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56268 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56269 DOUBLE PRECISION S
56270
56271 IF (M .EQ. 0) GOTO 150
56272 IF (IGH .EQ. LOW) GOTO 120
56273C
56274 DO 110 I = LOW, IGH
56275 S = SCALE(I)
56276C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56277C IF THE FOREGOING STATEMENT IS REPLACED BY
56278C S=1.0D0/SCALE(I). ..........
56279 DO 100 J = 1, M
56280 ZR(I,J) = ZR(I,J) * S
56281 ZI(I,J) = ZI(I,J) * S
56282 100 CONTINUE
56283C
56284 110 CONTINUE
56285C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56286C IGH+1 STEP 1 UNTIL N DO -- ..........
56287 120 DO 140 II = 1, N
56288 I = II
56289 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56290 IF (I .LT. LOW) I = LOW - II
56291 K = SCALE(I)
56292 IF (K .EQ. I) GOTO 140
56293C
56294 DO 130 J = 1, M
56295 S = ZR(I,J)
56296 ZR(I,J) = ZR(K,J)
56297 ZR(K,J) = S
56298 S = ZI(I,J)
56299 ZI(I,J) = ZI(K,J)
56300 ZI(K,J) = S
56301 130 CONTINUE
56302C
56303 140 CONTINUE
56304C
56305 150 RETURN
56306 END
56307
56308C*********************************************************************
56309
56310C...PYCRTH
56311C...Auxiliary to PYEICG.
56312C
56313C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56314C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56315C BY MARTIN AND WILKINSON.
56316C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56317C
56318C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56319C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56320C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56321C UNITARY SIMILARITY TRANSFORMATIONS.
56322C
56323C ON INPUT
56324C
56325C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56326C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56327C DIMENSION STATEMENT.
56328C
56329C N IS THE ORDER OF THE MATRIX.
56330C
56331C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56332C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56333C SET LOW=1, IGH=N.
56334C
56335C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56336C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56337C
56338C ON OUTPUT
56339C
56340C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56341C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56342C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56343C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56344C HESSENBERG MATRIX.
56345C
56346C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56347C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56348C
56349C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56350C
56351C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56352C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56353C
56354C THIS VERSION DATED AUGUST 1983.
56355C
56356
56357 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56358
56359 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56360 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56361 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56362
56363 LA = IGH - 1
56364 KP1 = LOW + 1
56365 IF (LA .LT. KP1) GOTO 210
56366C
56367 DO 200 M = KP1, LA
56368 H = 0.0D0
56369 ORTR(M) = 0.0D0
56370 ORTI(M) = 0.0D0
56371 SCALE = 0.0D0
56372C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56373 DO 100 I = M, IGH
56374 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56375C
56376 IF (SCALE .EQ. 0.0D0) GOTO 200
56377 MP = M + IGH
56378C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56379 DO 110 II = M, IGH
56380 I = MP - II
56381 ORTR(I) = AR(I,M-1) / SCALE
56382 ORTI(I) = AI(I,M-1) / SCALE
56383 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56384 110 CONTINUE
56385C
56386 G = DSQRT(H)
56387 F = PYTHAG(ORTR(M),ORTI(M))
56388 IF (F .EQ. 0.0D0) GOTO 120
56389 H = H + F * G
56390 G = G / F
56391 ORTR(M) = (1.0D0 + G) * ORTR(M)
56392 ORTI(M) = (1.0D0 + G) * ORTI(M)
56393 GOTO 130
56394C
56395 120 ORTR(M) = G
56396 AR(M,M-1) = SCALE
56397C .......... FORM (I-(U*UT)/H) * A ..........
56398 130 DO 160 J = M, N
56399 FR = 0.0D0
56400 FI = 0.0D0
56401C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56402 DO 140 II = M, IGH
56403 I = MP - II
56404 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56405 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56406 140 CONTINUE
56407C
56408 FR = FR / H
56409 FI = FI / H
56410C
56411 DO 150 I = M, IGH
56412 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56413 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56414 150 CONTINUE
56415C
56416 160 CONTINUE
56417C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56418 DO 190 I = 1, IGH
56419 FR = 0.0D0
56420 FI = 0.0D0
56421C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56422 DO 170 JJ = M, IGH
56423 J = MP - JJ
56424 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56425 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56426 170 CONTINUE
56427C
56428 FR = FR / H
56429 FI = FI / H
56430C
56431 DO 180 J = M, IGH
56432 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56433 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56434 180 CONTINUE
56435C
56436 190 CONTINUE
56437C
56438 ORTR(M) = SCALE * ORTR(M)
56439 ORTI(M) = SCALE * ORTI(M)
56440 AR(M,M-1) = -G * AR(M,M-1)
56441 AI(M,M-1) = -G * AI(M,M-1)
56442 200 CONTINUE
56443C
56444 210 RETURN
56445 END
56446
56447C*********************************************************************
56448
56449C...PYLDCM
56450C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56451C...processes.
56452
56453 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56454 IMPLICIT NONE
56455 INTEGER N,NP,INDX(N)
56456 REAL*8 D,TINY
56457 COMPLEX*16 A(NP,NP)
56458 PARAMETER (TINY=1.0D-20)
56459 INTEGER I,IMAX,J,K
56460 REAL*8 AAMAX,VV(6),DUM
56461 COMPLEX*16 SUM,DUMC
56462
56463 D=1D0
56464 DO 110 I=1,N
56465 AAMAX=0D0
56466 DO 100 J=1,N
56467 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56468 100 CONTINUE
56469 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56470 VV(I)=1D0/AAMAX
56471 110 CONTINUE
56472 DO 180 J=1,N
56473 DO 130 I=1,J-1
56474 SUM=A(I,J)
56475 DO 120 K=1,I-1
56476 SUM=SUM-A(I,K)*A(K,J)
56477 120 CONTINUE
56478 A(I,J)=SUM
56479 130 CONTINUE
56480 AAMAX=0D0
56481 DO 150 I=J,N
56482 SUM=A(I,J)
56483 DO 140 K=1,J-1
56484 SUM=SUM-A(I,K)*A(K,J)
56485 140 CONTINUE
56486 A(I,J)=SUM
56487 DUM=VV(I)*ABS(SUM)
56488 IF (DUM.GE.AAMAX) THEN
56489 IMAX=I
56490 AAMAX=DUM
56491 ENDIF
56492 150 CONTINUE
56493 IF (J.NE.IMAX)THEN
56494 DO 160 K=1,N
56495 DUMC=A(IMAX,K)
56496 A(IMAX,K)=A(J,K)
56497 A(J,K)=DUMC
56498 160 CONTINUE
56499 D=-D
56500 VV(IMAX)=VV(J)
56501 ENDIF
56502 INDX(J)=IMAX
56503 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56504 IF(J.NE.N)THEN
56505 DO 170 I=J+1,N
56506 A(I,J)=A(I,J)/A(J,J)
56507 170 CONTINUE
56508 ENDIF
56509 180 CONTINUE
56510
56511 RETURN
56512 END
56513
56514C*********************************************************************
56515
56516C...PYBKSB
56517C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56518C...processes.
56519
56520 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56521 IMPLICIT NONE
56522 INTEGER N,NP,INDX(N)
56523 COMPLEX*16 A(NP,NP),B(N)
56524 INTEGER I,II,J,LL
56525 COMPLEX*16 SUM
56526
56527 II=0
56528 DO 110 I=1,N
56529 LL=INDX(I)
56530 SUM=B(LL)
56531 B(LL)=B(I)
56532 IF (II.NE.0)THEN
56533 DO 100 J=II,I-1
56534 SUM=SUM-A(I,J)*B(J)
56535 100 CONTINUE
56536 ELSE IF (ABS(SUM).NE.0D0) THEN
56537 II=I
56538 ENDIF
56539 B(I)=SUM
56540 110 CONTINUE
56541 DO 130 I=N,1,-1
56542 SUM=B(I)
56543 DO 120 J=I+1,N
56544 SUM=SUM-A(I,J)*B(J)
56545 120 CONTINUE
56546 B(I)=SUM/A(I,I)
56547 130 CONTINUE
56548 RETURN
56549 END
56550
56551C***********************************************************************
56552
56553C...PYWIDX
56554C...Calculates full and partial widths of resonances.
56555C....copy of PYWIDT, used for techniparticle widths
56556
56557 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56558
56559C...Double precision and integer declarations.
56560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56561 IMPLICIT INTEGER(I-N)
56562 INTEGER PYK,PYCHGE,PYCOMP
56563C...Parameter statement to help give large particle numbers.
56564 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56565 &KEXCIT=4000000,KDIMEN=5000000)
56566C...Commonblocks.
56567 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56568 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56569 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56570 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56571 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56572 COMMON/PYINT1/MINT(400),VINT(400)
56573 COMMON/PYINT4/MWID(500),WIDS(500,5)
56574 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56575 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56576 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56577 &/PYINT4/,/PYMSSM/,/PYTCSM/
56578C...Local arrays and saved variables.
56579 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56580 &WID2SV(3,2)
56581 SAVE MOFSV,WIDWSV,WID2SV
56582 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56583
56584C...Compressed code and sign; mass.
56585 KFLA=IABS(KFLR)
56586 KFLS=ISIGN(1,KFLR)
56587 KC=PYCOMP(KFLA)
56588 SHR=SQRT(SH)
56589 PMR=PMAS(KC,1)
56590
56591C...Reset width information.
56592 DO I=0,400
56593 WDTP(I)=0D0
56594 ENDDO
56595
56596C...Common electroweak and strong constants.
56597 XW=PARU(102)
56598 XWV=XW
56599 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56600 XW1=1D0-XW
56601 AEM=PYALEM(SH)
56602 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56603 AS=PYALPS(SH)
56604 RADC=1D0+AS/PARU(1)
56605
56606 IF(KFLA.EQ.23) THEN
56607C...Z0:
56608 XWC=1D0/(16D0*XW*XW1)
56609 FAC=(AEM*XWC/3D0)*SHR
56610 120 CONTINUE
56611 DO 130 I=1,MDCY(KC,3)
56612 IDC=I+MDCY(KC,2)-1
56613 IF(MDME(IDC,1).LT.0) GOTO 130
56614 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56615 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56616 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56617 IF(I.LE.8) THEN
56618C...Z0 -> q + qbar
56619 EF=KCHG(I,1)/3D0
56620 AF=SIGN(1D0,EF+0.1D0)
56621 VF=AF-4D0*EF*XWV
56622 FCOF=3D0*RADC
56623 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56624 ELSEIF(I.LE.16) THEN
56625C...Z0 -> l+ + l-, nu + nubar
56626 EF=KCHG(I+2,1)/3D0
56627 AF=SIGN(1D0,EF+0.1D0)
56628 VF=AF-4D0*EF*XWV
56629 FCOF=1D0
56630 ENDIF
56631 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56632 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56633 & BE34
56634 WDTP(0)=WDTP(0)+WDTP(I)
56635 130 CONTINUE
56636
56637
56638 ELSEIF(KFLA.EQ.24) THEN
56639C...W+/-:
56640 FAC=(AEM/(24D0*XW))*SHR
56641 DO 140 I=1,MDCY(KC,3)
56642 IDC=I+MDCY(KC,2)-1
56643 IF(MDME(IDC,1).LT.0) GOTO 140
56644 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56645 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56646 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56647 WID2=1D0
56648 IF(I.LE.16) THEN
56649C...W+/- -> q + qbar'
56650 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56651 ELSEIF(I.LE.20) THEN
56652C...W+/- -> l+/- + nu
56653 FCOF=1D0
56654 ENDIF
56655 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56656 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56657 WDTP(0)=WDTP(0)+WDTP(I)
56658 140 CONTINUE
56659
56660C.....V8 -> quark anti-quark
56661 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56662 FAC=AS/6D0*SHR
56663 TANT3=RTCM(21)
56664 IF(ITCM(2).EQ.0) THEN
56665 IMDL=1
56666 ELSEIF(ITCM(2).EQ.1) THEN
56667 IMDL=2
56668 ENDIF
56669 DO 150 I=1,MDCY(KC,3)
56670 IDC=I+MDCY(KC,2)-1
56671 IF(MDME(IDC,1).LT.0) GOTO 150
56672 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56673 RM1=PM1**2/SH
56674 IF(RM1.GT.0.25D0) GOTO 150
56675 WID2=1D0
56676 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56677 FMIX=1D0/TANT3**2
56678 ELSE
56679 FMIX=TANT3**2
56680 ENDIF
56681 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56682 IF(I.EQ.6) WID2=WIDS(6,1)
56683 WDTP(0)=WDTP(0)+WDTP(I)
56684 150 CONTINUE
56685 ENDIF
56686
56687 RETURN
56688 END
56689
56690C*********************************************************************
56691
56692C...PYRVSF
56693C...Calculates R-violating decays of sfermions.
56694C...P. Z. Skands
56695
56696 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56697
56698C...Double precision and integer declarations.
56699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56700 IMPLICIT INTEGER(I-N)
56701C...Parameter statement to help give large particle numbers.
56702 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56703 &KEXCIT=4000000,KDIMEN=5000000)
56704C...Commonblocks.
56705 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56706 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56707 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56708 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56709 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56710C...Local variables.
56711 DOUBLE PRECISION XLAM(0:400)
56712 INTEGER IDLAM(400,3), PYCOMP
56713 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56714
56715C...IS R-VIOLATION ON ?
56716 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56717C...Mass eigenstate counter
56718 ICNT=INT(KFIN/KSUSY1)
56719C...SM KF code of SUSY particle
56720 KFSM=KFIN-ICNT*KSUSY1
56721C...Squared Sparticle Mass
56722 SM=PMAS(PYCOMP(KFIN),1)**2
56723C... Squared mass of top quark
56724 SMT=PMAS(PYCOMP(6),1)**2
56725C...IS L-VIOLATION ON ?
56726 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56727C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56728 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56729 & THEN
56730 K=INT((KFSM-9)/2)
56731 DO 110 I=1,3
56732 DO 100 J=1,3
56733 IF(I.NE.J) THEN
56734C...~e,~mu,~tau -> nu_I + lepton-_J
56735 LKNT = LKNT+1
56736 IDLAM(LKNT,1)= 12 +2*(I-1)
56737 IDLAM(LKNT,2)= 11 +2*(J-1)
56738 IDLAM(LKNT,3)= 0
56739 XLAM(LKNT)=0D0
56740 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56741 IF (IMSS(51).NE.0) XLAM(LKNT) =
56742 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56743C...KINEMATICS CHECK
56744 IF (XLAM(LKNT).EQ.0D0) THEN
56745 LKNT=LKNT-1
56746 ENDIF
56747 ENDIF
56748 100 CONTINUE
56749 110 CONTINUE
56750C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56751 J=INT((KFSM-9)/2)
56752 DO 130 I=1,3
56753 IF(I.NE.J) THEN
56754 DO 120 K=1,3
56755 LKNT = LKNT+1
56756 IDLAM(LKNT,1)=-12 -2*(I-1)
56757 IDLAM(LKNT,2)= 11 +2*(K-1)
56758 IDLAM(LKNT,3)= 0
56759 XLAM(LKNT)=0D0
56760 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56761 IF (IMSS(51).NE.0) XLAM(LKNT) =
56762 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56763C...KINEMATICS CHECK
56764 IF (XLAM(LKNT).EQ.0D0) THEN
56765 LKNT=LKNT-1
56766 ENDIF
56767 120 CONTINUE
56768 ENDIF
56769 130 CONTINUE
56770C...~e,~mu,~tau -> u_Jbar + d_K
56771 I=INT((KFSM-9)/2)
56772 DO 150 J=1,3
56773 DO 140 K=1,3
56774 LKNT = LKNT+1
56775 IDLAM(LKNT,1)=-2 -2*(J-1)
56776 IDLAM(LKNT,2)= 1 +2*(K-1)
56777 IDLAM(LKNT,3)= 0
56778 XLAM(LKNT)=0
56779 IF (IMSS(52).NE.0) THEN
56780C...Use massive top quark
56781 IF (IDLAM(LKNT,1).EQ.-6) THEN
56782 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56783 & * (SM-SMT)
56784 XLAM(LKNT) =
56785 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56786C...If no top quark, all decay products massless
56787 ELSE
56788 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56789 XLAM(LKNT) =
56790 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56791 ENDIF
56792C...KINEMATICS CHECK
56793 IF (XLAM(LKNT).EQ.0D0) THEN
56794 LKNT=LKNT-1
56795 ENDIF
56796 ENDIF
56797 140 CONTINUE
56798 150 CONTINUE
56799 ENDIF
56800C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56801C...No right-handed neutrinos
56802 IF(ICNT.EQ.1) THEN
56803 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56804 J=INT((KFSM-10)/2)
56805 DO 170 I=1,3
56806 DO 160 K=1,3
56807 IF (I.NE.J) THEN
56808C...~nu_J -> lepton+_I + lepton-_K
56809 LKNT = LKNT+1
56810 IDLAM(LKNT,1)=-11 -2*(I-1)
56811 IDLAM(LKNT,2)= 11 +2*(K-1)
56812 IDLAM(LKNT,3)= 0
56813 XLAM(LKNT)=0D0
56814 RM2=RVLAM(I,J,K)**2 * SM
56815 IF (IMSS(51).NE.0) XLAM(LKNT) =
56816 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56817C...KINEMATICS CHECK
56818 IF (XLAM(LKNT).EQ.0D0) THEN
56819 LKNT=LKNT-1
56820 ENDIF
56821 ENDIF
56822 160 CONTINUE
56823 170 CONTINUE
56824C...~nu_I -> dbar_J + d_K
56825 I=INT((KFSM-10)/2)
56826 DO 190 J=1,3
56827 DO 180 K=1,3
56828 LKNT = LKNT+1
56829 IDLAM(LKNT,1)=-1 -2*(J-1)
56830 IDLAM(LKNT,2)= 1 +2*(K-1)
56831 IDLAM(LKNT,3)= 0
56832 XLAM(LKNT)=0D0
56833 RM2=3*RVLAMP(I,J,K)**2 * SM
56834 IF (IMSS(52).NE.0) XLAM(LKNT) =
56835 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56836C...KINEMATICS CHECK
56837 IF (XLAM(LKNT).EQ.0D0) THEN
56838 LKNT=LKNT-1
56839 ENDIF
56840 180 CONTINUE
56841 190 CONTINUE
56842 ENDIF
56843 ENDIF
56844C * SDOWN -> NU(BAR) + D and LEPTON- + U
56845 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56846 J=INT((KFSM+1)/2)
56847 DO 210 I=1,3
56848 DO 200 K=1,3
56849C...~d_J -> nu_Ibar + d_K
56850 LKNT = LKNT+1
56851 IDLAM(LKNT,1)=-12 -2*(I-1)
56852 IDLAM(LKNT,2)= 1 +2*(K-1)
56853 IDLAM(LKNT,3)= 0
56854 XLAM(LKNT)=0D0
56855 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56856 IF (IMSS(52).NE.0) XLAM(LKNT) =
56857 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56858C...KINEMATICS CHECK
56859 IF (XLAM(LKNT).EQ.0D0) THEN
56860 LKNT=LKNT-1
56861 ENDIF
56862 200 CONTINUE
56863 210 CONTINUE
56864 K=INT((KFSM+1)/2)
56865 DO 240 I=1,3
56866 DO 230 J=1,3
56867C...~d_K -> nu_I + d_J
56868 LKNT = LKNT+1
56869 IDLAM(LKNT,1)= 12 +2*(I-1)
56870 IDLAM(LKNT,2)= 1 +2*(J-1)
56871 IDLAM(LKNT,3)= 0
56872 XLAM(LKNT)=0D0
56873 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56874 IF (IMSS(52).NE.0) XLAM(LKNT) =
56875 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56876C...KINEMATICS CHECK
56877 IF (XLAM(LKNT).EQ.0D0) THEN
56878 LKNT=LKNT-1
56879 ENDIF
56880C...~d_K -> lepton_I- + u_J
56881 220 LKNT = LKNT+1
56882 IDLAM(LKNT,1)= 11 +2*(I-1)
56883 IDLAM(LKNT,2)= 2 +2*(J-1)
56884 IDLAM(LKNT,3)= 0
56885 XLAM(LKNT)=0D0
56886 IF (IMSS(52).NE.0) THEN
56887C...Use massive top quark
56888 IF (IDLAM(LKNT,2).EQ.6) THEN
56889 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56890 XLAM(LKNT) =
56891 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56892C...If no top quark, all decay products massless
56893 ELSE
56894 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56895 XLAM(LKNT) =
56896 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56897 ENDIF
56898C...KINEMATICS CHECK
56899 IF (XLAM(LKNT).EQ.0D0) THEN
56900 LKNT=LKNT-1
56901 ENDIF
56902 ENDIF
56903 230 CONTINUE
56904 240 CONTINUE
56905 ENDIF
56906C * SUP -> LEPTON+ + D
56907 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56908 J=NINT(KFSM/2.)
56909 DO 260 I=1,3
56910 DO 250 K=1,3
56911C...~u_J -> lepton_I+ + d_K
56912 LKNT = LKNT+1
56913 IDLAM(LKNT,1)=-11 -2*(I-1)
56914 IDLAM(LKNT,2)= 1 +2*(K-1)
56915 IDLAM(LKNT,3)= 0
56916 XLAM(LKNT)=0D0
56917 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56918 IF (IMSS(52).NE.0) XLAM(LKNT) =
56919 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56920C...KINEMATICS CHECK
56921 IF (XLAM(LKNT).EQ.0D0) THEN
56922 LKNT=LKNT-1
56923 ENDIF
56924 250 CONTINUE
56925 260 CONTINUE
56926 ENDIF
56927 ENDIF
56928C...BARYON NUMBER VIOLATING DECAYS
56929 IF (IMSS(53).GE.1) THEN
56930C * SUP -> DBAR + DBAR
56931 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56932 I = KFSM/2
56933 DO 280 J=1,3
56934 DO 270 K=1,3
56935C...~u_I -> dbar_J + dbar_K
56936 IF (J.LT.K) THEN
56937C...(anti-) symmetry J <-> K.
56938 LKNT = LKNT + 1
56939 IDLAM(LKNT,1) = -1 -2*(J-1)
56940 IDLAM(LKNT,2) = -1 -2*(K-1)
56941 IDLAM(LKNT,3) = 0
56942 XLAM(LKNT) = 0D0
56943 RM2 = 2.*(RVLAMB(I,J,K)**2)
56944 & * SFMIX(KFSM,2*ICNT)**2 * SM
56945 XLAM(LKNT) =
56946 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56947C...KINEMATICS CHECK
56948 IF (XLAM(LKNT).EQ.0D0) THEN
56949 LKNT = LKNT-1
56950 ENDIF
56951 ENDIF
56952 270 CONTINUE
56953 280 CONTINUE
56954 ENDIF
56955C * SDOWN -> UBAR + DBAR
56956 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56957 K=(KFSM+1)/2
56958 DO 300 I=1,3
56959 DO 290 J=1,3
56960C...LAMB coupling antisymmetric in J and K.
56961 IF (J.NE.K) THEN
56962C...~d_K -> ubar_I + dbar_K
56963 LKNT = LKNT + 1
56964 IDLAM(LKNT,1)= -2 -2*(I-1)
56965 IDLAM(LKNT,2)= -1 -2*(J-1)
56966 IDLAM(LKNT,3)= 0
56967 XLAM(LKNT)=0D0
56968C...Use massive top quark
56969 IF (IDLAM(LKNT,1).EQ.-6) THEN
56970 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56971 & )
56972 XLAM(LKNT) =
56973 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56974C...If no top quark, all decay products massless
56975 ELSE
56976 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56977 XLAM(LKNT) =
56978 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56979 ENDIF
56980C...KINEMATICS CHECK
56981 IF (XLAM(LKNT).EQ.0D0) THEN
56982 LKNT=LKNT-1
56983 ENDIF
56984 ENDIF
56985 290 CONTINUE
56986 300 CONTINUE
56987 ENDIF
56988 ENDIF
56989 ENDIF
56990
56991 RETURN
56992 END
56993
56994C*********************************************************************
56995
56996C...PYRVNE
56997C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
56998C...P. Z. Skands
56999
57000 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57001
57002C...Double precision and integer declarations.
57003 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57004 IMPLICIT INTEGER(I-N)
57005C...Parameter statement to help give large particle numbers.
57006 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57007 &KEXCIT=4000000,KDIMEN=5000000)
57008C...Commonblocks.
57009 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57010 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57011 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57012 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57013 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57014 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57015C...Local variables.
57016 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57017 & ,DCMASS,KFR(3)
57018 DOUBLE PRECISION XLAM(0:400)
57019 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57020 INTEGER IDLAM(400,3), PYCOMP
57021 LOGICAL DCMASS
57022 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57023
57024C...R-VIOLATING DECAYS
57025 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57026 KFSM=KFIN-KSUSY1
57027 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57028C...WHICH NEUTRALINO ?
57029 NCHI=1
57030 IF (KFSM.EQ.23) NCHI=2
57031 IF (KFSM.EQ.25) NCHI=3
57032 IF (KFSM.EQ.35) NCHI=4
57033C...SIGN OF MASS (Opposite convention as HERWIG)
57034 ISM = 1
57035 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57036
57037C...Useful parameters for the calculation of the A and B constants.
57038 WMASS = PMAS(PYCOMP(24),1)
57039 ECHG = 2*SQRT(PARU(103)*PARU(1))
57040 COSB=1/(SQRT(1+RMSS(5)**2))
57041 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57042 COSW=SQRT(1-PARU(102))
57043 SINW=SQRT(PARU(102))
57044 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57045C...Run quark masses to neutralino mass squared (for Higgs-type
57046C...couplings)
57047 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57048 DO 100 I=1,6
57049 RMQ(I)=PYMRUN(I,SQMCHI)
57050 100 CONTINUE
57051C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57052 DO 110 NCHJ=1,4
57053 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57054 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57055 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57056 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57057 110 CONTINUE
57058 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57059 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57060 C2=ECHG*ZPMIX(NCHI,1)
57061 C3=GW*ZPMIX(NCHI,2)/COSW
57062 EU=2D0/3D0
57063 ED=-1D0/3D0
57064C... AB(x,y,z):
57065C x=1-2 : Select A or B constant (1:A ; 2:B)
57066C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57067C 11-16:e,nu_e,mu,...)
57068C z=1-2 : Mass eigenstate number
57069C...CALCULATE COUPLINGS
57070 DO 120 I = 11,15,2
57071 CMS=PMAS(PYCOMP(I),1)
57072C...Intermediate sleptons
57073 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57074 & *(C2-C3*SINW**2))
57075 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57076 & *(C2-C3*SINW**2))
57077 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57078 & **2))
57079 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57080 & **2))
57081C...Inermediate sneutrinos
57082 AB(1,I+1,1)=0D0
57083 AB(2,I+1,1)=5D-1*C3
57084 AB(1,I+1,2)=0D0
57085 AB(2,I+1,2)=0D0
57086C...Inermediate sdown
57087 J=I-10
57088 CMS=RMQ(J)
57089 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57090 & *ED*(C2-C3*SINW**2))
57091 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57092 & *ED*(C2-C3*SINW**2))
57093 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57094 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57095 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57096 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57097C...Inermediate sup
57098 J=J+1
57099 CMS=RMQ(J)
57100 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57101 & *EU*(C2-C3*SINW**2))
57102 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57103 & *EU*(C2-C3*SINW**2))
57104 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57105 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57106 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57107 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57108 120 CONTINUE
57109
57110 IF (IMSS(51).GE.1) THEN
57111C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57112C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57113C...STEP IN I,J,K USING SINGLE COUNTER
57114 DO 130 ISC=0,26
57115C...LAMBDA COUPLING ASYM IN I,J
57116 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57117 LKNT = LKNT+1
57118 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57119 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57120 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57121 XLAM(LKNT) = 0D0
57122C...Set coupling, and decay product masses on/off
57123 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57124 & ,MOD(ISC,3)+1)**2
57125 DCMASS=.FALSE.
57126 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57127 & DCMASS = .TRUE.
57128C...Resonance KF codes (1=I,2=J,3=K)
57129 KFR(1)=-IDLAM(LKNT,1)
57130 KFR(2)=-IDLAM(LKNT,2)
57131 KFR(3)=-IDLAM(LKNT,3)
57132C...Calculate width.
57133 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57134 & IDLAM(LKNT,3),XLAM(LKNT))
57135 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57136C...Charge conjugate mode.
57137 LKNT=LKNT+1
57138 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57139 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57140 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57141 XLAM(LKNT)=XLAM(LKNT-1)
57142C...KINEMATICS CHECK
57143 IF (XLAM(LKNT).EQ.0D0) THEN
57144 LKNT=LKNT-2
57145 ENDIF
57146 ENDIF
57147 130 CONTINUE
57148 ENDIF
57149
57150 IF (IMSS(52).GE.1) THEN
57151C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57152C * CHI0 -> NUBAR_I + DBAR_J + D_K
57153 DO 140 ISC=0,26
57154 LKNT = LKNT+1
57155 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57156 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57157 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57158 XLAM(LKNT) = 0D0
57159C...Set coupling, and decay product masses on/off
57160 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57161 & ,MOD(ISC,3)+1)**2
57162 DCMASS=.FALSE.
57163 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57164 & DCMASS = .TRUE.
57165C...Resonance KF codes (1=I,2=J,3=K)
57166 KFR(1)=-IDLAM(LKNT,1)
57167 KFR(2)=-IDLAM(LKNT,2)
57168 KFR(3)=-IDLAM(LKNT,3)
57169C...Calculate width.
57170 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57171 & ,XLAM(LKNT))
57172 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57173C...Charge conjugate mode.
57174 LKNT=LKNT+1
57175 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57176 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57177 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57178 XLAM(LKNT)=XLAM(LKNT-1)
57179C...KINEMATICS CHECK
57180 IF (XLAM(LKNT).EQ.0D0) THEN
57181 LKNT=LKNT-2
57182 ENDIF
57183
57184C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57185 LKNT = LKNT+1
57186 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57187 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57188 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57189 XLAM(LKNT) = 0D0
57190C...Set coupling, and decay product masses on/off
57191 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57192 & ,MOD(ISC,3)+1)**2
57193 DCMASS=.FALSE.
57194 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57195 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57196C...Resonance KF codes (1=I,2=J,3=K)
57197 KFR(1)=-IDLAM(LKNT,1)
57198 KFR(2)=-IDLAM(LKNT,2)
57199 KFR(3)=-IDLAM(LKNT,3)
57200C...Calculate width.
57201 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57202 & ,XLAM(LKNT))
57203 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57204C...Charge conjugate mode.
57205 LKNT=LKNT+1
57206 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57207 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57208 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57209 XLAM(LKNT)=XLAM(LKNT-1)
57210C...KINEMATICS CHECK
57211 IF (XLAM(LKNT).EQ.0D0) THEN
57212 LKNT=LKNT-2
57213 ENDIF
57214 140 CONTINUE
57215 ENDIF
57216
57217 IF (IMSS(53).GE.1) THEN
57218C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57219C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57220 DO 150 ISC=0,26
57221C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57222 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57223 LKNT = LKNT+1
57224 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57225 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57226 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57227 XLAM(LKNT) = 0D0
57228C...Set coupling, and decay product masses on/off
57229 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57230 & +1,MOD(ISC,3)+1)**2
57231 DCMASS=.FALSE.
57232 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57233 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57234C...Resonance KF codes (1=I,2=J,3=K)
57235 KFR(1) = IDLAM(LKNT,1)
57236 KFR(2) = IDLAM(LKNT,2)
57237 KFR(3) = IDLAM(LKNT,3)
57238C...Calculate width.
57239 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57240 & IDLAM(LKNT,3),XLAM(LKNT))
57241 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57242C...Charge conjugate mode.
57243 LKNT=LKNT+1
57244 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57245 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57246 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57247 XLAM(LKNT)=XLAM(LKNT-1)
57248C...KINEMATICS CHECK
57249 IF (XLAM(LKNT).EQ.0D0) THEN
57250 LKNT=LKNT-2
57251 ENDIF
57252 ENDIF
57253 150 CONTINUE
57254 ENDIF
57255 ENDIF
57256 ENDIF
57257
57258 RETURN
57259 END
57260
57261C*********************************************************************
57262
57263C...PYRVCH
57264C...Calculates R-violating chargino decay widths.
57265C...P. Z. Skands
57266
57267 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57268
57269C...Double precision and integer declarations.
57270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57271 IMPLICIT INTEGER(I-N)
57272C...Parameter statement to help give large particle numbers.
57273 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57274 &KEXCIT=4000000,KDIMEN=5000000)
57275C...Commonblocks.
57276 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57277 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57278 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57279 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57280 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57281 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57282C...Local variables.
57283 DOUBLE PRECISION XLAM(0:400)
57284 INTEGER IDLAM(400,3), PYCOMP
57285C...Information from main routine to PYRVGW
57286 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57287 & ,DCMASS,KFR(3)
57288C...Auxiliary variables needed for BV (RV Gauge STOre)
57289 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57290 & ,RVLJKI,RVLJIK
57291C...Running quark masses
57292 DOUBLE PRECISION RMQ(6)
57293C...Decay product masses on/off
57294 LOGICAL DCMASS
57295 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57296 & /RVGSTO/
57297
57298
57299C...IF R-VIOLATION ON.
57300 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57301 KFSM=KFIN-KSUSY1
57302 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57303C...WHICH CHARGINO ?
57304 NCHI = 1
57305 IF (KFSM.EQ.37) NCHI = 2
57306
57307C...Useful parameters for calculating the A and B constants.
57308C...SIGN OF MASS (Opposite convention as HERWIG)
57309 ISM = 1
57310 IF (SMW(NCHI).LT.0D0) ISM = -1
57311 WMASS = PMAS(PYCOMP(24),1)
57312 COSB = 1/(SQRT(1+RMSS(5)**2))
57313 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57314 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57315 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57316 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57317 C2 = UMIX(NCHI,1)
57318 C3 = VMIX(NCHI,1)
57319C...Running masses at Q^2=MCHI^2.
57320 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57321 DO 100 I=1,6
57322 RMQ(I)=PYMRUN(I,SQMCHI)
57323 100 CONTINUE
57324
57325C... AB(x,y,z) coefficients:
57326C x=1-2 : A or B coefficient (1:A ; 2:B)
57327C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57328C 11-16:e,nu_e,mu,...)
57329C z=1-2 : Mass eigenstate number
57330 DO 110 I = 11,15,2
57331C...Intermediate sleptons
57332 AB(1,I,1) = 0D0
57333 AB(1,I,2) = 0D0
57334 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57335 & SFMIX(I,1)*C2
57336 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57337 & SFMIX(I,3)*C2
57338C...Intermediate sneutrinos
57339 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57340 AB(1,I+1,2) = 0D0
57341 AB(2,I+1,1) = ISM*C3
57342 AB(2,I+1,2) = 0D0
57343C...Intermediate sdown
57344 J=I-10
57345 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57346 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57347 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57348 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57349C...Intermediate sup
57350 J=J+1
57351 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57352 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57353 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57354 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57355 110 CONTINUE
57356
57357C...LLE TYPE R-VIOLATION
57358 IF (IMSS(51).GE.1) THEN
57359C...LOOP OVER DECAY MODES
57360 DO 140 ISC=0,26
57361
57362C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57363 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57364 LKNT = LKNT+1
57365 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57366 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57367 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57368 XLAM(LKNT) = 0D0
57369C...Set coupling, and decay product masses on/off
57370 RVLAMC = GW2 * 5D-1 *
57371 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57372 & **2
57373 DCMASS=.FALSE.
57374 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57375C...Resonance KF codes (1=I,2=J,3=K).
57376 KFR(1) = 0
57377 KFR(2) = 0
57378 KFR(3) = -IDLAM(LKNT,3)+1
57379C...Calculate width.
57380 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57381 & IDLAM(LKNT,3),XLAM(LKNT))
57382 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57383C...KINEMATICS CHECK
57384 IF (XLAM(LKNT).EQ.0D0) THEN
57385 LKNT=LKNT-1
57386 ENDIF
57387
57388C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57389 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57390 LKNT = LKNT+1
57391 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57392 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57393 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57394 XLAM(LKNT) = 0D0
57395C...Set coupling, and decay product masses on/off
57396 RVLAMC = GW2 * 5D-1 *
57397 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57398C...I,J SYMMETRY => FACTOR 2
57399 RVLAMC=2*RVLAMC
57400 DCMASS=.FALSE.
57401 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57402C...Resonance KF codes (1=I,2=J,3=K)
57403 KFR(1)=IDLAM(LKNT,1)-1
57404 KFR(2)=IDLAM(LKNT,2)-1
57405 KFR(3)=0
57406C...Calculate width.
57407 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57408 & IDLAM(LKNT,3),XLAM(LKNT))
57409 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57410C...KINEMATICS CHECK
57411 IF (XLAM(LKNT).EQ.0D0) THEN
57412 LKNT=LKNT-1
57413 ENDIF
57414 130 ENDIF
57415
57416C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57417 LKNT = LKNT+1
57418 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57419 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57420 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57421 XLAM(LKNT) = 0D0
57422C...Set coupling, and decay product masses on/off
57423 RVLAMC = GW2 * 5D-1 *
57424 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57425C...I,J SYMMETRY => FACTOR 2
57426 RVLAMC=2*RVLAMC
57427 DCMASS=.FALSE.
57428 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57429 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57430C...Resonance KF codes (1=I,2=J,3=K)
57431 KFR(1) =-IDLAM(LKNT,1)+1
57432 KFR(2) =-IDLAM(LKNT,2)+1
57433 KFR(3) = 0
57434C...Calculate width.
57435 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57436 & IDLAM(LKNT,3),XLAM(LKNT))
57437 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57438C...KINEMATICS CHECK
57439 IF (XLAM(LKNT).EQ.0D0) THEN
57440 LKNT=LKNT-1
57441 ENDIF
57442 ENDIF
57443 140 CONTINUE
57444 ENDIF
57445
57446C...LQD TYPE R-VIOLATION
57447 IF (IMSS(52).GE.1) THEN
57448C...LOOP OVER DECAY MODES
57449 DO 180 ISC=0,26
57450
57451C...CHI+ -> NUBAR_I + DBAR_J + U_K
57452 LKNT = LKNT+1
57453 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57454 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57455 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57456 XLAM(LKNT) = 0D0
57457C...Set coupling, and decay product masses on/off
57458 RVLAMC = 3. * GW2 * 5D-1 *
57459 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57460 DCMASS=.FALSE.
57461 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57462 & DCMASS = .TRUE.
57463C...Resonance KF codes (1=I,2=J,3=K)
57464 KFR(1)=0
57465 KFR(2)=0
57466 KFR(3)=-IDLAM(LKNT,3)+1
57467C...Calculate width.
57468 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57469 & ,XLAM(LKNT))
57470 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57471C...KINEMATICS CHECK
57472 IF (XLAM(LKNT).EQ.0D0) THEN
57473 LKNT=LKNT-1
57474 ENDIF
57475
57476C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57477 150 LKNT = LKNT+1
57478 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57479 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57480 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57481 XLAM(LKNT) = 0D0
57482C...Set coupling, and decay product masses on/off
57483 RVLAMC = 3. * GW2 * 5D-1 *
57484 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57485 DCMASS=.FALSE.
57486 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57487 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57488C...Resonance KF codes (1=I,2=J,3=K)
57489 KFR(1)=0
57490 KFR(2)=0
57491 KFR(3)=-IDLAM(LKNT,3)+1
57492C...Calculate width.
57493 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57494 & ,XLAM(LKNT))
57495 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57496C...KINEMATICS CHECK
57497 IF (XLAM(LKNT).EQ.0D0) THEN
57498 LKNT=LKNT-1
57499 ENDIF
57500
57501C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57502 160 LKNT = LKNT+1
57503 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57504 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57505 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57506 XLAM(LKNT) = 0D0
57507C...Set coupling, and decay product masses on/off
57508 RVLAMC = 3. * GW2 * 5D-1 *
57509 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57510 DCMASS = .FALSE.
57511 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57512 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57513C...Resonance KF codes (1=I,2=J,3=K)
57514 KFR(1)=-IDLAM(LKNT,1)+1
57515 KFR(2)=-IDLAM(LKNT,2)+1
57516 KFR(3)=0
57517C...Calculate width.
57518 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57519 & ,XLAM(LKNT))
57520 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57521C...KINEMATICS CHECK
57522 IF (XLAM(LKNT).EQ.0D0) THEN
57523 LKNT=LKNT-1
57524 ENDIF
57525
57526C * CHI+ -> NU_I + U_J + DBAR_K.
57527 170 LKNT = LKNT+1
57528 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57529 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57530 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57531 XLAM(LKNT) = 0D0
57532C...Set coupling, and decay product masses on/off
57533 DCMASS = .FALSE.
57534 RVLAMC = 3. * GW2 * 5D-1 *
57535 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57536 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57537 & DCMASS = .TRUE.
57538C...Resonance KF codes (1=I,2=J,3=K)
57539 KFR(1)=IDLAM(LKNT,1)-1
57540 KFR(2)=IDLAM(LKNT,2)-1
57541 KFR(3)=0
57542C...Calculate width.
57543 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57544 & ,XLAM(LKNT))
57545 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57546C...KINEMATICS CHECK
57547 IF (XLAM(LKNT).EQ.0D0) THEN
57548 LKNT=LKNT-1
57549 ENDIF
57550
57551 180 CONTINUE
57552 ENDIF
57553
57554C...UDD TYPE R-VIOLATION
57555C...These decays need special treatment since more than one BV coupling
57556C...contributes (with interference). Consider e.g. (symbolically)
57557C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57558C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57559C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57560C...The problem is that a single call to PYRVGW would evaluate all
57561C...these terms and sum them, but without the different couplings. The
57562C...way out is to call PYRVGW three times, once for the first line, once
57563C...for the second line, and then once for all the lines (it is
57564C...impossible to get just the last line out) without multiplying by
57565C...couplings. The last line is then obtained as the result of the third
57566C...call minus the results of the two first calls. Each term is then
57567C...multiplied by its respective coupling before the whole thing is
57568C...summed up in XLAM.
57569C...Note that with three interfering resonances, this procedure becomes
57570C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57571
57572 IF (IMSS(53).GE.1) THEN
57573C...LOOP OVER DECAY MODES
57574 DO 190 ISC=1,25
57575
57576C...CHI+ -> U_I + U_J + D_K
57577C...Decay mode I<->J symmetric.
57578 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57579 LKNT = LKNT+1
57580 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57581 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57582 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57583 XLAM(LKNT) = 0D0
57584C...Set coupling, and decay product masses on/off
57585 RVLAMC= 6. * GW2 * 5D-1
57586 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57587 & +1)
57588 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57589 & +1)
57590 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57591 & * RVLAMC
57592 DCMASS=.FALSE.
57593 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57594 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57595C...Resonance KF codes (1=I,2=J,3=K)
57596 KFR(1) = -IDLAM(LKNT,1)+1
57597 KFR(2) = 0
57598 KFR(3) = 0
57599C...Calculate width.
57600 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57601 & IDLAM(LKNT,3),XRESI)
57602C...Resonance KF codes (1=I,2=J,3=K)
57603 KFR(1) = 0
57604 KFR(2) = -IDLAM(LKNT,2)+1
57605 KFR(3) = 0
57606C...Calculate width.
57607 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57608 & IDLAM(LKNT,3),XRESJ)
57609C...Resonance KF codes (1=I,2=J,3=K)
57610 KFR(1) = -IDLAM(LKNT,1)+1
57611 KFR(2) = -IDLAM(LKNT,2)+1
57612 KFR(3) = 0
57613C...Calculate width.
57614 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57615 & IDLAM(LKNT,3),XRESIJ)
57616 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57617 XRESIJ = XRESIJ-XRESI-XRESJ
57618 ELSE
57619 XRESIJ = 0D0
57620 ENDIF
57621C...CALCULATE TOTAL WIDTH
57622 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57623 & + RVLJIK*RVLIJK * XRESIJ
57624 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57625C...KINEMATICS CHECK
57626 IF (XLAM(LKNT).EQ.0D0) THEN
57627 LKNT=LKNT-1
57628 ENDIF
57629 ENDIF
57630C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57631C...Symmetry I<->J<->K.
57632 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57633 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57634 LKNT = LKNT+1
57635 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57636 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57637 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57638 XLAM(LKNT) = 0D0
57639C...Set coupling, and decay product masses on/off
57640 RVLAMC = 6. * GW2 * 5D-1
57641 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57642 & +1)
57643 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57644 & +1)
57645 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57646 & +1)
57647 DCMASS = .FALSE.
57648 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57649 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57650C...Collect symmetry factors
57651 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57652 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57653 & RVLAMC = 5D-1 * RVLAMC
57654C...Resonance KF codes (1=I,2=J,3=K)
57655 KFR(1) = IDLAM(LKNT,1)-1
57656 KFR(2) = 0
57657 KFR(3) = 0
57658C...Calculate width.
57659 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57660 & IDLAM(LKNT,3),XRESI)
57661C...Resonance KF codes (1=I,2=J,3=K)
57662 KFR(1) = 0
57663 KFR(2) = IDLAM(LKNT,2)-1
57664 KFR(3) = 0
57665C...Calculate width.
57666 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57667 & IDLAM(LKNT,3),XRESJ)
57668C...Resonance KF codes (1=I,2=J,3=K)
57669 KFR(1) = 0
57670 KFR(2) = 0
57671 KFR(3) = IDLAM(LKNT,3)-1
57672C...Calculate width.
57673 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57674 & IDLAM(LKNT,3),XRESK)
57675C...Resonance KF codes (1=I,2=J,3=K)
57676 KFR(1) = IDLAM(LKNT,1)-1
57677 KFR(2) = IDLAM(LKNT,2)-1
57678 KFR(3) = 0
57679C...Calculate width.
57680 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57681 & IDLAM(LKNT,3),XRESIJ)
57682 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57683 XRESIJ = XRESI+XRESJ-XRESIJ
57684 ELSE
57685 XRESIJ = 0D0
57686 ENDIF
57687C...Resonance KF codes (1=I,2=J,3=K)
57688 KFR(1) = 0
57689 KFR(2) = IDLAM(LKNT,2)-1
57690 KFR(3) = IDLAM(LKNT,3)-1
57691C...Calculate width.
57692 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57693 & IDLAM(LKNT,3),XRESJK)
57694 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57695 XRESJK = XRESJ+XRESK-XRESJK
57696 ELSE
57697 XRESJK = 0D0
57698 ENDIF
57699C...Resonance KF codes (1=I,2=J,3=K)
57700 KFR(1) = IDLAM(LKNT,1)-1
57701 KFR(2) = 0
57702 KFR(3) = IDLAM(LKNT,3)-1
57703C...Calculate width.
57704 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57705 & IDLAM(LKNT,3),XRESIK)
57706 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57707 XRESIK = XRESI+XRESK-XRESIK
57708 ELSE
57709 XRESIK = 0D0
57710 ENDIF
57711C...CALCULATE TOTAL WIDTH
57712 XLAM(LKNT) =
57713 & RVLIJK**2 * XRESI
57714 & + RVLJKI**2 * XRESJ
57715 & + RVLKIJ**2 * XRESK
57716 & + RVLIJK*RVLJKI * XRESIJ
57717 & + RVLIJK*RVLKIJ * XRESIK
57718 & + RVLJKI*RVLKIJ * XRESJK
57719 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57720C...KINEMATICS CHECK
57721 IF (XLAM(LKNT).EQ.0D0) THEN
57722 LKNT=LKNT-1
57723 ENDIF
57724 ENDIF
57725 190 CONTINUE
57726 ENDIF
57727 ENDIF
57728 ENDIF
57729
57730 RETURN
57731 END
57732
57733C*********************************************************************
57734
57735C...PYRVGL
57736C...Calculates R-violating gluino decay widths.
57737C...See BV part of PYRVCH for comments about the way the BV decay width
57738C...is calculated. Same comments apply here.
57739C...P. Z. Skands
57740
57741 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57742
57743C...Double precision and integer declarations.
57744 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57745 IMPLICIT INTEGER(I-N)
57746C...Parameter statement to help give large particle numbers.
57747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57748 &KEXCIT=4000000,KDIMEN=5000000)
57749C...Commonblocks.
57750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57751 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57752 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57753 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57754 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57755 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57756C...Local variables.
57757 DOUBLE PRECISION XLAM(0:400)
57758 INTEGER IDLAM(400,3), PYCOMP
57759C...Information from main routine to PYRVGW
57760 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57761 & ,DCMASS,KFR(3)
57762C...Auxiliary variables needed for BV (RV Gauge STOre)
57763 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57764 & ,RVLJKI,RVLJIK
57765C...Running quark masses
57766 DOUBLE PRECISION RMQ(6)
57767C...Decay product masses on/off
57768 LOGICAL DCMASS
57769 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57770 & /RVGSTO/
57771
57772C...IF LQD OR UDD TYPE R-VIOLATION ON.
57773 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57774 KFSM=KFIN-KSUSY1
57775
57776C... AB(x,y,z):
57777C x=1-2 : Select A or B coupling (1:A ; 2:B)
57778C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57779C 11-16:e,nu_e,mu,... not used here)
57780C z=1-2 : Mass eigenstate number
57781 DO 100 I = 1,6
57782C...A Couplings
57783 AB(1,I,1) = SFMIX(I,2)
57784 AB(1,I,2) = SFMIX(I,4)
57785C...B Couplings
57786 AB(2,I,1) = -SFMIX(I,1)
57787 AB(2,I,2) = -SFMIX(I,3)
57788 100 CONTINUE
57789 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57790C...LQD DECAYS.
57791 IF (IMSS(52).GE.1) THEN
57792C...STEP IN I,J,K USING SINGLE COUNTER
57793 DO 120 ISC=0,26
57794C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57795 LKNT = LKNT+1
57796 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57797 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57798 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57799 XLAM(LKNT)=0D0
57800C...Set coupling, and decay product masses on/off
57801 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57802 & * 5D-1 * GSTR2
57803 DCMASS = .FALSE.
57804 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57805C...Resonance KF codes (1=I,2=J,3=K)
57806 KFR(1) = 0
57807 KFR(2) = -IDLAM(LKNT,2)
57808 KFR(3) = -IDLAM(LKNT,3)
57809C...Calculate width.
57810 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57811 & ,XLAM(LKNT))
57812C...Normalize
57813 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57814C...Charge conjugate mode.
57815 110 LKNT = LKNT+1
57816 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57817 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57818 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57819 XLAM(LKNT) = XLAM(LKNT-1)
57820C...KINEMATICS CHECK
57821 IF (XLAM(LKNT).EQ.0D0) THEN
57822 LKNT=LKNT-2
57823 ENDIF
57824
57825C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57826 LKNT = LKNT+1
57827 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57828 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57829 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57830 XLAM(LKNT)=0D0
57831C...Set coupling, and decay product masses on/off
57832 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57833 & **2* 5D-1 * GSTR2
57834 DCMASS = .FALSE.
57835 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57836 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57837C...Resonance KF codes (1=I,2=J,3=K)
57838 KFR(1) = 0
57839 KFR(2) = -IDLAM(LKNT,2)
57840 KFR(3) = -IDLAM(LKNT,3)
57841C...Calculate width.
57842 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57843 & ,XLAM(LKNT))
57844 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57845C...Charge conjugate mode.
57846 LKNT=LKNT+1
57847 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57848 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57849 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57850 XLAM(LKNT) = XLAM(LKNT-1)
57851C...KINEMATICS CHECK
57852 IF (XLAM(LKNT).EQ.0D0) THEN
57853 LKNT=LKNT-2
57854 ENDIF
57855
57856 120 CONTINUE
57857 ENDIF
57858
57859C...UDD DECAYS.
57860 IF (IMSS(53).GE.1) THEN
57861C...STEP IN I,J,K USING SINGLE COUNTER
57862 DO 130 ISC=0,26
57863C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57864 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57865 LKNT = LKNT+1
57866 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57867 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57868 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57869 XLAM(LKNT)=0D0
57870C...Set coupling, and decay product masses on/off. A factor of 2 for
57871C...(N_C-1) has been used to cancel a factor 0.5.
57872 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57873 & **2 * GSTR2
57874 DCMASS = .FALSE.
57875 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57876 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57877C...Resonance KF codes (1=I,2=J,3=K)
57878 KFR(1) = IDLAM(LKNT,1)
57879 KFR(2) = 0
57880 KFR(3) = 0
57881C...Calculate width.
57882 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57883 & ,XRESI)
57884C...Resonance KF codes (1=I,2=J,3=K)
57885 KFR(1) = 0
57886 KFR(2) = IDLAM(LKNT,2)
57887 KFR(3) = 0
57888C...Calculate width.
57889 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57890 & ,XRESJ)
57891C...Resonance KF codes (1=I,2=J,3=K)
57892 KFR(1) = 0
57893 KFR(2) = 0
57894 KFR(3) = IDLAM(LKNT,3)
57895C...Calculate width.
57896 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57897 & ,XRESK)
57898C...Resonance KF codes (1=I,2=J,3=K)
57899 KFR(1) = IDLAM(LKNT,1)
57900 KFR(2) = IDLAM(LKNT,2)
57901 KFR(3) = 0
57902C...Calculate width.
57903 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57904 & ,XRESIJ)
57905C...Calculate interference function. (Factor -1/2 to make up for factor
57906C...-2 in PYRVGW.
57907 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57908 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57909 ELSE
57910 XRESIJ = 0D0
57911 ENDIF
57912C...Resonance KF codes (1=I,2=J,3=K)
57913 KFR(1) = 0
57914 KFR(2) = IDLAM(LKNT,2)
57915 KFR(3) = IDLAM(LKNT,3)
57916C...Calculate width.
57917 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57918 & ,XRESJK)
57919 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57920 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57921 ELSE
57922 XRESJK = 0D0
57923 ENDIF
57924C...Resonance KF codes (1=I,2=J,3=K)
57925 KFR(1) = IDLAM(LKNT,1)
57926 KFR(2) = 0
57927 KFR(3) = IDLAM(LKNT,3)
57928C...Calculate width.
57929 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57930 & ,XRESIK)
57931 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57932 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57933 ELSE
57934 XRESIK = 0D0
57935 ENDIF
57936C...Calculate total width (factor 1/2 from 1/(N_C-1))
57937 XLAM(LKNT) = XRESI + XRESJ + XRESK
57938 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57939C...Normalize
57940 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57941C...Charge conjugate mode.
57942 LKNT = LKNT+1
57943 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57944 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57945 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57946 XLAM(LKNT) = XLAM(LKNT-1)
57947C...KINEMATICS CHECK
57948 IF (XLAM(LKNT).EQ.0D0) THEN
57949 LKNT=LKNT-2
57950 ENDIF
57951 ENDIF
57952 130 CONTINUE
57953 ENDIF
57954 ENDIF
57955 RETURN
57956 END
57957
57958C*********************************************************************
57959
57960C...PYRVSB
57961C...Auxiliary function to PYRVSF for calculating R-Violating
57962C...sfermion widths. Though the decay products are most often treated
57963C...as massless in the calculation, the kinematical boundary of phase
57964C...space is tested using the true masses.
57965C...MODE = 1: All decay products massive
57966C...MODE = 2: Decay product 1 massless
57967C...MODE = 3: Decay product 2 massless
57968C...MODE = 4: All decay products massless
57969
57970 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57971
57972 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57973 IMPLICIT INTEGER (I-N)
57974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57975 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57976 SAVE /PYDAT1/,/PYDAT2/
57977 DOUBLE PRECISION SM(3)
57978 INTEGER PYCOMP, KC(3)
57979 KC(1)=PYCOMP(KFIN)
57980 KC(2)=PYCOMP(ID1)
57981 KC(3)=PYCOMP(ID2)
57982 SM(1)=PMAS(KC(1),1)**2
57983 SM(2)=PMAS(KC(2),1)**2
57984 SM(3)=PMAS(KC(3),1)**2
57985C...Kinematics check
57986 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57987 PYRVSB=0D0
57988 RETURN
57989 ENDIF
57990C...CM momenta squared
57991 IF (MODE.EQ.1) THEN
57992 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
57993 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
57994 ELSE IF (MODE.EQ.2) THEN
57995 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
57996 ELSE IF (MODE.EQ.3) THEN
57997 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
57998 ELSE
57999 P2CM=SM(1)/4.
58000 ENDIF
58001C...Calculate Width
58002 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58003 RETURN
58004 END
58005
58006C*********************************************************************
58007
58008C...PYRVGW
58009C...Generalized Matrix Element for R-Violating 3-body widths.
58010C...P. Z. Skands
58011 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58012
58013 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58014 IMPLICIT INTEGER (I-N)
58015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58016 &KEXCIT=4000000,KDIMEN=5000000)
58017 PARAMETER (EPS=1D-4)
58018 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58019 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58020 & ,DCMASS,KFR(3)
58021 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58022 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58023 DOUBLE PRECISION XLIM(3,3)
58024 INTEGER KC(0:3), PYCOMP
58025 LOGICAL DCMASS, DCHECK(6)
58026 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58027
58028 XLAM = 0D0
58029
58030 KC(0) = PYCOMP(KFIN)
58031 KC(1) = PYCOMP(ID1)
58032 KC(2) = PYCOMP(ID2)
58033 KC(3) = PYCOMP(ID3)
58034 RMS(0) = PMAS(KC(0),1)
58035 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58036 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58037 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58038C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58039 XLIM(1,1)=(RMS(1)+RMS(2))**2
58040 XLIM(1,2)=(RMS(0)-RMS(3))**2
58041 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58042 XLIM(2,1)=(RMS(2)+RMS(3))**2
58043 XLIM(2,2)=(RMS(0)-RMS(1))**2
58044 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58045 XLIM(3,1)=(RMS(1)+RMS(3))**2
58046 XLIM(3,2)=(RMS(0)-RMS(2))**2
58047 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58048C...Check Phase Space
58049 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58050 RETURN
58051 ENDIF
58052
58053C...INITIALIZE RESONANCE INFORMATION
58054 DO 110 JRES = 1,3
58055 DO 100 IMASS = 1,2
58056 IRES = 2*(JRES-1)+IMASS
58057 INTRES(IRES,1) = 0
58058 DCHECK(IRES) =.FALSE.
58059C...NO RIGHT-HANDED NEUTRINOS
58060 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58061 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58062 & .KFR(JRES).EQ.0) GOTO 100
58063 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58064 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58065 INTRES(IRES,1) = IABS(KFR(JRES))
58066 INTRES(IRES,2) = IMASS
58067 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58068 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58069 100 CONTINUE
58070 110 CONTINUE
58071
58072C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58073
58074C...RESONANCE CONTRIBUTIONS
58075C...(Only sum contributions where the resonance is off shell).
58076C...Store whether diagram on/off in DCHECK.
58077C...LOOP OVER MASS STATES
58078 DO 120 J=1,2
58079 IDR=J
58080 IF(INTRES(IDR,1).NE.0) THEN
58081
58082 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58083 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58084 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58085 DCHECK(IDR) =.TRUE.
58086 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58087 ENDIF
58088 ENDIF
58089
58090 IDR=J+2
58091 IF(INTRES(IDR,1).NE.0) THEN
58092 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58093 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58094 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58095 DCHECK(IDR) =.TRUE.
58096 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58097 ENDIF
58098 ENDIF
58099
58100 IDR=J+4
58101 IF(INTRES(IDR,1).NE.0) THEN
58102 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58103 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58104 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58105 DCHECK(IDR) =.TRUE.
58106 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58107 ENDIF
58108 ENDIF
58109 120 CONTINUE
58110C... L-R INTERFERENCES
58111C... (Only add contributions where both contributing diagrams
58112C... are non-resonant).
58113 IDR=1
58114 IF (DCHECK(1).AND.DCHECK(2)) THEN
58115C...Bug corrected 11/12 2001. Skands.
58116 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58117 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58118 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58119 ENDIF
58120
58121 IDR=3
58122 IF (DCHECK(3).AND.DCHECK(4)) THEN
58123 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58124 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58125 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58126 ENDIF
58127
58128 IDR=5
58129 IF (DCHECK(5).AND.DCHECK(6)) THEN
58130 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58131 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58132 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58133 ENDIF
58134C... TRUE INTERFERENCES
58135C... (Only add contributions where both contributing diagrams
58136C... are non-resonant).
58137 PREF=-2D0
58138 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58139 DO 140 IKR1 = 1,2
58140 DO 130 IKR2 = 1,2
58141 IDR = IKR1+2
58142 IDR2 = IKR2
58143 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58144 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58145 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58146 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58147 ENDIF
58148
58149 IDR = IKR1+4
58150 IDR2 = IKR2
58151 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58152 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58153 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58154 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58155 ENDIF
58156
58157 IDR = IKR1+4
58158 IDR2 = IKR2+2
58159 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58160 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58161 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58162 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58163 ENDIF
58164 130 CONTINUE
58165 140 CONTINUE
58166
58167 RETURN
58168 END
58169
58170C*********************************************************************
58171
58172C...PYRVI1
58173C...Function to integrate resonance contributions
58174
58175 FUNCTION PYRVI1(ID1,ID2,ID3)
58176
58177 IMPLICIT NONE
58178 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58179 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58180 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58181 LOGICAL MFLAG,DCMASS
58182 EXTERNAL PYRVG1,PYGAUS
58183 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58184 & ,DCMASS,KFR(3)
58185 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58186 SAVE/PYRVNV/,/PYRVPM/
58187C...Initialize mass and width information
58188 PYRVI1 = 0D0
58189 RM(0) = RMS(0)
58190 RM(1) = RMS(ID1)
58191 RM(2) = RMS(ID2)
58192 RM(3) = RMS(ID3)
58193 RESM(1)= RES(IDR,1)
58194 RESW(1)= RES(IDR,2)
58195C...A->B and B->A for antisparticles
58196 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58197 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58198C...Integration boundaries and mass flag
58199 LO = (RM(1)+RM(2))**2
58200 HI = (RM(0)-RM(3))**2
58201 MFLAG = DCMASS
58202 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58203 RETURN
58204 END
58205
58206C*********************************************************************
58207
58208C...PYRVI2
58209C...Function to integrate L-R interference contributions
58210
58211 FUNCTION PYRVI2(ID1,ID2,ID3)
58212
58213 IMPLICIT NONE
58214 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58215 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58216 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58217 LOGICAL MFLAG,DCMASS
58218 EXTERNAL PYRVG2,PYGAUS
58219 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58220 & ,DCMASS,KFR(3)
58221 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58222 SAVE/PYRVNV/,/PYRVPM/
58223C...Initialize mass and width information
58224 PYRVI2 = 0D0
58225 RM(0) = RMS(0)
58226 RM(1) = RMS(ID1)
58227 RM(2) = RMS(ID2)
58228 RM(3) = RMS(ID3)
58229 RESM(1)= RES(IDR,1)
58230 RESW(1)= RES(IDR,2)
58231 RESM(2)= RES(IDR+1,1)
58232 RESW(2)= RES(IDR+1,2)
58233C...A->B and B->A for antisparticles
58234 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58235 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58236 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58237 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58238C...Boundaries and mass flag
58239 LO = (RM(1)+RM(2))**2
58240 HI = (RM(0)-RM(3))**2
58241 MFLAG = DCMASS
58242 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58243 RETURN
58244 END
58245
58246C*********************************************************************
58247
58248C...PYRVI3
58249C...Function to integrate true interference contributions
58250
58251 FUNCTION PYRVI3(ID1,ID2,ID3)
58252
58253 IMPLICIT NONE
58254 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58255 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58256 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58257 LOGICAL MFLAG,DCMASS
58258 EXTERNAL PYRVG3,PYGAUS
58259 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58260 & ,DCMASS,KFR(3)
58261 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58262 SAVE/PYRVNV/,/PYRVPM/
58263C...Initialize mass and width information
58264 PYRVI3 = 0D0
58265 RM(0) = RMS(0)
58266 RM(1) = RMS(ID1)
58267 RM(2) = RMS(ID2)
58268 RM(3) = RMS(ID3)
58269 RESM(1)= RES(IDR,1)
58270 RESW(1)= RES(IDR,2)
58271 RESM(2)= RES(IDR2,1)
58272 RESW(2)= RES(IDR2,2)
58273C...A -> B and B -> A for antisparticles
58274 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58275 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58276 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58277 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58278C...Boundaries and mass flag
58279 LO = (RM(1)+RM(2))**2
58280 HI = (RM(0)-RM(3))**2
58281 MFLAG = DCMASS
58282 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58283 RETURN
58284 END
58285
58286C*********************************************************************
58287
58288C...PYRVG1
58289C...Integrand for resonance contributions
58290
58291 FUNCTION PYRVG1(X)
58292
58293 IMPLICIT NONE
58294 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58295 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58296 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58297 LOGICAL MFLAG
58298 SAVE/PYRVPM/
58299 RVR = PYRVR(X,RESM(1),RESW(1))
58300 C1 = 2D0*SQRT(MAX(0D0,X))
58301 IF (.NOT.MFLAG) THEN
58302 E2 = X/C1
58303 E3 = (RM(0)**2-X)/C1
58304 DELTAY = 4D0*E2*E3
58305 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58306 ELSE
58307 E2 = (X-RM(1)**2+RM(2)**2)/C1
58308 E3 = (RM(0)**2-X-RM(3)**2)/C1
58309 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58310 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58311 DELTAY = 4D0*SR1*SR2
58312 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58313 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58314 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58315 ENDIF
58316 RETURN
58317 END
58318
58319C*********************************************************************
58320
58321C...PYRVG2
58322C...Integrand for L-R interference contributions
58323
58324 FUNCTION PYRVG2(X)
58325
58326 IMPLICIT NONE
58327 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58328 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58329 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58330 LOGICAL MFLAG
58331 SAVE/PYRVPM/
58332 C1 = 2D0*SQRT(MAX(0D0,X))
58333 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58334 IF (.NOT.MFLAG) THEN
58335 E2 = X/C1
58336 E3 = (RM(0)**2-X)/C1
58337 DELTAY = 4D0*E2*E3
58338 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58339 ELSE
58340 E2 = (X-RM(1)**2+RM(2)**2)/C1
58341 E3 = (RM(0)**2-X-RM(3)**2)/C1
58342 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58343 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58344 DELTAY = 4D0*SR1*SR2
58345 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58346 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58347 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58348 ENDIF
58349 RETURN
58350 END
58351
58352C*********************************************************************
58353
58354C...PYRVG3
58355C...Function to do Y integration over true interference contributions
58356
58357 FUNCTION PYRVG3(X)
58358
58359 IMPLICIT NONE
58360 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58361C...Second Dalitz variable for PYRVG4
58362 COMMON/PYG2DX/X1
58363 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58364 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58365 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58366 LOGICAL MFLAG
58367 EXTERNAL PYGAU2,PYRVG4
58368 SAVE/PYRVPM/,/PYG2DX/
58369 PYRVG3=0D0
58370 C1=2D0*SQRT(MAX(1D-9,X))
58371 X1=X
58372 IF (.NOT.MFLAG) THEN
58373 E2 = X/C1
58374 E3 = (RM(0)**2-X)/C1
58375 YMIN = 0D0
58376 YMAX = 4D0*E2*E3
58377 ELSE
58378 E2 = (X-RM(1)**2+RM(2)**2)/C1
58379 E3 = (RM(0)**2-X-RM(3)**2)/C1
58380 SQ1 = (E2+E3)**2
58381 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58382 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58383 YMIN = SQ1-(SR1+SR2)**2
58384 YMAX = SQ1-(SR1-SR2)**2
58385 ENDIF
58386 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58387 RETURN
58388 END
58389
58390C*********************************************************************
58391
58392C...PYRVG4
58393C...Integrand for true intereference contributions
58394
58395 FUNCTION PYRVG4(Y)
58396
58397 IMPLICIT NONE
58398 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58399 COMMON/PYG2DX/X
58400 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58401 LOGICAL MFLAG
58402 SAVE /PYRVPM/,/PYG2DX/
58403 PYRVG4=0D0
58404 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58405 IF (.NOT.MFLAG) THEN
58406 PYRVG4 = RVS*B(1)*B(2)*X*Y
58407 ELSE
58408 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58409 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58410 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58411 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58412 ENDIF
58413 RETURN
58414 END
58415
58416C*********************************************************************
58417
58418C...PYRVR
58419C...Breit-Wigner for resonance contributions
58420
58421 FUNCTION PYRVR(Mab2,RM,RW)
58422
58423 IMPLICIT NONE
58424 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58425 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58426 RETURN
58427 END
58428
58429C*********************************************************************
58430
58431C...PYRVS
58432C...Interference function
58433
58434 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58435
58436 IMPLICIT NONE
58437 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58438 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58439 & +W1*W2*M1*M2)
58440 RETURN
58441 END
58442
58443C*********************************************************************
58444
58445C...PY1ENT
58446C...Stores one parton/particle in commonblock PYJETS.
58447
58448 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58449
58450C...Double precision and integer declarations.
58451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58452 IMPLICIT INTEGER(I-N)
58453 INTEGER PYK,PYCHGE,PYCOMP
58454C...Commonblocks.
58455 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58456 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58457 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58458 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58459
58460C...Standard checks.
58461 MSTU(28)=0
58462 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58463 IPA=MAX(1,IABS(IP))
58464 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58465 &'(PY1ENT:) writing outside PYJETS memory')
58466 KC=PYCOMP(KF)
58467 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58468
58469C...Find mass. Reset K, P and V vectors.
58470 PM=0D0
58471 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58472 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58473 DO 100 J=1,5
58474 K(IPA,J)=0
58475 P(IPA,J)=0D0
58476 V(IPA,J)=0D0
58477 100 CONTINUE
58478
58479C...Store parton/particle in K and P vectors.
58480 K(IPA,1)=1
58481 IF(IP.LT.0) K(IPA,1)=2
58482 K(IPA,2)=KF
58483 P(IPA,5)=PM
58484 P(IPA,4)=MAX(PE,PM)
58485 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58486 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58487 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58488 P(IPA,3)=PA*COS(THE)
58489
58490C...Set N. Optionally fragment/decay.
58491 N=IPA
58492 IF(IP.EQ.0) CALL PYEXEC
58493
58494 RETURN
58495 END
58496
58497C*********************************************************************
58498
58499C...PY2ENT
58500C...Stores two partons/particles in their CM frame,
58501C...with the first along the +z axis.
58502
58503 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58504
58505C...Double precision and integer declarations.
58506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58507 IMPLICIT INTEGER(I-N)
58508 INTEGER PYK,PYCHGE,PYCOMP
58509C...Commonblocks.
58510 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58511 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58512 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58513 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58514
58515C...Standard checks.
58516 MSTU(28)=0
58517 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58518 IPA=MAX(1,IABS(IP))
58519 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58520 &'(PY2ENT:) writing outside PYJETS memory')
58521 KC1=PYCOMP(KF1)
58522 KC2=PYCOMP(KF2)
58523 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58524 &'(PY2ENT:) unknown flavour code')
58525
58526C...Find masses. Reset K, P and V vectors.
58527 PM1=0D0
58528 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58529 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58530 PM2=0D0
58531 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58532 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58533 DO 110 I=IPA,IPA+1
58534 DO 100 J=1,5
58535 K(I,J)=0
58536 P(I,J)=0D0
58537 V(I,J)=0D0
58538 100 CONTINUE
58539 110 CONTINUE
58540
58541C...Check flavours.
58542 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58543 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58544 IF(MSTU(19).EQ.1) THEN
58545 MSTU(19)=0
58546 ELSE
58547 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58548 & '(PY2ENT:) unphysical flavour combination')
58549 ENDIF
58550 K(IPA,2)=KF1
58551 K(IPA+1,2)=KF2
58552
58553C...Store partons/particles in K vectors for normal case.
58554 IF(IP.GE.0) THEN
58555 K(IPA,1)=1
58556 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58557 K(IPA+1,1)=1
58558
58559C...Store partons in K vectors for parton shower evolution.
58560 ELSE
58561 K(IPA,1)=3
58562 K(IPA+1,1)=3
58563 K(IPA,4)=MSTU(5)*(IPA+1)
58564 K(IPA,5)=K(IPA,4)
58565 K(IPA+1,4)=MSTU(5)*IPA
58566 K(IPA+1,5)=K(IPA+1,4)
58567 ENDIF
58568
58569C...Check kinematics and store partons/particles in P vectors.
58570 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58571 &'(PY2ENT:) energy smaller than sum of masses')
58572 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58573 &(2D0*PECM)
58574 P(IPA,3)=PA
58575 P(IPA,4)=SQRT(PM1**2+PA**2)
58576 P(IPA,5)=PM1
58577 P(IPA+1,3)=-PA
58578 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58579 P(IPA+1,5)=PM2
58580
58581C...Set N. Optionally fragment/decay.
58582 N=IPA+1
58583 IF(IP.EQ.0) CALL PYEXEC
58584
58585 RETURN
58586 END
58587
58588C*********************************************************************
58589
58590C...PY3ENT
58591C...Stores three partons or particles in their CM frame,
58592C...with the first along the +z axis and the third in the (x,z)
58593C...plane with x > 0.
58594
58595 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58596
58597C...Double precision and integer declarations.
58598 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58599 IMPLICIT INTEGER(I-N)
58600 INTEGER PYK,PYCHGE,PYCOMP
58601C...Commonblocks.
58602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58605 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58606
58607C...Standard checks.
58608 MSTU(28)=0
58609 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58610 IPA=MAX(1,IABS(IP))
58611 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58612 &'(PY3ENT:) writing outside PYJETS memory')
58613 KC1=PYCOMP(KF1)
58614 KC2=PYCOMP(KF2)
58615 KC3=PYCOMP(KF3)
58616 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58617 &'(PY3ENT:) unknown flavour code')
58618
58619C...Find masses. Reset K, P and V vectors.
58620 PM1=0D0
58621 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58622 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58623 PM2=0D0
58624 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58625 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58626 PM3=0D0
58627 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58628 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58629 DO 110 I=IPA,IPA+2
58630 DO 100 J=1,5
58631 K(I,J)=0
58632 P(I,J)=0D0
58633 V(I,J)=0D0
58634 100 CONTINUE
58635 110 CONTINUE
58636
58637C...Check flavours.
58638 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58639 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58640 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58641 IF(MSTU(19).EQ.1) THEN
58642 MSTU(19)=0
58643 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58644 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58645 & KQ1+KQ3.EQ.4)) THEN
58646 ELSE
58647 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58648 ENDIF
58649 K(IPA,2)=KF1
58650 K(IPA+1,2)=KF2
58651 K(IPA+2,2)=KF3
58652
58653C...Store partons/particles in K vectors for normal case.
58654 IF(IP.GE.0) THEN
58655 K(IPA,1)=1
58656 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58657 K(IPA+1,1)=1
58658 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58659 K(IPA+2,1)=1
58660
58661C...Store partons in K vectors for parton shower evolution.
58662 ELSE
58663 K(IPA,1)=3
58664 K(IPA+1,1)=3
58665 K(IPA+2,1)=3
58666 KCS=4
58667 IF(KQ1.EQ.-1) KCS=5
58668 K(IPA,KCS)=MSTU(5)*(IPA+1)
58669 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58670 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58671 K(IPA+1,9-KCS)=MSTU(5)*IPA
58672 K(IPA+2,KCS)=MSTU(5)*IPA
58673 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58674 ENDIF
58675
58676C...Check kinematics.
58677 MKERR=0
58678 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58679 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58680 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58681 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58682 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58683 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58684 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58685 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58686 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58687 IF(MKERR.NE.0) CALL PYERRM(13,
58688 &'(PY3ENT:) unphysical kinematical variable setup')
58689
58690C...Store partons/particles in P vectors.
58691 P(IPA,3)=PA1
58692 P(IPA,4)=SQRT(PA1**2+PM1**2)
58693 P(IPA,5)=PM1
58694 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58695 P(IPA+2,3)=PA3*CTHE3
58696 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58697 P(IPA+2,5)=PM3
58698 P(IPA+1,1)=-P(IPA+2,1)
58699 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58700 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58701 P(IPA+1,5)=PM2
58702
58703C...Set N. Optionally fragment/decay.
58704 N=IPA+2
58705 IF(IP.EQ.0) CALL PYEXEC
58706
58707 RETURN
58708 END
58709
58710C*********************************************************************
58711
58712C...PY4ENT
58713C...Stores four partons or particles in their CM frame, with
58714C...the first along the +z axis, the last in the xz plane with x > 0
58715C...and the second having y < 0 and y > 0 with equal probability.
58716
58717 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58718
58719C...Double precision and integer declarations.
58720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58721 IMPLICIT INTEGER(I-N)
58722 INTEGER PYK,PYCHGE,PYCOMP
58723C...Commonblocks.
58724 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58725 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58726 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58727 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58728
58729C...Standard checks.
58730 MSTU(28)=0
58731 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58732 IPA=MAX(1,IABS(IP))
58733 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58734 &'(PY4ENT:) writing outside PYJETS momory')
58735 KC1=PYCOMP(KF1)
58736 KC2=PYCOMP(KF2)
58737 KC3=PYCOMP(KF3)
58738 KC4=PYCOMP(KF4)
58739 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58740 &'(PY4ENT:) unknown flavour code')
58741
58742C...Find masses. Reset K, P and V vectors.
58743 PM1=0D0
58744 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58745 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58746 PM2=0D0
58747 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58748 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58749 PM3=0D0
58750 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58751 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58752 PM4=0D0
58753 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58754 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58755 DO 110 I=IPA,IPA+3
58756 DO 100 J=1,5
58757 K(I,J)=0
58758 P(I,J)=0D0
58759 V(I,J)=0D0
58760 100 CONTINUE
58761 110 CONTINUE
58762
58763C...Check flavours.
58764 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58765 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58766 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58767 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58768 IF(MSTU(19).EQ.1) THEN
58769 MSTU(19)=0
58770 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58771 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58772 & KQ1+KQ4.EQ.4)) THEN
58773 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58774 & THEN
58775 ELSE
58776 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58777 ENDIF
58778 K(IPA,2)=KF1
58779 K(IPA+1,2)=KF2
58780 K(IPA+2,2)=KF3
58781 K(IPA+3,2)=KF4
58782
58783C...Store partons/particles in K vectors for normal case.
58784 IF(IP.GE.0) THEN
58785 K(IPA,1)=1
58786 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58787 K(IPA+1,1)=1
58788 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58789 & K(IPA+1,1)=2
58790 K(IPA+2,1)=1
58791 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58792 K(IPA+3,1)=1
58793
58794C...Store partons for parton shower evolution from q-g-g-qbar or
58795C...g-g-g-g event.
58796 ELSEIF(KQ1+KQ2.NE.0) THEN
58797 K(IPA,1)=3
58798 K(IPA+1,1)=3
58799 K(IPA+2,1)=3
58800 K(IPA+3,1)=3
58801 KCS=4
58802 IF(KQ1.EQ.-1) KCS=5
58803 K(IPA,KCS)=MSTU(5)*(IPA+1)
58804 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58805 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58806 K(IPA+1,9-KCS)=MSTU(5)*IPA
58807 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58808 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58809 K(IPA+3,KCS)=MSTU(5)*IPA
58810 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58811
58812C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58813 ELSE
58814 K(IPA,1)=3
58815 K(IPA+1,1)=3
58816 K(IPA+2,1)=3
58817 K(IPA+3,1)=3
58818 K(IPA,4)=MSTU(5)*(IPA+1)
58819 K(IPA,5)=K(IPA,4)
58820 K(IPA+1,4)=MSTU(5)*IPA
58821 K(IPA+1,5)=K(IPA+1,4)
58822 K(IPA+2,4)=MSTU(5)*(IPA+3)
58823 K(IPA+2,5)=K(IPA+2,4)
58824 K(IPA+3,4)=MSTU(5)*(IPA+2)
58825 K(IPA+3,5)=K(IPA+3,4)
58826 ENDIF
58827
58828C...Check kinematics.
58829 MKERR=0
58830 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58831 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58832 &MKERR=1
58833 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58834 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58835 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58836 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58837 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58838 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58839 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58840 STHE4=SQRT(1D0-CTHE4**2)
58841 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58842 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58843 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58844 STHE2=SQRT(1D0-CTHE2**2)
58845 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58846 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58847 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58848 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58849 IF(MKERR.EQ.1) CALL PYERRM(13,
58850 &'(PY4ENT:) unphysical kinematical variable setup')
58851
58852C...Store partons/particles in P vectors.
58853 P(IPA,3)=PA1
58854 P(IPA,4)=SQRT(PA1**2+PM1**2)
58855 P(IPA,5)=PM1
58856 P(IPA+3,1)=PA4*STHE4
58857 P(IPA+3,3)=PA4*CTHE4
58858 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58859 P(IPA+3,5)=PM4
58860 P(IPA+1,1)=PA2*STHE2*CPHI2
58861 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58862 P(IPA+1,3)=PA2*CTHE2
58863 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58864 P(IPA+1,5)=PM2
58865 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58866 P(IPA+2,2)=-P(IPA+1,2)
58867 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58868 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58869 P(IPA+2,5)=PM3
58870
58871C...Set N. Optionally fragment/decay.
58872 N=IPA+3
58873 IF(IP.EQ.0) CALL PYEXEC
58874
58875 RETURN
58876 END
58877
58878C*********************************************************************
58879
58880C...PY2FRM
58881C...An interface from a two-fermion generator to include
58882C...parton showers and hadronization.
58883
58884 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58885
58886C...Double precision and integer declarations.
58887 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58888 IMPLICIT INTEGER(I-N)
58889 INTEGER PYK,PYCHGE,PYCOMP
58890C...Commonblocks.
58891 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58892 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58893 SAVE /PYJETS/,/PYDAT1/
58894C...Local arrays.
58895 DIMENSION IJOIN(2),INTAU(2)
58896
58897C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58898 IF(ICOM.EQ.0) THEN
58899 MSTU(28)=0
58900 CALL PYHEPC(2)
58901 ENDIF
58902
58903C...Loop through entries and pick up all final fermions/antifermions.
58904 I1=0
58905 I2=0
58906 DO 100 I=1,N
58907 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58908 KFA=IABS(K(I,2))
58909 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58910 IF(K(I,2).GT.0) THEN
58911 IF(I1.EQ.0) THEN
58912 I1=I
58913 ELSE
58914 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58915 ENDIF
58916 ELSE
58917 IF(I2.EQ.0) THEN
58918 I2=I
58919 ELSE
58920 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58921 ENDIF
58922 ENDIF
58923 ENDIF
58924 100 CONTINUE
58925
58926C...Check that event is arranged according to conventions.
58927 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58928 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58929 ENDIF
58930 IF(I2.LT.I1) THEN
58931 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58932 ENDIF
58933
58934C...Check whether fermion pair is quarks or leptons.
58935 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58936 IQL12=1
58937 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58938 IQL12=2
58939 ELSE
58940 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58941 ENDIF
58942
58943C...Decide whether to allow or not photon radiation in showers.
58944 MSTJ(41)=2
58945 IF(IRAD.EQ.0) MSTJ(41)=1
58946
58947C...Do colour joining and parton showers.
58948 IP1=I1
58949 IP2=I2
58950 IF(IQL12.EQ.1) THEN
58951 IJOIN(1)=IP1
58952 IJOIN(2)=IP2
58953 CALL PYJOIN(2,IJOIN)
58954 ENDIF
58955 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58956 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58957 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58958 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58959 ENDIF
58960
58961C...Do fragmentation and decays. Possibly except tau decay.
58962 IF(ITAU.EQ.0) THEN
58963 NTAU=0
58964 DO 110 I=1,N
58965 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58966 NTAU=NTAU+1
58967 INTAU(NTAU)=I
58968 K(I,1)=11
58969 ENDIF
58970 110 CONTINUE
58971 ENDIF
58972 CALL PYEXEC
58973 IF(ITAU.EQ.0) THEN
58974 DO 120 I=1,NTAU
58975 K(INTAU(I),1)=1
58976 120 CONTINUE
58977 ENDIF
58978
58979C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58980 IF(ICOM.EQ.0) THEN
58981 MSTU(28)=0
58982 CALL PYHEPC(1)
58983 ENDIF
58984
58985 END
58986
58987C*********************************************************************
58988
58989C...PY4FRM
58990C...An interface from a four-fermion generator to include
58991C...parton showers and hadronization.
58992
58993 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
58994
58995C...Double precision and integer declarations.
58996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58997 IMPLICIT INTEGER(I-N)
58998 INTEGER PYK,PYCHGE,PYCOMP
58999C...Commonblocks.
59000 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59001 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59003 COMMON/PYINT1/MINT(400),VINT(400)
59004 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59005C...Local arrays.
59006 DIMENSION IJOIN(2),INTAU(4)
59007
59008C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59009 IF(ICOM.EQ.0) THEN
59010 MSTU(28)=0
59011 CALL PYHEPC(2)
59012 ENDIF
59013
59014C...Loop through entries and pick up all final fermions/antifermions.
59015 I1=0
59016 I2=0
59017 I3=0
59018 I4=0
59019 DO 100 I=1,N
59020 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59021 KFA=IABS(K(I,2))
59022 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59023 IF(K(I,2).GT.0) THEN
59024 IF(I1.EQ.0) THEN
59025 I1=I
59026 ELSEIF(I3.EQ.0) THEN
59027 I3=I
59028 ELSE
59029 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59030 ENDIF
59031 ELSE
59032 IF(I2.EQ.0) THEN
59033 I2=I
59034 ELSEIF(I4.EQ.0) THEN
59035 I4=I
59036 ELSE
59037 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59038 ENDIF
59039 ENDIF
59040 ENDIF
59041 100 CONTINUE
59042
59043C...Check that event is arranged according to conventions.
59044 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59045 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59046 ENDIF
59047 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59048 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59049 ENDIF
59050
59051C...Check which fermion pairs are quarks and which leptons.
59052 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59053 IQL12=1
59054 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59055 IQL12=2
59056 ELSE
59057 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59058 ENDIF
59059 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59060 IQL34=1
59061 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59062 IQL34=2
59063 ELSE
59064 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59065 ENDIF
59066
59067C...Decide whether to allow or not photon radiation in showers.
59068 MSTJ(41)=2
59069 IF(IRAD.EQ.0) MSTJ(41)=1
59070
59071C...Decide on dipole pairing.
59072 IP1=I1
59073 IP2=I2
59074 IP3=I3
59075 IP4=I4
59076 IF(IQL12.EQ.IQL34) THEN
59077 R1SQ=A1SQ
59078 R2SQ=A2SQ
59079 DELTA=ATOTSQ-A1SQ-A2SQ
59080 IF(ISTRAT.EQ.1) THEN
59081 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59082 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59083 ELSEIF(ISTRAT.EQ.2) THEN
59084 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59085 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59086 ENDIF
59087 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59088 IP2=I4
59089 IP4=I2
59090 ENDIF
59091 ENDIF
59092
59093C...If colour reconnection then bookkeep W+W- or Z0Z0
59094C...and copy q qbar q qbar consecutively.
59095 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59096 K(N+1,1)=11
59097 K(N+1,3)=IP1
59098 K(N+1,4)=N+3
59099 K(N+1,5)=N+4
59100 K(N+2,1)=11
59101 K(N+2,3)=IP3
59102 K(N+2,4)=N+5
59103 K(N+2,5)=N+6
59104 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59105 K(N+1,2)=23
59106 K(N+2,2)=23
59107 MINT(1)=22
59108 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59109 K(N+1,2)=24
59110 K(N+2,2)=-24
59111 MINT(1)=25
59112 ELSE
59113 K(N+1,2)=-24
59114 K(N+2,2)=24
59115 MINT(1)=25
59116 ENDIF
59117 DO 110 J=1,5
59118 K(N+3,J)=K(IP1,J)
59119 K(N+4,J)=K(IP2,J)
59120 K(N+5,J)=K(IP3,J)
59121 K(N+6,J)=K(IP4,J)
59122 P(N+1,J)=P(IP1,J)+P(IP2,J)
59123 P(N+2,J)=P(IP3,J)+P(IP4,J)
59124 P(N+3,J)=P(IP1,J)
59125 P(N+4,J)=P(IP2,J)
59126 P(N+5,J)=P(IP3,J)
59127 P(N+6,J)=P(IP4,J)
59128 V(N+1,J)=V(IP1,J)
59129 V(N+2,J)=V(IP3,J)
59130 V(N+3,J)=V(IP1,J)
59131 V(N+4,J)=V(IP2,J)
59132 V(N+5,J)=V(IP3,J)
59133 V(N+6,J)=V(IP4,J)
59134 110 CONTINUE
59135 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59136 & P(N+1,3)**2))
59137 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59138 & P(N+2,3)**2))
59139 K(N+3,3)=N+1
59140 K(N+4,3)=N+1
59141 K(N+5,3)=N+2
59142 K(N+6,3)=N+2
59143C...Remove original q qbar q qbar and update counters.
59144 K(IP1,1)=K(IP1,1)+10
59145 K(IP2,1)=K(IP2,1)+10
59146 K(IP3,1)=K(IP3,1)+10
59147 K(IP4,1)=K(IP4,1)+10
59148 IW1=N+1
59149 IW2=N+2
59150 NSD1=N+2
59151 IP1=N+3
59152 IP2=N+4
59153 IP3=N+5
59154 IP4=N+6
59155 N=N+6
59156 ENDIF
59157
59158C...Do colour joinings and parton showers.
59159 IF(IQL12.EQ.1) THEN
59160 IJOIN(1)=IP1
59161 IJOIN(2)=IP2
59162 CALL PYJOIN(2,IJOIN)
59163 ENDIF
59164 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59165 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59166 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59167 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59168 ENDIF
59169 NAFT1=N
59170 IF(IQL34.EQ.1) THEN
59171 IJOIN(1)=IP3
59172 IJOIN(2)=IP4
59173 CALL PYJOIN(2,IJOIN)
59174 ENDIF
59175 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59176 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59177 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59178 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59179 ENDIF
59180
59181C...Optionally do colour reconnection.
59182 MINT(32)=0
59183 MSTI(32)=0
59184 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59185 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59186 MSTI(32)=MINT(32)
59187 ENDIF
59188
59189C...Do fragmentation and decays. Possibly except tau decay.
59190 IF(ITAU.EQ.0) THEN
59191 NTAU=0
59192 DO 120 I=1,N
59193 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59194 NTAU=NTAU+1
59195 INTAU(NTAU)=I
59196 K(I,1)=11
59197 ENDIF
59198 120 CONTINUE
59199 ENDIF
59200 CALL PYEXEC
59201 IF(ITAU.EQ.0) THEN
59202 DO 130 I=1,NTAU
59203 K(INTAU(I),1)=1
59204 130 CONTINUE
59205 ENDIF
59206
59207C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59208 IF(ICOM.EQ.0) THEN
59209 MSTU(28)=0
59210 CALL PYHEPC(1)
59211 ENDIF
59212
59213 END
59214
59215C*********************************************************************
59216
59217C...PY6FRM
59218C...An interface from a six-fermion generator to include
59219C...parton showers and hadronization.
59220
59221 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59222
59223C...Double precision and integer declarations.
59224 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59225 IMPLICIT INTEGER(I-N)
59226 INTEGER PYK,PYCHGE,PYCOMP
59227C...Commonblocks.
59228 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59229 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59230 SAVE /PYJETS/,/PYDAT1/
59231C...Local arrays.
59232 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59233
59234C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59235 IF(ICOM.EQ.0) THEN
59236 MSTU(28)=0
59237 CALL PYHEPC(2)
59238 ENDIF
59239
59240C...Loop through entries and pick up all final fermions/antifermions.
59241 I1=0
59242 I2=0
59243 I3=0
59244 I4=0
59245 I5=0
59246 I6=0
59247 DO 100 I=1,N
59248 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59249 KFA=IABS(K(I,2))
59250 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59251 IF(K(I,2).GT.0) THEN
59252 IF(I1.EQ.0) THEN
59253 I1=I
59254 ELSEIF(I3.EQ.0) THEN
59255 I3=I
59256 ELSEIF(I5.EQ.0) THEN
59257 I5=I
59258 ELSE
59259 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59260 ENDIF
59261 ELSE
59262 IF(I2.EQ.0) THEN
59263 I2=I
59264 ELSEIF(I4.EQ.0) THEN
59265 I4=I
59266 ELSEIF(I6.EQ.0) THEN
59267 I6=I
59268 ELSE
59269 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59270 ENDIF
59271 ENDIF
59272 ENDIF
59273 100 CONTINUE
59274
59275C...Check that event is arranged according to conventions.
59276 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59277 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59278 ENDIF
59279 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59280 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59281 ENDIF
59282
59283C...Check which fermion pairs are quarks and which leptons.
59284 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59285 IQL12=1
59286 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59287 IQL12=2
59288 ELSE
59289 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59290 ENDIF
59291 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59292 IQL34=1
59293 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59294 IQL34=2
59295 ELSE
59296 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59297 ENDIF
59298 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59299 IQL56=1
59300 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59301 IQL56=2
59302 ELSE
59303 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59304 ENDIF
59305
59306C...Decide whether to allow or not photon radiation in showers.
59307 MSTJ(41)=2
59308 IF(IRAD.EQ.0) MSTJ(41)=1
59309
59310C...Allow dipole pairings only among leptons and quarks separately.
59311 P12D=P12
59312 P13D=0D0
59313 IF(IQL34.EQ.IQL56) P13D=P13
59314 P21D=0D0
59315 IF(IQL12.EQ.IQL34) P21D=P21
59316 P23D=0D0
59317 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59318 P31D=0D0
59319 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59320 P32D=0D0
59321 IF(IQL12.EQ.IQL56) P32D=P32
59322
59323C...Decide whether t+tbar.
59324 ITOP=0
59325 IF(PYR(0).LT.PTOP) THEN
59326 ITOP=1
59327
59328C...If t+tbar: reconstruct t's.
59329 IT=N+1
59330 ITB=N+2
59331 DO 110 J=1,5
59332 K(IT,J)=0
59333 K(ITB,J)=0
59334 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59335 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59336 V(IT,J)=0D0
59337 V(ITB,J)=0D0
59338 110 CONTINUE
59339 K(IT,1)=1
59340 K(ITB,1)=1
59341 K(IT,2)=6
59342 K(ITB,2)=-6
59343 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59344 & P(IT,3)**2))
59345 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59346 & P(ITB,3)**2))
59347 N=N+2
59348
59349C...If t+tbar: colour join t's and let them shower.
59350 IJOIN(1)=IT
59351 IJOIN(2)=ITB
59352 CALL PYJOIN(2,IJOIN)
59353 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59354 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59355 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59356
59357C...If t+tbar: pick up the t's after shower.
59358 ITNEW=IT
59359 ITBNEW=ITB
59360 DO 120 I=ITB+1,N
59361 IF(K(I,2).EQ.6) ITNEW=I
59362 IF(K(I,2).EQ.-6) ITBNEW=I
59363 120 CONTINUE
59364
59365C...If t+tbar: loop over two top systems.
59366 DO 200 IT1=1,2
59367 IF(IT1.EQ.1) THEN
59368 ITO=IT
59369 ITN=ITNEW
59370 IBO=I1
59371 IW1=I3
59372 IW2=I4
59373 ELSE
59374 ITO=ITB
59375 ITN=ITBNEW
59376 IBO=I2
59377 IW1=I5
59378 IW2=I6
59379 ENDIF
59380 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59381 & '(PY6FRM:) not b in t decay')
59382
59383C...If t+tbar: find boost from original to new top frame.
59384 DO 130 J=1,3
59385 BETAO(J)=P(ITO,J)/P(ITO,4)
59386 BETAN(J)=P(ITN,J)/P(ITN,4)
59387 130 CONTINUE
59388
59389C...If t+tbar: boost copy of b by t shower and connect it in colour.
59390 N=N+1
59391 IB=N
59392 K(IB,1)=3
59393 K(IB,2)=K(IBO,2)
59394 K(IB,3)=ITN
59395 DO 140 J=1,5
59396 P(IB,J)=P(IBO,J)
59397 V(IB,J)=0D0
59398 140 CONTINUE
59399 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59400 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59401 K(IB,4)=MSTU(5)*ITN
59402 K(IB,5)=MSTU(5)*ITN
59403 K(ITN,4)=K(ITN,4)+IB
59404 K(ITN,5)=K(ITN,5)+IB
59405 K(ITN,1)=K(ITN,1)+10
59406 K(IBO,1)=K(IBO,1)+10
59407
59408C...If t+tbar: construct W recoiling against b.
59409 N=N+1
59410 IW=N
59411 DO 150 J=1,5
59412 K(IW,J)=0
59413 V(IW,J)=0D0
59414 150 CONTINUE
59415 K(IW,1)=1
59416 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59417 IF(IABS(KCHW).EQ.3) THEN
59418 K(IW,2)=ISIGN(24,KCHW)
59419 ELSE
59420 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59421 ENDIF
59422 K(IW,3)=IW1
59423
59424C...If t+tbar: construct W momentum, including boost by t shower.
59425 DO 160 J=1,4
59426 P(IW,J)=P(IW1,J)+P(IW2,J)
59427 160 CONTINUE
59428 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59429 & P(IW,3)**2))
59430 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59431 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59432
59433C...If t+tbar: boost b and W to top rest frame.
59434 DO 170 J=1,3
59435 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59436 170 CONTINUE
59437 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59438 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59439
59440C...If t+tbar: let b shower and pick up modified W.
59441 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59442 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59443 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59444 DO 180 I=IW,N
59445 IF(IABS(K(I,2)).EQ.24) IWM=I
59446 180 CONTINUE
59447
59448C...If t+tbar: take copy of W decay products.
59449 DO 190 J=1,5
59450 K(N+1,J)=K(IW1,J)
59451 P(N+1,J)=P(IW1,J)
59452 V(N+1,J)=V(IW1,J)
59453 K(N+2,J)=K(IW2,J)
59454 P(N+2,J)=P(IW2,J)
59455 V(N+2,J)=V(IW2,J)
59456 190 CONTINUE
59457 K(IW1,1)=K(IW1,1)+10
59458 K(IW2,1)=K(IW2,1)+10
59459 K(IWM,1)=K(IWM,1)+10
59460 K(IWM,4)=N+1
59461 K(IWM,5)=N+2
59462 K(N+1,3)=IWM
59463 K(N+2,3)=IWM
59464 IF(IT1.EQ.1) THEN
59465 I3=N+1
59466 I4=N+2
59467 ELSE
59468 I5=N+1
59469 I6=N+2
59470 ENDIF
59471 N=N+2
59472
59473C...If t+tbar: boost W decay products, first by effects of t shower,
59474C...then by those of b shower. b and its shower simple boost back.
59475 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59476 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59477 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59478 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59479 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59480 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59481 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59482 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59483 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59484 200 CONTINUE
59485 ENDIF
59486
59487C...Decide on dipole pairing.
59488 IP1=I1
59489 IP3=I3
59490 IP5=I5
59491 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59492 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59493 IP2=I2
59494 IP4=I4
59495 IP6=I6
59496 ELSEIF(PRN.LT.P12D+P13D) THEN
59497 IP2=I2
59498 IP4=I6
59499 IP6=I4
59500 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59501 IP2=I4
59502 IP4=I2
59503 IP6=I6
59504 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59505 IP2=I4
59506 IP4=I6
59507 IP6=I2
59508 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59509 IP2=I6
59510 IP4=I2
59511 IP6=I4
59512 ELSE
59513 IP2=I6
59514 IP4=I4
59515 IP6=I2
59516 ENDIF
59517
59518C...Do colour joinings and parton showers
59519C...(except ones already made for t+tbar).
59520 IF(ITOP.EQ.0) THEN
59521 IF(IQL12.EQ.1) THEN
59522 IJOIN(1)=IP1
59523 IJOIN(2)=IP2
59524 CALL PYJOIN(2,IJOIN)
59525 ENDIF
59526 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59527 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59528 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59529 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59530 ENDIF
59531 ENDIF
59532 IF(IQL34.EQ.1) THEN
59533 IJOIN(1)=IP3
59534 IJOIN(2)=IP4
59535 CALL PYJOIN(2,IJOIN)
59536 ENDIF
59537 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59538 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59539 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59540 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59541 ENDIF
59542 IF(IQL56.EQ.1) THEN
59543 IJOIN(1)=IP5
59544 IJOIN(2)=IP6
59545 CALL PYJOIN(2,IJOIN)
59546 ENDIF
59547 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59548 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59549 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59550 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59551 ENDIF
59552
59553C...Do fragmentation and decays. Possibly except tau decay.
59554 IF(ITAU.EQ.0) THEN
59555 NTAU=0
59556 DO 210 I=1,N
59557 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59558 NTAU=NTAU+1
59559 INTAU(NTAU)=I
59560 K(I,1)=11
59561 ENDIF
59562 210 CONTINUE
59563 ENDIF
59564 CALL PYEXEC
59565 IF(ITAU.EQ.0) THEN
59566 DO 220 I=1,NTAU
59567 K(INTAU(I),1)=1
59568 220 CONTINUE
59569 ENDIF
59570
59571C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59572 IF(ICOM.EQ.0) THEN
59573 MSTU(28)=0
59574 CALL PYHEPC(1)
59575 ENDIF
59576
59577 END
59578
59579C*********************************************************************
59580
59581C...PY4JET
59582C...An interface from a four-parton generator to include
59583C...parton showers and hadronization.
59584
59585 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59586
59587C...Double precision and integer declarations.
59588 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59589 IMPLICIT INTEGER(I-N)
59590 INTEGER PYK,PYCHGE,PYCOMP
59591C...Commonblocks.
59592 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59593 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59594 SAVE /PYJETS/,/PYDAT1/
59595C...Local arrays.
59596 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59597
59598C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59599 IF(ICOM.EQ.0) THEN
59600 MSTU(28)=0
59601 CALL PYHEPC(2)
59602 ENDIF
59603
59604C...Loop through entries and pick up all final partons.
59605 I1=0
59606 I2=0
59607 I3=0
59608 I4=0
59609 DO 100 I=1,N
59610 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59611 KFA=IABS(K(I,2))
59612 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59613 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59614 IF(I1.EQ.0) THEN
59615 I1=I
59616 ELSEIF(I3.EQ.0) THEN
59617 I3=I
59618 ELSE
59619 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59620 ENDIF
59621 ELSEIF(K(I,2).LT.0) THEN
59622 IF(I2.EQ.0) THEN
59623 I2=I
59624 ELSEIF(I4.EQ.0) THEN
59625 I4=I
59626 ELSE
59627 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59628 ENDIF
59629 ELSE
59630 IF(I3.EQ.0) THEN
59631 I3=I
59632 ELSEIF(I4.EQ.0) THEN
59633 I4=I
59634 ELSE
59635 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59636 ENDIF
59637 ENDIF
59638 ENDIF
59639 100 CONTINUE
59640
59641C...Check that event is arranged according to conventions.
59642 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59643 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59644 ENDIF
59645 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59646 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59647 ENDIF
59648
59649C...Check whether second pair are quarks or gluons.
59650 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59651 IQG34=1
59652 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59653 IQG34=2
59654 ELSE
59655 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59656 ENDIF
59657
59658C...Boost partons to their cm frame.
59659 DO 110 J=1,4
59660 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59661 110 CONTINUE
59662 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59663 DO 120 J=1,3
59664 BETA(J)=PTOT(J)/PTOT(4)
59665 120 CONTINUE
59666 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59667 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59668 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59669 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59670 NSAV=N
59671
59672C...Decide and set up shower history for q qbar q' qbar' events.
59673 IF(IQG34.EQ.1) THEN
59674 W1=PY4JTW(0,I1,I3,I4)
59675 W2=PY4JTW(0,I2,I3,I4)
59676 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59677 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59678 ELSE
59679 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59680 ENDIF
59681
59682C...Decide and set up shower history for q qbar g g events.
59683 ELSE
59684 W1=PY4JTW(I1,I3,I2,I4)
59685 W2=PY4JTW(I1,I4,I2,I3)
59686 W3=PY4JTW(0,I3,I1,I4)
59687 W4=PY4JTW(0,I4,I1,I3)
59688 W5=PY4JTW(0,I3,I2,I4)
59689 W6=PY4JTW(0,I4,I2,I3)
59690 W7=PY4JTW(0,I1,I3,I4)
59691 W8=PY4JTW(0,I2,I3,I4)
59692 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59693 IF(W1.GT.WR) THEN
59694 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59695 ELSEIF(W1+W2.GT.WR) THEN
59696 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59697 ELSEIF(W1+W2+W3.GT.WR) THEN
59698 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59699 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59700 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59701 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59702 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59703 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59704 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59705 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59706 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59707 ELSE
59708 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59709 ENDIF
59710 ENDIF
59711
59712C...Boost back original partons and mark them as deleted.
59713 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59714 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59715 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59716 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59717 K(I1,1)=K(I1,1)+10
59718 K(I2,1)=K(I2,1)+10
59719 K(I3,1)=K(I3,1)+10
59720 K(I4,1)=K(I4,1)+10
59721
59722C...Rotate shower initiating partons to be along z axis.
59723 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59724 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59725 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59726 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59727
59728C...Set up copy of shower initiating partons as on mass shell.
59729 DO 140 I=N+1,N+2
59730 DO 130 J=1,5
59731 K(I,J)=0
59732 P(I,J)=0D0
59733 V(I,J)=V(I1,J)
59734 130 CONTINUE
59735 K(I,1)=1
59736 K(I,2)=K(I-6,2)
59737 140 CONTINUE
59738 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59739 K(N+1,3)=I1
59740 P(N+1,5)=P(I1,5)
59741 K(N+2,3)=I2
59742 P(N+2,5)=P(I2,5)
59743 ELSE
59744 K(N+1,3)=I2
59745 P(N+1,5)=P(I2,5)
59746 K(N+2,3)=I1
59747 P(N+2,5)=P(I1,5)
59748 ENDIF
59749 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59750 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59751 P(N+1,3)=PABS
59752 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59753 P(N+2,3)=-PABS
59754 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59755 N=N+2
59756
59757C...Decide whether to allow or not photon radiation in showers.
59758C...Connect up colours.
59759 MSTJ(41)=2
59760 IF(IRAD.EQ.0) MSTJ(41)=1
59761 IJOIN(1)=N-1
59762 IJOIN(2)=N
59763 CALL PYJOIN(2,IJOIN)
59764
59765C...Decide on maximum virtuality and do parton shower.
59766 IF(PMAX.LT.PARJ(82)) THEN
59767 PQMAX=QMAX
59768 ELSE
59769 PQMAX=PMAX
59770 ENDIF
59771 CALL PYSHOW(NSAV+1,-100,PQMAX)
59772
59773C...Rotate and boost back system.
59774 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59775
59776C...Do fragmentation and decays.
59777 CALL PYEXEC
59778
59779C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59780 IF(ICOM.EQ.0) THEN
59781 MSTU(28)=0
59782 CALL PYHEPC(1)
59783 ENDIF
59784
59785 RETURN
59786 END
59787
59788C*********************************************************************
59789
59790C...PY4JTW
59791C...Auxiliary to PY4JET, to evaluate weight of configuration.
59792
59793 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59794
59795C...Double precision and integer declarations.
59796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59797 IMPLICIT INTEGER(I-N)
59798 INTEGER PYK,PYCHGE,PYCOMP
59799C...Commonblocks.
59800 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59801 SAVE /PYJETS/
59802
59803C...First case: when both original partons radiate.
59804C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59805 IF(IA1.NE.0) THEN
59806 DO 100 J=1,4
59807 P(N+1,J)=P(IA1,J)+P(IA2,J)
59808 P(N+2,J)=P(IA3,J)+P(IA4,J)
59809 100 CONTINUE
59810 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59811 & P(N+1,3)**2))
59812 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59813 & P(N+2,3)**2))
59814 Z1=P(IA1,4)/P(N+1,4)
59815 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59816 Z2=P(IA3,4)/P(N+2,4)
59817 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59818
59819C...Second case: when one original parton radiates to three.
59820C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59821 ELSE
59822 DO 110 J=1,4
59823 P(N+2,J)=P(IA3,J)+P(IA4,J)
59824 P(N+1,J)=P(N+2,J)+P(IA2,J)
59825 110 CONTINUE
59826 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59827 & P(N+1,3)**2))
59828 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59829 & P(N+2,3)**2))
59830 IF(K(IA2,2).EQ.21) THEN
59831 Z1=P(N+2,4)/P(N+1,4)
59832 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59833 & P(IA3,5)**2)
59834 ELSE
59835 Z1=P(IA2,4)/P(N+1,4)
59836 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59837 & P(IA2,5)**2)
59838 ENDIF
59839 Z2=P(IA3,4)/P(N+2,4)
59840 IF(K(IA2,2).EQ.21) THEN
59841 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59842 & P(IA3,5)**2)
59843 ELSEIF(K(IA3,2).EQ.21) THEN
59844 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59845 ELSE
59846 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59847 ENDIF
59848 ENDIF
59849
59850C...Total weight.
59851 PY4JTW=WT1*WT2
59852
59853 RETURN
59854 END
59855
59856C*********************************************************************
59857
59858C...PY4JTS
59859C...Auxiliary to PY4JET, to set up chosen configuration.
59860
59861 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59862
59863C...Double precision and integer declarations.
59864 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59865 IMPLICIT INTEGER(I-N)
59866 INTEGER PYK,PYCHGE,PYCOMP
59867C...Commonblocks.
59868 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59869 SAVE /PYJETS/
59870
59871C...Reset info.
59872 DO 110 I=N+1,N+6
59873 DO 100 J=1,5
59874 K(I,J)=0
59875 V(I,J)=V(IA2,J)
59876 100 CONTINUE
59877 K(I,1)=16
59878 110 CONTINUE
59879
59880C...First case: when both original partons radiate.
59881C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59882 IF(IA1.NE.0) THEN
59883
59884C...Set up flavour and history pointers for new partons.
59885 K(N+1,2)=K(IA1,2)
59886 K(N+2,2)=K(IA3,2)
59887 K(N+3,2)=K(IA1,2)
59888 K(N+4,2)=K(IA2,2)
59889 K(N+5,2)=K(IA3,2)
59890 K(N+6,2)=K(IA4,2)
59891 K(N+1,3)=IA1
59892 K(N+1,4)=N+3
59893 K(N+1,5)=N+4
59894 K(N+2,3)=IA3
59895 K(N+2,4)=N+5
59896 K(N+2,5)=N+6
59897 K(N+3,3)=N+1
59898 K(N+4,3)=N+1
59899 K(N+5,3)=N+2
59900 K(N+6,3)=N+2
59901
59902C...Set up momenta for new partons.
59903 DO 120 J=1,5
59904 P(N+1,J)=P(IA1,J)+P(IA2,J)
59905 P(N+2,J)=P(IA3,J)+P(IA4,J)
59906 P(N+3,J)=P(IA1,J)
59907 P(N+4,J)=P(IA2,J)
59908 P(N+5,J)=P(IA3,J)
59909 P(N+6,J)=P(IA4,J)
59910 120 CONTINUE
59911 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59912 & P(N+1,3)**2))
59913 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59914 & P(N+2,3)**2))
59915 QMAX=MIN(P(N+1,5),P(N+2,5))
59916
59917C...Second case: q radiates twice.
59918C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59919C...IA5=N+2 does not radiate.
59920 ELSEIF(K(IA2,2).EQ.21) THEN
59921
59922C...Set up flavour and history pointers for new partons.
59923 K(N+1,2)=K(IA3,2)
59924 K(N+2,2)=K(IA5,2)
59925 K(N+3,2)=K(IA3,2)
59926 K(N+4,2)=K(IA2,2)
59927 K(N+5,2)=K(IA3,2)
59928 K(N+6,2)=K(IA4,2)
59929 K(N+1,3)=IA3
59930 K(N+1,4)=N+3
59931 K(N+1,5)=N+4
59932 K(N+2,3)=IA5
59933 K(N+3,3)=N+1
59934 K(N+3,4)=N+5
59935 K(N+3,5)=N+6
59936 K(N+4,3)=N+1
59937 K(N+5,3)=N+3
59938 K(N+6,3)=N+3
59939
59940C...Set up momenta for new partons.
59941 DO 130 J=1,5
59942 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59943 P(N+2,J)=P(IA5,J)
59944 P(N+3,J)=P(IA3,J)+P(IA4,J)
59945 P(N+4,J)=P(IA2,J)
59946 P(N+5,J)=P(IA3,J)
59947 P(N+6,J)=P(IA4,J)
59948 130 CONTINUE
59949 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59950 & P(N+1,3)**2))
59951 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59952 & P(N+3,3)**2))
59953 QMAX=P(N+3,5)
59954
59955C...Third case: q radiates g, g branches.
59956C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59957C...IA5=N+2 does not radiate.
59958 ELSE
59959
59960C...Set up flavour and history pointers for new partons.
59961 K(N+1,2)=K(IA2,2)
59962 K(N+2,2)=K(IA5,2)
59963 K(N+3,2)=K(IA2,2)
59964 K(N+4,2)=21
59965 K(N+5,2)=K(IA3,2)
59966 K(N+6,2)=K(IA4,2)
59967 K(N+1,3)=IA2
59968 K(N+1,4)=N+3
59969 K(N+1,5)=N+4
59970 K(N+2,3)=IA5
59971 K(N+3,3)=N+1
59972 K(N+4,3)=N+1
59973 K(N+4,4)=N+5
59974 K(N+4,5)=N+6
59975 K(N+5,3)=N+4
59976 K(N+6,3)=N+4
59977
59978C...Set up momenta for new partons.
59979 DO 140 J=1,5
59980 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59981 P(N+2,J)=P(IA5,J)
59982 P(N+3,J)=P(IA2,J)
59983 P(N+4,J)=P(IA3,J)+P(IA4,J)
59984 P(N+5,J)=P(IA3,J)
59985 P(N+6,J)=P(IA4,J)
59986 140 CONTINUE
59987 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59988 & P(N+1,3)**2))
59989 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
59990 & P(N+4,3)**2))
59991 QMAX=P(N+4,5)
59992
59993 ENDIF
59994 N=N+6
59995
59996 RETURN
59997 END
59998
59999C*********************************************************************
60000
60001C...PYJOIN
60002C...Connects a sequence of partons with colour flow indices,
60003C...as required for subsequent shower evolution (or other operations).
60004
60005 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60006
60007C...Double precision and integer declarations.
60008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60009 IMPLICIT INTEGER(I-N)
60010 INTEGER PYK,PYCHGE,PYCOMP
60011C...Commonblocks.
60012 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60015 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60016C...Local array.
60017 DIMENSION IJOIN(*)
60018
60019C...Check that partons are of right types to be connected.
60020 IF(NJOIN.LT.2) GOTO 120
60021 KQSUM=0
60022 DO 100 IJN=1,NJOIN
60023 I=IJOIN(IJN)
60024 IF(I.LE.0.OR.I.GT.N) GOTO 120
60025 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60026 KC=PYCOMP(K(I,2))
60027 IF(KC.EQ.0) GOTO 120
60028 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60029 IF(KQ.EQ.0) GOTO 120
60030 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60031 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60032 IF(IJN.EQ.1) KQS=KQ
60033 100 CONTINUE
60034 IF(KQSUM.NE.0) GOTO 120
60035
60036C...Connect the partons sequentially (closing for gluon loop).
60037 KCS=(9-KQS)/2
60038 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60039 DO 110 IJN=1,NJOIN
60040 I=IJOIN(IJN)
60041 K(I,1)=3
60042 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60043 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60044 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60045 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60046 K(I,KCS)=MSTU(5)*IN
60047 K(I,9-KCS)=MSTU(5)*IP
60048 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60049 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60050 110 CONTINUE
60051
60052C...Error exit: no action taken.
60053 RETURN
60054 120 CALL PYERRM(12,
60055 &'(PYJOIN:) given entries can not be joined by one string')
60056
60057 RETURN
60058 END
60059
60060C*********************************************************************
60061
60062C...PYGIVE
60063C...Sets values of commonblock variables.
60064
60065 SUBROUTINE PYGIVE(CHIN)
60066
60067C...Double precision and integer declarations.
60068 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60069 IMPLICIT INTEGER(I-N)
60070 INTEGER PYK,PYCHGE,PYCOMP
60071C...Commonblocks.
60072 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60073 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60074 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60075 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60076 COMMON/PYDAT4/CHAF(500,2)
60077 CHARACTER CHAF*16
60078 COMMON/PYDATR/MRPY(6),RRPY(100)
60079 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60081 COMMON/PYINT1/MINT(400),VINT(400)
60082 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60083 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60084 COMMON/PYINT4/MWID(500),WIDS(500,5)
60085 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60086 COMMON/PYINT6/PROC(0:500)
60087 CHARACTER PROC*28
60088 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60089 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60090 &XPDIR(-6:6)
60091 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60092 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60093 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60094 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60095 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60096 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60097 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60098C...Local arrays and character variables.
60099 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60100 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60101 &CHINR*16,CHDIG*10
60102 DIMENSION MSVAR(56,8)
60103
60104C...For each variable to be translated give: name,
60105C...integer/real/character, no. of indices, lower&upper index bounds.
60106 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60107 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60108 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60109 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60110 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60111 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60112 &'ITCM','RTCM','IUED','RUED'/
60113 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60114 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60115 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60116 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60117 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60118 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60119 &1,1,1,6,4*0, 2,1,1,100,4*0,
60120 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60121 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60122 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60123 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60124 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60125 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60126 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60127 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60128 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60129 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60130 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60131 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60132 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60133
60134C...Length of character variable. Subdivide it into instructions.
60135 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60136 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60137 CHBIT=CHIN//' '
60138 LBIT=101
60139 100 LBIT=LBIT-1
60140 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60141 LTOT=0
60142 DO 110 LCOM=1,LBIT
60143 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60144 LTOT=LTOT+1
60145 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60146 110 CONTINUE
60147 LLOW=0
60148 120 LHIG=LLOW+1
60149 130 LHIG=LHIG+1
60150 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60151 LBIT=LHIG-LLOW-1
60152 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60153
60154C...Send off decay-mode on/off commands to PYONOF.
60155 IONOF=0
60156 DO 135 LDIG=1,10
60157 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60158 135 CONTINUE
60159 IF(IONOF.EQ.1) THEN
60160 CALL PYONOF(CHIN)
60161 RETURN
60162 ENDIF
60163
60164C...Peel off any text following exclamation mark.
60165 LHIG2=LBIT
60166 DO 140 LLOW2=LHIG2,1,-1
60167 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60168 140 CONTINUE
60169 IF(LBIT.EQ.0) RETURN
60170
60171C...Identify commonblock variable.
60172 LNAM=1
60173 150 LNAM=LNAM+1
60174 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60175 &LNAM.LE.6) GOTO 150
60176 CHNAM=CHBIT(1:LNAM-1)//' '
60177 DO 170 LCOM=1,LNAM-1
60178 DO 160 LALP=1,26
60179 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60180 & CHALP(2)(LALP:LALP)
60181 160 CONTINUE
60182 170 CONTINUE
60183 IVAR=0
60184 DO 180 IV=1,56
60185 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60186 180 CONTINUE
60187 IF(IVAR.EQ.0) THEN
60188 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60189 LLOW=LHIG
60190 IF(LLOW.LT.LTOT) GOTO 120
60191 RETURN
60192 ENDIF
60193
60194C...Identify any indices.
60195 I1=0
60196 I2=0
60197 I3=0
60198 NINDX=0
60199 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60200 LIND=LNAM
60201 190 LIND=LIND+1
60202 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60203 CHIND=' '
60204 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60205 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60206 & IVAR.EQ.37)) THEN
60207 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60208 READ(CHIND,'(I8)') KF
60209 I1=PYCOMP(KF)
60210 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60211 & 'c') THEN
60212 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60213 & CHNAM)
60214 LLOW=LHIG
60215 IF(LLOW.LT.LTOT) GOTO 120
60216 RETURN
60217 ELSE
60218 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60219 READ(CHIND,'(I8)') I1
60220 ENDIF
60221 LNAM=LIND
60222 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60223 NINDX=1
60224 ENDIF
60225 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60226 LIND=LNAM
60227 200 LIND=LIND+1
60228 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60229 CHIND=' '
60230 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60231 READ(CHIND,'(I8)') I2
60232 LNAM=LIND
60233 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60234 NINDX=2
60235 ENDIF
60236 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60237 LIND=LNAM
60238 210 LIND=LIND+1
60239 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60240 CHIND=' '
60241 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60242 READ(CHIND,'(I8)') I3
60243 LNAM=LIND+1
60244 NINDX=3
60245 ENDIF
60246
60247C...Check that indices allowed.
60248 IERR=0
60249 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60250 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60251 &IERR=2
60252 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60253 &IERR=3
60254 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60255 &IERR=4
60256 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60257 IF(IERR.GE.1) THEN
60258 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60259 & CHBIT(1:LNAM-1))
60260 LLOW=LHIG
60261 IF(LLOW.LT.LTOT) GOTO 120
60262 RETURN
60263 ENDIF
60264
60265C...Save old value of variable.
60266 IF(IVAR.EQ.1) THEN
60267 IOLD=N
60268 ELSEIF(IVAR.EQ.2) THEN
60269 IOLD=K(I1,I2)
60270 ELSEIF(IVAR.EQ.3) THEN
60271 ROLD=P(I1,I2)
60272 ELSEIF(IVAR.EQ.4) THEN
60273 ROLD=V(I1,I2)
60274 ELSEIF(IVAR.EQ.5) THEN
60275 IOLD=MSTU(I1)
60276 ELSEIF(IVAR.EQ.6) THEN
60277 ROLD=PARU(I1)
60278 ELSEIF(IVAR.EQ.7) THEN
60279 IOLD=MSTJ(I1)
60280 ELSEIF(IVAR.EQ.8) THEN
60281 ROLD=PARJ(I1)
60282 ELSEIF(IVAR.EQ.9) THEN
60283 IOLD=KCHG(I1,I2)
60284 ELSEIF(IVAR.EQ.10) THEN
60285 ROLD=PMAS(I1,I2)
60286 ELSEIF(IVAR.EQ.11) THEN
60287 ROLD=PARF(I1)
60288 ELSEIF(IVAR.EQ.12) THEN
60289 ROLD=VCKM(I1,I2)
60290 ELSEIF(IVAR.EQ.13) THEN
60291 IOLD=MDCY(I1,I2)
60292 ELSEIF(IVAR.EQ.14) THEN
60293 IOLD=MDME(I1,I2)
60294 ELSEIF(IVAR.EQ.15) THEN
60295 ROLD=BRAT(I1)
60296 ELSEIF(IVAR.EQ.16) THEN
60297 IOLD=KFDP(I1,I2)
60298 ELSEIF(IVAR.EQ.17) THEN
60299 CHOLD=CHAF(I1,I2)(1:8)
60300 ELSEIF(IVAR.EQ.18) THEN
60301 IOLD=MRPY(I1)
60302 ELSEIF(IVAR.EQ.19) THEN
60303 ROLD=RRPY(I1)
60304 ELSEIF(IVAR.EQ.20) THEN
60305 IOLD=MSEL
60306 ELSEIF(IVAR.EQ.21) THEN
60307 IOLD=MSUB(I1)
60308 ELSEIF(IVAR.EQ.22) THEN
60309 IOLD=KFIN(I1,I2)
60310 ELSEIF(IVAR.EQ.23) THEN
60311 ROLD=CKIN(I1)
60312 ELSEIF(IVAR.EQ.24) THEN
60313 IOLD=MSTP(I1)
60314 ELSEIF(IVAR.EQ.25) THEN
60315 ROLD=PARP(I1)
60316 ELSEIF(IVAR.EQ.26) THEN
60317 IOLD=MSTI(I1)
60318 ELSEIF(IVAR.EQ.27) THEN
60319 ROLD=PARI(I1)
60320 ELSEIF(IVAR.EQ.28) THEN
60321 IOLD=MINT(I1)
60322 ELSEIF(IVAR.EQ.29) THEN
60323 ROLD=VINT(I1)
60324 ELSEIF(IVAR.EQ.30) THEN
60325 IOLD=ISET(I1)
60326 ELSEIF(IVAR.EQ.31) THEN
60327 IOLD=KFPR(I1,I2)
60328 ELSEIF(IVAR.EQ.32) THEN
60329 ROLD=COEF(I1,I2)
60330 ELSEIF(IVAR.EQ.33) THEN
60331 IOLD=ICOL(I1,I2,I3)
60332 ELSEIF(IVAR.EQ.34) THEN
60333 ROLD=XSFX(I1,I2)
60334 ELSEIF(IVAR.EQ.35) THEN
60335 IOLD=ISIG(I1,I2)
60336 ELSEIF(IVAR.EQ.36) THEN
60337 ROLD=SIGH(I1)
60338 ELSEIF(IVAR.EQ.37) THEN
60339 IOLD=MWID(I1)
60340 ELSEIF(IVAR.EQ.38) THEN
60341 ROLD=WIDS(I1,I2)
60342 ELSEIF(IVAR.EQ.39) THEN
60343 IOLD=NGEN(I1,I2)
60344 ELSEIF(IVAR.EQ.40) THEN
60345 ROLD=XSEC(I1,I2)
60346 ELSEIF(IVAR.EQ.41) THEN
60347 CHOLD2=PROC(I1)
60348 ELSEIF(IVAR.EQ.42) THEN
60349 ROLD=SIGT(I1,I2,I3)
60350 ELSEIF(IVAR.EQ.43) THEN
60351 ROLD=XPVMD(I1)
60352 ELSEIF(IVAR.EQ.44) THEN
60353 ROLD=XPANL(I1)
60354 ELSEIF(IVAR.EQ.45) THEN
60355 ROLD=XPANH(I1)
60356 ELSEIF(IVAR.EQ.46) THEN
60357 ROLD=XPBEH(I1)
60358 ELSEIF(IVAR.EQ.47) THEN
60359 ROLD=XPDIR(I1)
60360 ELSEIF(IVAR.EQ.48) THEN
60361 IOLD=IMSS(I1)
60362 ELSEIF(IVAR.EQ.49) THEN
60363 ROLD=RMSS(I1)
60364 ELSEIF(IVAR.EQ.50) THEN
60365 ROLD=RVLAM(I1,I2,I3)
60366 ELSEIF(IVAR.EQ.51) THEN
60367 ROLD=RVLAMP(I1,I2,I3)
60368 ELSEIF(IVAR.EQ.52) THEN
60369 ROLD=RVLAMB(I1,I2,I3)
60370 ELSEIF(IVAR.EQ.53) THEN
60371 IOLD=ITCM(I1)
60372 ELSEIF(IVAR.EQ.54) THEN
60373 ROLD=RTCM(I1)
60374 ELSEIF(IVAR.EQ.55) THEN
60375 IOLD=IUED(I1)
60376 ELSEIF(IVAR.EQ.56) THEN
60377 ROLD=RUED(I1)
60378 ENDIF
60379
60380C...Print current value of variable. Loop back.
60381 IF(LNAM.GE.LBIT) THEN
60382 CHBIT(LNAM:14)=' '
60383 CHBIT(15:60)=' has the value '
60384 IF(MSVAR(IVAR,1).EQ.1) THEN
60385 WRITE(CHBIT(51:60),'(I10)') IOLD
60386 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60387 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60388 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60389 CHBIT(53:60)=CHOLD
60390 ELSE
60391 CHBIT(33:60)=CHOLD
60392 ENDIF
60393 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60394 LLOW=LHIG
60395 IF(LLOW.LT.LTOT) GOTO 120
60396 RETURN
60397 ENDIF
60398
60399C...Read in new variable value.
60400 IF(MSVAR(IVAR,1).EQ.1) THEN
60401 CHINI=' '
60402 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60403 READ(CHINI,'(I10)') INEW
60404 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60405 CHINR=' '
60406 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60407 READ(CHINR,*) RNEW
60408 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60409 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60410 ELSE
60411 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60412 ENDIF
60413
60414C...Store new variable value.
60415 IF(IVAR.EQ.1) THEN
60416 N=INEW
60417 ELSEIF(IVAR.EQ.2) THEN
60418 K(I1,I2)=INEW
60419 ELSEIF(IVAR.EQ.3) THEN
60420 P(I1,I2)=RNEW
60421 ELSEIF(IVAR.EQ.4) THEN
60422 V(I1,I2)=RNEW
60423 ELSEIF(IVAR.EQ.5) THEN
60424 MSTU(I1)=INEW
60425 ELSEIF(IVAR.EQ.6) THEN
60426 PARU(I1)=RNEW
60427 ELSEIF(IVAR.EQ.7) THEN
60428 MSTJ(I1)=INEW
60429 ELSEIF(IVAR.EQ.8) THEN
60430 PARJ(I1)=RNEW
60431 ELSEIF(IVAR.EQ.9) THEN
60432 KCHG(I1,I2)=INEW
60433 ELSEIF(IVAR.EQ.10) THEN
60434 PMAS(I1,I2)=RNEW
60435 ELSEIF(IVAR.EQ.11) THEN
60436 PARF(I1)=RNEW
60437 ELSEIF(IVAR.EQ.12) THEN
60438 VCKM(I1,I2)=RNEW
60439 ELSEIF(IVAR.EQ.13) THEN
60440 MDCY(I1,I2)=INEW
60441 ELSEIF(IVAR.EQ.14) THEN
60442 MDME(I1,I2)=INEW
60443 ELSEIF(IVAR.EQ.15) THEN
60444 BRAT(I1)=RNEW
60445 ELSEIF(IVAR.EQ.16) THEN
60446 KFDP(I1,I2)=INEW
60447 ELSEIF(IVAR.EQ.17) THEN
60448 CHAF(I1,I2)=CHNEW
60449 ELSEIF(IVAR.EQ.18) THEN
60450 MRPY(I1)=INEW
60451 ELSEIF(IVAR.EQ.19) THEN
60452 RRPY(I1)=RNEW
60453 ELSEIF(IVAR.EQ.20) THEN
60454 MSEL=INEW
60455 ELSEIF(IVAR.EQ.21) THEN
60456 MSUB(I1)=INEW
60457 ELSEIF(IVAR.EQ.22) THEN
60458 KFIN(I1,I2)=INEW
60459 ELSEIF(IVAR.EQ.23) THEN
60460 CKIN(I1)=RNEW
60461 ELSEIF(IVAR.EQ.24) THEN
60462 MSTP(I1)=INEW
60463 ELSEIF(IVAR.EQ.25) THEN
60464 PARP(I1)=RNEW
60465 ELSEIF(IVAR.EQ.26) THEN
60466 MSTI(I1)=INEW
60467 ELSEIF(IVAR.EQ.27) THEN
60468 PARI(I1)=RNEW
60469 ELSEIF(IVAR.EQ.28) THEN
60470 MINT(I1)=INEW
60471 ELSEIF(IVAR.EQ.29) THEN
60472 VINT(I1)=RNEW
60473 ELSEIF(IVAR.EQ.30) THEN
60474 ISET(I1)=INEW
60475 ELSEIF(IVAR.EQ.31) THEN
60476 KFPR(I1,I2)=INEW
60477 ELSEIF(IVAR.EQ.32) THEN
60478 COEF(I1,I2)=RNEW
60479 ELSEIF(IVAR.EQ.33) THEN
60480 ICOL(I1,I2,I3)=INEW
60481 ELSEIF(IVAR.EQ.34) THEN
60482 XSFX(I1,I2)=RNEW
60483 ELSEIF(IVAR.EQ.35) THEN
60484 ISIG(I1,I2)=INEW
60485 ELSEIF(IVAR.EQ.36) THEN
60486 SIGH(I1)=RNEW
60487 ELSEIF(IVAR.EQ.37) THEN
60488 MWID(I1)=INEW
60489 ELSEIF(IVAR.EQ.38) THEN
60490 WIDS(I1,I2)=RNEW
60491 ELSEIF(IVAR.EQ.39) THEN
60492 NGEN(I1,I2)=INEW
60493 ELSEIF(IVAR.EQ.40) THEN
60494 XSEC(I1,I2)=RNEW
60495 ELSEIF(IVAR.EQ.41) THEN
60496 PROC(I1)=CHNEW2
60497 ELSEIF(IVAR.EQ.42) THEN
60498 SIGT(I1,I2,I3)=RNEW
60499 ELSEIF(IVAR.EQ.43) THEN
60500 XPVMD(I1)=RNEW
60501 ELSEIF(IVAR.EQ.44) THEN
60502 XPANL(I1)=RNEW
60503 ELSEIF(IVAR.EQ.45) THEN
60504 XPANH(I1)=RNEW
60505 ELSEIF(IVAR.EQ.46) THEN
60506 XPBEH(I1)=RNEW
60507 ELSEIF(IVAR.EQ.47) THEN
60508 XPDIR(I1)=RNEW
60509 ELSEIF(IVAR.EQ.48) THEN
60510 IMSS(I1)=INEW
60511 ELSEIF(IVAR.EQ.49) THEN
60512 RMSS(I1)=RNEW
60513 ELSEIF(IVAR.EQ.50) THEN
60514 RVLAM(I1,I2,I3)=RNEW
60515 ELSEIF(IVAR.EQ.51) THEN
60516 RVLAMP(I1,I2,I3)=RNEW
60517 ELSEIF(IVAR.EQ.52) THEN
60518 RVLAMB(I1,I2,I3)=RNEW
60519 ELSEIF(IVAR.EQ.53) THEN
60520 ITCM(I1)=INEW
60521 ELSEIF(IVAR.EQ.54) THEN
60522 RTCM(I1)=RNEW
60523 ELSEIF(IVAR.EQ.55) THEN
60524 IUED(I1)=INEW
60525 ELSEIF(IVAR.EQ.56) THEN
60526 RUED(I1)=RNEW
60527 ENDIF
60528
60529C...Write old and new value. Loop back.
60530 CHBIT(LNAM:14)=' '
60531 CHBIT(15:60)=' changed from to '
60532 IF(MSVAR(IVAR,1).EQ.1) THEN
60533 WRITE(CHBIT(33:42),'(I10)') IOLD
60534 WRITE(CHBIT(51:60),'(I10)') INEW
60535 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60536 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60537 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60538 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60539 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60540 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60541 CHBIT(35:42)=CHOLD
60542 CHBIT(53:60)=CHNEW
60543 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60544 ELSE
60545 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60546 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60547 ENDIF
60548 LLOW=LHIG
60549 IF(LLOW.LT.LTOT) GOTO 120
60550
60551C...Format statement for output on unit MSTU(11) (by default 6).
60552 5000 FORMAT(5X,A60)
60553 5100 FORMAT(5X,A88)
60554
60555 RETURN
60556 END
60557
60558C*********************************************************************
60559
60560C...PYONOF
60561C...Switches on and off decay channel by search for match.
60562
60563 SUBROUTINE PYONOF(CHIN)
60564
60565C...Double precision and integer declarations.
60566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60567 IMPLICIT INTEGER(I-N)
60568 INTEGER PYK,PYCHGE,PYCOMP
60569C...Commonblocks.
60570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60571 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60572 SAVE /PYDAT1/,/PYDAT3/
60573C...Local arrays and character variables.
60574 INTEGER KFCMP(10),KFTMP(10)
60575 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60576 &CHALP(2)*26
60577 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60578 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60579
60580C...Determine length of character variable.
60581 CHTMP=CHIN//' '
60582 LBEG=0
60583 100 LBEG=LBEG+1
60584 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60585 LEND=LBEG-1
60586 105 LEND=LEND+1
60587 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60588 110 LEND=LEND-1
60589 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60590 LEN=1+LEND-LBEG
60591 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60592
60593C...Find colon separator and particle code.
60594 LCOLON=0
60595 120 LCOLON=LCOLON+1
60596 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60597 CHCODE=' '
60598 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60599 READ(CHCODE,'(I8)',ERR=300) KF
60600 KC=PYCOMP(KF)
60601
60602C...Done if unknown code or no decay channels.
60603 IF(KC.EQ.0) THEN
60604 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60605 RETURN
60606 ENDIF
60607 IDCBEG=MDCY(KC,2)
60608 IDCLEN=MDCY(KC,3)
60609 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60610 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60611 RETURN
60612 ENDIF
60613
60614C...Find command name up to blank or equal sign.
60615 LSEP=LCOLON
60616 130 LSEP=LSEP+1
60617 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60618 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60619 CHMODE=' '
60620 LMODE=LSEP-LCOLON-1
60621 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60622
60623C...Convert to uppercase.
60624 DO 150 LCOM=1,LMODE
60625 DO 140 LALP=1,26
60626 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60627 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60628 140 CONTINUE
60629 150 CONTINUE
60630
60631C...Identify command. Failed if not identified.
60632 MODE=0
60633 IF(CHMODE.EQ.'ALLOFF') MODE=1
60634 IF(CHMODE.EQ.'ALLON') MODE=2
60635 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60636 IF(CHMODE.EQ.'ONIFANY') MODE=4
60637 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60638 IF(CHMODE.EQ.'ONIFALL') MODE=6
60639 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60640 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60641 IF(MODE.EQ.0) THEN
60642 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60643 RETURN
60644 ENDIF
60645
60646C...Simple cases when all on or all off.
60647 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60648 WRITE(MSTU(11),1000) KF,CHMODE
60649 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60650 IF(MDME(IDC,1).LT.0) GOTO 160
60651 MDME(IDC,1)=MODE-1
60652 160 CONTINUE
60653 RETURN
60654 ENDIF
60655
60656C...Identify matching list.
60657 NCMP=0
60658 LBEG=LSEP
60659 170 LBEG=LBEG+1
60660 IF(LBEG.GT.LEN) GOTO 190
60661 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60662 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60663 LEND=LBEG-1
60664 180 LEND=LEND+1
60665 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60666 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60667 IF(LEND.LT.LEN) LEND=LEND-1
60668 CHCODE=' '
60669 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60670 READ(CHCODE,'(I8)',ERR=300) KFREAD
60671 NCMP=NCMP+1
60672 KFCMP(NCMP)=IABS(KFREAD)
60673 LBEG=LEND
60674 IF(NCMP.LT.10) GOTO 170
60675 190 CONTINUE
60676 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60677
60678C...Only one matching required.
60679 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60680 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60681 IF(MDME(IDC,1).LT.0) GOTO 220
60682 DO 210 IKF=1,5
60683 KFNOW=IABS(KFDP(IDC,IKF))
60684 IF(KFNOW.EQ.0) GOTO 210
60685 DO 200 ICMP=1,NCMP
60686 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60687 MDME(IDC,1)=MODE-3
60688 GOTO 220
60689 ENDIF
60690 200 CONTINUE
60691 210 CONTINUE
60692 220 CONTINUE
60693 RETURN
60694 ENDIF
60695
60696C...Multiple matchings required.
60697 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60698 IF(MDME(IDC,1).LT.0) GOTO 260
60699 NTMP=NCMP
60700 DO 230 ITMP=1,NTMP
60701 KFTMP(ITMP)=KFCMP(ITMP)
60702 230 CONTINUE
60703 NFIN=0
60704 DO 250 IKF=1,5
60705 KFNOW=IABS(KFDP(IDC,IKF))
60706 IF(KFNOW.EQ.0) GOTO 250
60707 NFIN=NFIN+1
60708 DO 240 ITMP=1,NTMP
60709 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60710 KFTMP(ITMP)=KFTMP(NTMP)
60711 NTMP=NTMP-1
60712 GOTO 250
60713 ENDIF
60714 240 CONTINUE
60715 250 CONTINUE
60716 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60717 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60718 & MDME(IDC,1)=MODE-7
60719 260 CONTINUE
60720 RETURN
60721
60722C...Error exit for impossible read of particle code.
60723 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60724 &//CHCODE)
60725
60726C...Formats for output.
60727 1000 FORMAT(' Decays for',I8,' set ',A10)
60728 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60729
60730 RETURN
60731 END
60732C*********************************************************************
60733
60734C...PYTUNE
60735C...Presets for a few specific underlying-event and min-bias tunes
60736C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60737C...others require particular versions of pythia (e.g. the SCI and GAL
60738C...models). See below for details.
60739 SUBROUTINE PYTUNE(ITUNE)
60740C
60741C ITUNE NAME (detailed descriptions below)
60742C 0 Default : No settings changed => defaults.
60743C
60744C ====== Old UE, Q2-ordered showers ====================================
60745C 100 A : Rick Field's CDF Tune A (Oct 2002)
60746C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60747C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60748C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60749C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60750C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60751C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60752C 107 ACR : Tune A modified with new CR model (Mar 2007)
60753C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60754C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60755C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60756C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60757C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60758C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60759C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60760C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60761C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60762C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60763C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60764C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60765C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60766C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60767C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60768C
60769C ====== Intermediate and Hybrid Models ================================
60770C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60771C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60772C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60773C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60774C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60775C
60776C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60777C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60778C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60779C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60780C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60781C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60782C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60783C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60784C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60785C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60786C 311 S1-Pro : S1 -"- (Oct 2008)
60787C 312 S2-Pro : S2 -"- (Oct 2008)
60788C 313 S0A-Pro : S0A -"- (Oct 2008)
60789C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60790C 315 Old-Pro : Old -"- (Oct 2008)
60791C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60792C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60793C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60794C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60795C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60796C balance & different scaling to LHC & RHIC (Feb 2009)
60797C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60798C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60799C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60800C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60801C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60802C
60803C ======= The Uppsala models ===========================================
60804C ( NB! must be run with special modified Pythia 6.215 version )
60805C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60806C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60807C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60808C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60809C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60810C
60811C More details;
60812C
60813C Quick Dictionary:
60814C BE : Bose-Einstein
60815C BR : Beam Remnants
60816C CR : Colour Reconnections
60817C HAD: Hadronization
60818C ISR/FSR: Initial-State Radiation / Final-State Radiation
60819C FSI: Final-State Interactions (=CR+BE)
60820C MB : Minimum-bias
60821C MI : Multiple Interactions
60822C UE : Underlying Event
60823C
60824C=======================================================================
60825C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60826C=======================================================================
60827C
60828C A (100) and AW (101). CTEQ5L parton distributions
60829C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60830C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60831C...Key feature: extensively compared to CDF data (R.D. Field).
60832C...* Large starting scale for ISR (PARP(67)=4)
60833C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60834C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60835C
60836C BW (102). CTEQ5L parton distributions
60837C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60838C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60839C...Key feature: extensively compared to CDF data (R.D. Field).
60840C...NB: Can also be run with Pythia 6.2 or 6.312+
60841C...* Small starting scale for ISR (PARP(67)=1)
60842C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60843C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60844C
60845C DW (103) and DWT (104). CTEQ5L parton distributions
60846C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60847C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60848C...Key feature: extensively compared to CDF data (R.D. Field).
60849C...NB: Can also be run with Pythia 6.2 or 6.312+
60850C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60851C...* DWT has a different reference energy, the same as the "S" models
60852C... below, leading to more UE activity at the LHC, but less at RHIC.
60853C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60854C
60855C QW (105). CTEQ61 parton distributions
60856C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60857C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60858C...Key feature: uses CTEQ61 (external pdf library must be linked)
60859C
60860C ATLAS-DC2 (106). CTEQ5L parton distributions
60861C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60862C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60863C...Key feature: tune used by the ATLAS collaboration.
60864C
60865C ACR (107). CTEQ5L parton distributions
60866C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60867C...Key feature: Tune A modified to use annealing CR.
60868C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60869C
60870C D6 (108) and D6T (109). CTEQ6L parton distributions
60871C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60872C
60873C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60874C Old UE model, Q2-ordered showers.
60875C...Key feature: Rick Field's family of tunes revamped with the
60876C...Professor Q2-ordered final-state shower and fragmentation tunes
60877C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60878C...Key feature: improved descriptions of LEP data.
60879C
60880C Pro-Q20 (129). CTEQ5L parton distributions
60881C Old UE model, Q2-ordered showers.
60882C...Key feature: Complete retune of old model by Professor, including
60883C...large amounts of both LEP and Tevatron data.
60884C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60885C...extreme in this tune, corresponding to using mu_R = pT/3 .
60886C
60887C=======================================================================
60888C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60889C=======================================================================
60890C
60891C IM1 (200). Intermediate model, Q2-ordered showers,
60892C CTEQ5L parton distributions
60893C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60894C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60895C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60896C
60897C APT (201). Old UE model, pT-ordered final-state showers,
60898C CTEQ5L parton distributions
60899C...Key feature: Rick Field's Tune A, but with new final-state showers
60900C
60901C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60902C CTEQ5L parton distributions
60903C...Key feature: APT revamped with the Professor pT-ordered final-state
60904C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60905C...Perugia MPI workshop in October 2008.
60906C
60907C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60908C CTEQ5L parton distributions
60909C...Key feature: APT-Pro with final-state showers off the MPI,
60910C...lower ISR renormalization scale to improve agreement with the
60911C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60912C...to min-bias at 630 GeV.
60913C
60914C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60915C CTEQ6L1 parton distributions.
60916C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60917C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60918C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60919C
60920C=======================================================================
60921C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60922C=======================================================================
60923C
60924C S0 (300) and S0A (303). CTEQ5L parton distributions
60925C...Key feature: large amount of multiple interactions
60926C...* Somewhat faster than the other colour annealing scenarios.
60927C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60928C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60929C...* Small amount of radiation.
60930C...* Large amount of low-pT MI
60931C...* Low degree of proton lumpiness (broad matter dist.)
60932C...* CR Type S (driven by free triplets), of medium strength.
60933C...* See: Pythia6402 update notes or later.
60934C
60935C S1 (301). CTEQ5L parton distributions
60936C...Key feature: large amount of radiation.
60937C...* Large amount of low-pT perturbative ISR
60938C...* Large amount of FSR off ISR partons
60939C...* Small amount of low-pT multiple interactions
60940C...* Moderate degree of proton lumpiness
60941C...* Least aggressive CR type (S+S Type I), but with large strength
60942C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60943C
60944C S2 (302). CTEQ5L parton distributions
60945C...Key feature: very lumpy proton + gg string cluster formation allowed
60946C...* Small amount of radiation
60947C...* Moderate amount of low-pT MI
60948C...* High degree of proton lumpiness (more spiky matter distribution)
60949C...* Most aggressive CR type (S+S Type II), but with small strength
60950C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60951C
60952C NOCR (304). CTEQ5L parton distributions
60953C...Key feature: no colour reconnections (NB: "Best fit" only).
60954C...* NB: <pT>(Nch) problematic in this tune.
60955C...* Small amount of radiation
60956C...* Small amount of low-pT MI
60957C...* Low degree of proton lumpiness
60958C...* Large BR composite x enhancement factor
60959C...* Most clever colour flow without CR ("Lambda ordering")
60960C
60961C ATLAS-CSC (306). CTEQ6L parton distributions
60962C...Key feature: 11-parameter ATLAS tune of the new framework.
60963C...* Old (pre-annealing) colour reconnections a la 305.
60964C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60965C
60966C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60967C...Key feature: the S0 family of tunes revamped with the Professor
60968C...pT-ordered final-state shower and fragmentation tunes presented by
60969C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60970C...Key feature: improved descriptions of LEP data.
60971C
60972C Perugia-0 (320). CTEQ5L parton distributions.
60973C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60974C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60975C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60976C...beam-remnant breakup (more baryon number transport), and suppression
60977C...of CR in high-pT string pieces.
60978C
60979C Perugia-HARD (321). CTEQ5L parton distributions.
60980C...Key feature: More ISR, More FSR, Less MPI, Less BR
60981C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60982C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60983C...baryon number transport), and more fragmentation pT.
60984C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60985C...DY pT spectrum is HARD.
60986C
60987C Perugia-SOFT (322). CTEQ5L parton distributions.
60988C...Key feature: Less ISR, Less FSR, More MPI, More BR
60989C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60990C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
60991C...number transport), and less fragmentation pT.
60992C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
60993C...DY pT spectrum is SOFT
60994C
60995C Perugia-3 (323). CTEQ5L parton distributions.
60996C...Key feature: variant of Perugia-0 with more extreme energy scaling
60997C...properties while still agreeing with Tevatron data from 630 to 1960.
60998C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
60999C...allows FSR off the active end of dipoles stretched to the remnant.
61000C
61001C Perugia-NOCR (324). CTEQ5L parton distributions.
61002C...Key feature: Retune of NOCR-Pro with better scaling properties to
61003C...lower energies and somewhat better agreement with Tevatron data
61004C...at 1800/1960.
61005C
61006C Perugia-* (325). MRST LO* parton distributions for generators
61007C...Key feature: first attempt at using the LO* distributions
61008C...(external pdf library must be linked).
61009C
61010C Perugia-6 (326). CTEQ6L1 parton distributions
61011C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61012C
61013C Pro-pT0 (329). CTEQ5L parton distributions
61014C...Key feature: Complete retune of new model by Professor, including
61015C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61016C
61017C=======================================================================
61018C OTHER TUNES
61019C=======================================================================
61020C
61021C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61022C...with an unmodified Pythia distribution.
61023C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61024C
61025C ::: + Future improvements?
61026C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61027C (problem: K-factor affects everything so only works as
61028C intended for min-bias, not for UE ... probably need a
61029C better long-term solution to handle UE as well. Anyway,
61030C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61031
61032C...Global statements
61033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61034 INTEGER PYK,PYCHGE,PYCOMP
61035
61036C...Commonblocks.
61037 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61038 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61039
61040C...SCI and GAL Commonblocks
61041 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61042
61043C...SAVE statements
61044 SAVE /PYDAT1/,/PYPARS/
61045 SAVE /SCIPAR/
61046
61047C...Internal parameters
61048 PARAMETER(MXTUNS=500)
61049 CHARACTER*8 CHVERS, CHDOC
61050 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61051 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61052 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61053 & CHPARJ(1:100), CH40
61054 CHARACTER*60 CH60
61055 CHARACTER*70 CH70
61056 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61057 DATA (CHNAMS(I),I=100,119)/
61058 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61059 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61060 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61061 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61062 1 'Tune D6-Pro','Tune D6T-Pro'/
61063 DATA (CHNAMS(I),I=120,129)/
61064 & 9*' ','Pro-Q20'/
61065 DATA (CHNAMS(I),I=300,309)/
61066 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61067 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61068 DATA (CHNAMS(I),I=310,315)/
61069 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61070 & 'NOCR-Pro','Old-Pro'/
61071 DATA (CHNAMS(I),I=320,329)/
61072 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61073 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61074 & 'Perugia 6',2*' ','Pro-pT0'/
61075 DATA (CHNAMS(I),I=200,229)/
61076 & 'IM Tune 1','Tune APT',8*' ',
61077 & ' ','Tune APT-Pro',8*' ',
61078 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61079 DATA (CHNAMS(I),I=400,409)/
61080 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61081 DATA (CHMSTJ(I),I=11,20)/
61082 & 'HAD choice of fragmentation function(s)',4*' ',
61083 & 'HAD treatment of small-mass systems',4*' '/
61084 DATA (CHMSTJ(I),I=41,50)/
61085 & 'FSR type (Q2 or pT) for old framework',9*' '/
61086 DATA (CHMSTP(I),I=51,100)/
61087 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61088 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61089 6 'ISR coherence option for 1st emission',
61090 6 'ISR phase space choice & ME corrections',' ',
61091 7 'ISR IR regularization scheme',' ',
61092 7 'ISR scheme for FSR off ISR',8*' ',
61093 8 'UE model',
61094 8 'UE hadron transverse mass distribution',5*' ',
61095 8 'BR composite scheme','BR colour scheme',
61096 9 'BR primordial kT compensation',
61097 9 'BR primordial kT distribution',
61098 9 'BR energy partitioning scheme',2*' ',
61099 9 'FSI colour (re-)connection model',5*' '/
61100 DATA (CHPARP(I),I=61,100)/
61101 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61102 6 2*' ','ISR Q2max factor',3*' ',
61103 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61104 7 'FSI colour reco high-pT dampening strength',
61105 7 'FSI colour reconnection strength',
61106 7 'BR composite x enhancement','BR breakup suppression',
61107 8 2*'UE IR cutoff at reference ecm',
61108 8 2*'UE mass distribution parameter',
61109 8 'UE gg colour correlated fraction','UE total gg fraction',
61110 8 2*' ',
61111 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61112 9 'BR primordial kT width <|kT|>',' ',
61113 9 'BR primordial kT UV cutoff',7*' '/
61114 DATA (CHPARJ(I),I=1,30)/
61115 & 'HAD diquark suppression','HAD strangeness suppression',
61116 & 'HAD strange diquark suppression',
61117 & 'HAD vector diquark suppression',6*' ',
61118 1 'HAD P(vector meson), u and d only',
61119 1 'HAD P(vector meson), contains s',
61120 1 'HAD P(vector meson), heavy quarks',7*' ',
61121 2 'HAD fragmentation pT',' ',' ',' ',
61122 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61123 DATA (CHPARJ(I),I=41,90)/
61124 4 'HAD string parameter a','HAD string parameter b',3*' ',
61125 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61126 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61127 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61128 6 10*' ',10*' ',
61129 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61130
61131C...1) Shorthand notation
61132 M13=MSTU(13)
61133 M11=MSTU(11)
61134 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61135 CHNAME=CHNAMS(ITUNE)
61136 IF (ITUNE.EQ.0) GOTO 9999
61137 ELSE
61138 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61139 GOTO 9999
61140 ENDIF
61141
61142C...2) Hello World
61143 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61144
61145C...3) Tune parameters
61146
61147C=======================================================================
61148C...S0, S1, S2, S0A, NOCR, Rap,
61149C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61150C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61151C...Pro-pT0
61152 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61153 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61154 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61155 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61156 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61157 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61158 & ' with tune.')
61159 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61160 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61161 & THEN
61162 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61163 & ' with tune.')
61164 ENDIF
61165
61166C...Use Professor's LEP pars if ITUNE >= 310
61167C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61168 IF (ITUNE.LT.310) THEN
61169C...# Old defaults
61170 MSTJ(11) = 4
61171C...# Old default flavour parameters
61172 PARJ(21) = 0.36
61173 PARJ(41) = 0.30
61174 PARJ(42) = 0.58
61175 PARJ(46) = 1.0
61176 PARJ(82) = 1.0
61177
61178 ELSEIF (ITUNE.GE.310) THEN
61179C...# Tuned flavour parameters:
61180 PARJ(1) = 0.073
61181 PARJ(2) = 0.2
61182 PARJ(3) = 0.94
61183 PARJ(4) = 0.032
61184 PARJ(11) = 0.31
61185 PARJ(12) = 0.4
61186 PARJ(13) = 0.54
61187 PARJ(25) = 0.63
61188 PARJ(26) = 0.12
61189C...# Always use pT-ordered shower:
61190 MSTJ(41) = 12
61191C...# Switch on Bowler:
61192 MSTJ(11) = 5
61193C...# Fragmentation
61194 PARJ(21) = 0.313
61195 PARJ(41) = 0.49
61196 PARJ(42) = 1.2
61197 PARJ(47) = 1.0
61198 PARJ(81) = 0.257
61199 PARJ(82) = 0.8
61200 ENDIF
61201
61202C...Remove middle digit now for Professor variants, since identical pars
61203 ITUNEB=ITUNE
61204 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61205 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61206 ENDIF
61207
61208C...PDFs: all use CTEQ5L as starting point
61209 MSTP(52)=1
61210 MSTP(51)=7
61211 IF (ITUNE.EQ.325) THEN
61212C...MRST LO* for 325
61213 MSTP(52)=2
61214 MSTP(51)=20650
61215 ELSEIF (ITUNE.EQ.326) THEN
61216C...CTEQ6L1 for 326
61217 MSTP(52)=2
61218 MSTP(51)=10042
61219 ENDIF
61220
61221C...ISR: use Lambda_MSbar with default scale for S0(A)
61222 MSTP(64)=2
61223 PARP(64)=1D0
61224 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61225 & ITUNE.EQ.326) THEN
61226C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61227 MSTP(64)=3
61228 PARP(64)=1D0
61229 ELSEIF (ITUNE.EQ.321) THEN
61230C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61231 MSTP(64)=3
61232 PARP(64)=0.25D0
61233 ELSEIF (ITUNE.EQ.322) THEN
61234C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61235 MSTP(64)=2
61236 PARP(64)=2D0
61237 ELSEIF (ITUNE.EQ.325) THEN
61238C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61239 MSTP(64)=3
61240 PARP(64)=2D0
61241 ELSEIF (ITUNE.EQ.329) THEN
61242C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61243 MSTP(64)=2
61244 PARP(64)=1.3D0
61245 ENDIF
61246
61247C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61248 MSTP(67)=2
61249 PARP(67)=4D0
61250C...Perugia tunes have stronger suppression, except HARD
61251 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61252 PARP(67)=1D0
61253 IF (ITUNE.EQ.321) PARP(67)=4D0
61254 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61255 ENDIF
61256
61257C...ISR IR cutoff type and FSR off ISR setting:
61258C...Smooth ISR, low FSR-off-ISR
61259 MSTP(70)=2
61260 MSTP(72)=0
61261 IF (ITUNEB.EQ.301) THEN
61262C...S1, S1-Pro: sharp ISR, high FSR
61263 MSTP(70)=0
61264 MSTP(72)=1
61265 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61266 & .OR.ITUNE.EQ.325) THEN
61267C...Perugia default is smooth ISR, high FSR-off-ISR
61268 MSTP(70)=2
61269 MSTP(72)=1
61270 ELSEIF (ITUNE.EQ.321) THEN
61271C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61272 MSTP(70)=0
61273 PARP(62)=1.25D0
61274 MSTP(72)=1
61275 ELSEIF (ITUNE.EQ.322) THEN
61276C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61277 MSTP(70)=1
61278 PARP(81)=1.5D0
61279 MSTP(72)=0
61280 ELSEIF (ITUNE.EQ.323) THEN
61281C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61282 MSTP(70)=0
61283 PARP(62)=1.25D0
61284 MSTP(72)=2
61285 ENDIF
61286
61287C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61288C...by Professor tunes (with HARD and SOFT variations)
61289 PARP(71)=4D0
61290 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61291 PARP(71)=2D0
61292 IF (ITUNE.EQ.321) PARP(71)=4D0
61293 IF (ITUNE.EQ.322) PARP(71)=1D0
61294 ENDIF
61295 IF (ITUNE.EQ.329) PARP(71)=2D0
61296
61297C...FSR: Lambda_FSR scale (only if not using professor)
61298 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61299 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61300 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61301
61302C...UE on, new model
61303 MSTP(81)=21
61304
61305C...UE: hadron-hadron overlap profile (expOfPow for all)
61306 MSTP(82)=5
61307C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61308 PARP(83)=1.6D0
61309 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61310 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61311C...NOCR variants have very smooth distributions
61312 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61313 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61314 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61315C...Perugia variants have slightly smoother profiles by default
61316C...(to compensate for more tail by added radiation)
61317C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61318 PARP(83)=1.7D0
61319 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61320 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61321 ENDIF
61322C...Professor-pT0 also has very smooth distribution
61323 IF (ITUNE.EQ.329) PARP(83)=1.8
61324
61325C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61326 PARP(82)=1.85D0
61327 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61328 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61329 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61330 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61331 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61332C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61333C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61334C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61335C...slightly higher, due to increased activity.
61336 PARP(82)=2.0D0
61337 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61338 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61339 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61340 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61341 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61342 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61343 ENDIF
61344C...Professor-pT0 maintains low pT0 vaue
61345 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61346
61347C...UE: IR cutoff reference energy and default energy scaling pace
61348 PARP(89)=1800D0
61349 PARP(90)=0.16D0
61350C...S0A, S0A-Pro have tune A energy scaling
61351 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61352 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61353C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61354 PARP(90)=0.26
61355 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61356 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61357 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61358 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61359C...LO* and CTEQ6L1 tunes have slower energy scaling
61360 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61361 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61362 ENDIF
61363C...Professor-pT0 has intermediate scaling
61364 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61365
61366C...BR: MPI initiator color connections rap-ordered by default
61367C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61368 MSTP(89)=1
61369 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61370 IF (ITUNE.EQ.322) MSTP(89)=0
61371
61372C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61373 PARP(80)=0.01D0
61374 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61375C...Perugia tunes have more beam blowup by default
61376 PARP(80)=0.05D0
61377 IF (ITUNE.EQ.321) PARP(80)=0.01
61378 IF (ITUNE.EQ.323) PARP(80)=0.03
61379 IF (ITUNE.EQ.324) PARP(80)=0.01
61380 ENDIF
61381
61382C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61383 MSTP(88)=0
61384 PARP(79)=2D0
61385 IF (ITUNEB.EQ.304) PARP(79)=3D0
61386 IF (ITUNE.EQ.329) PARP(79)=1.18
61387
61388C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61389 MSTP(91)=1
61390 PARP(91)=2D0
61391 PARP(93)=10D0
61392C...Perugia-HARD only uses 1.0 GeV
61393 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61394C...Perugia-3 only uses 1.5 GeV
61395 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61396C...Professor-pT0 uses 7-GeV cutoff
61397 IF (ITUNE.EQ.329) PARP(93)=7.0
61398
61399C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61400 MSTP(95)=6
61401C...S1, S1-Pro: use S1
61402 IF (ITUNEB.EQ.301) MSTP(95)=2
61403C...S2, S2-Pro: use S2
61404 IF (ITUNEB.EQ.302) MSTP(95)=4
61405C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61406 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61407C..."Old" and "Old"-Pro: use old CR
61408 IF (ITUNEB.EQ.305) MSTP(95)=1
61409
61410C...FSI: CR strength and high-pT dampening, default is S0
61411 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61412 PARP(78)=0.2D0
61413 PARP(77)=0D0
61414 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61415 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61416 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61417 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61418 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61419 ELSE
61420C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61421 PARP(78)=0.33
61422 PARP(77)=0.9D0
61423 IF (ITUNE.EQ.321) THEN
61424C...HARD has HIGH amount of CR
61425 PARP(78)=0.37D0
61426 PARP(77)=0.4D0
61427 ELSEIF (ITUNE.EQ.322) THEN
61428C...SOFT has LOW amount of CR
61429 PARP(78)=0.15D0
61430 PARP(77)=0.5D0
61431 ELSEIF (ITUNE.EQ.323) THEN
61432C...Scaling variant appears to need slightly more than default
61433 PARP(78)=0.35D0
61434 PARP(77)=0.6D0
61435 ELSEIF (ITUNE.EQ.324) THEN
61436C...NOCR has no CR
61437 PARP(78)=0D0
61438 PARP(77)=0D0
61439 ENDIF
61440 ENDIF
61441
61442C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61443 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61444 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61445
61446C...Switch off trial joinings
61447 MSTP(96)=0
61448
61449C...S0 (300), S0A (303)
61450 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61451 IF (M13.GE.1) THEN
61452 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61453 WRITE(M11,5030) CH60
61454 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61455 WRITE(M11,5030) CH60
61456 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61457 WRITE(M11,5030) CH60
61458 IF (ITUNE.GE.310) THEN
61459 CH60='LEP parameters tuned by Professor'
61460 WRITE(M11,5030) CH60
61461 ENDIF
61462 ENDIF
61463
61464C...S1 (301)
61465 ELSEIF(ITUNEB.EQ.301) THEN
61466 IF (M13.GE.1) THEN
61467 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61468 WRITE(M11,5030) CH60
61469 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61470 WRITE(M11,5030) CH60
61471 IF (ITUNE.GE.310) THEN
61472 CH60='LEP parameters tuned with Professor'
61473 WRITE(M11,5030) CH60
61474 ENDIF
61475 ENDIF
61476
61477C...S2 (302)
61478 ELSEIF(ITUNEB.EQ.302) THEN
61479 IF (M13.GE.1) THEN
61480 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61481 WRITE(M11,5030) CH60
61482 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61483 WRITE(M11,5030) CH60
61484 IF (ITUNE.GE.310) THEN
61485 CH60='LEP parameters tuned by Professor'
61486 WRITE(M11,5030) CH60
61487 ENDIF
61488 ENDIF
61489
61490C...NOCR (304)
61491 ELSEIF(ITUNEB.EQ.304) THEN
61492 IF (M13.GE.1) THEN
61493 CH60='"best try" without colour reconnections'
61494 WRITE(M11,5030) CH60
61495 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61496 WRITE(M11,5030) CH60
61497 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61498 WRITE(M11,5030) CH60
61499 IF (ITUNE.GE.310) THEN
61500 CH60='LEP parameters tuned by Professor'
61501 WRITE(M11,5030) CH60
61502 ENDIF
61503 ENDIF
61504
61505C..."Lo FSR" retune (305)
61506 ELSEIF(ITUNEB.EQ.305) THEN
61507 IF (M13.GE.1) THEN
61508 CH60='"Lo FSR retune" with primitive colour reconnections'
61509 WRITE(M11,5030) CH60
61510 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61511 WRITE(M11,5030) CH60
61512 IF (ITUNE.GE.310) THEN
61513 CH60='LEP parameters tuned by Professor'
61514 WRITE(M11,5030) CH60
61515 ENDIF
61516 ENDIF
61517
61518C...Perugia Tunes (320-326)
61519 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61520 IF (M13.GE.1) THEN
61521 CH60='P. Skands, Perugia MPI workshop October 2008'
61522 WRITE(M11,5030) CH60
61523 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61524 WRITE(M11,5030) CH60
61525 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61526 WRITE(M11,5030) CH60
61527 CH60='LEP parameters tuned by Professor'
61528 WRITE(M11,5030) CH60
61529 IF (ITUNE.EQ.325) THEN
61530 CH70='NB! This tune requires MRST LO* pdfs to be '//
61531 & 'externally linked'
61532 WRITE(M11,5035) CH70
61533 ELSEIF (ITUNE.EQ.326) THEN
61534 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61535 & 'externally linked'
61536 WRITE(M11,5035) CH70
61537 ELSEIF (ITUNE.EQ.321) THEN
61538 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61539 WRITE(M11,5030) CH60
61540 ELSEIF (ITUNE.EQ.322) THEN
61541 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61542 WRITE(M11,5030) CH60
61543 ENDIF
61544 ENDIF
61545
61546C...Professor-pT0 (329)
61547 ELSEIF(ITUNE.EQ.329) THEN
61548 IF (M13.GE.1) THEN
61549 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61550 WRITE(M11,5030) CH60
61551 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61552 WRITE(M11,5030) CH60
61553 CH60='LEP/Tevatron parameters tuned by Professor'
61554 WRITE(M11,5030) CH60
61555 ENDIF
61556
61557 ENDIF
61558
61559C...Output
61560 IF (M13.GE.1) THEN
61561 WRITE(M11,5030) ' '
61562 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61563 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61564 IF (MSTP(70).EQ.0) THEN
61565 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61566 ELSEIF (MSTP(70).EQ.1) THEN
61567 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61568 CH60='(Note: PARP(81) replaces PARP(62).)'
61569 WRITE(M11,5030) CH60
61570 ENDIF
61571 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61572 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61573 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61574 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61575 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61576 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61577 WRITE(M11,5030) CH60
61578 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61579 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61580 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61581 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61582 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61583 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61584 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61585 IF (MSTP(70).EQ.2) THEN
61586 CH60='(Note: PARP(82) replaces PARP(62).)'
61587 WRITE(M11,5030) CH60
61588 ENDIF
61589 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61590 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61591 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61592 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61593 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61594 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61595 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61596 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61597 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61598 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61599 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61600 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61601 IF (MSTP(95).GE.1) THEN
61602 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61603 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61604 ENDIF
61605 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61606 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61607 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61608 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61609 IF (MSTJ(11).LE.3) THEN
61610 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61611 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61612 ELSE
61613 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61614 ENDIF
61615 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61616 ENDIF
61617
61618C=======================================================================
61619C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61620 ELSEIF (ITUNE.EQ.306) THEN
61621 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61622 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61623 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61624 & ' with tune.')
61625 ENDIF
61626
61627C...PDFs
61628 MSTP(52)=2
61629 MSTP(54)=2
61630 MSTP(51)=10042
61631 MSTP(53)=10042
61632C...ISR
61633C PARP(64)=1D0
61634C...UE on, new model.
61635 MSTP(81)=21
61636C...Energy scaling
61637 PARP(89)=1800D0
61638 PARP(90)=0.22D0
61639C...Switch off trial joinings
61640 MSTP(96)=0
61641C...Primordial kT cutoff
61642
61643 IF (M13.GE.1) THEN
61644 CH60='see presentations by A. Moraes (ATLAS),'
61645 WRITE(M11,5030) CH60
61646 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61647 WRITE(M11,5030) CH60
61648 WRITE(M11,5030) ' '
61649 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61650 & 'externally linked'
61651 WRITE(M11,5035) CH70
61652 ENDIF
61653C...Smooth ISR, low FSR
61654 MSTP(70)=2
61655 MSTP(72)=0
61656C...pT0
61657 PARP(82)=1.9D0
61658C...Transverse density profile.
61659 MSTP(82)=4
61660 PARP(83)=0.3D0
61661 PARP(84)=0.5D0
61662C...ISR & FSR in interactions after the first (default)
61663 MSTP(84)=1
61664 MSTP(85)=1
61665C...No double-counting (default)
61666 MSTP(86)=2
61667C...Companion quark parent gluon (1-x) power
61668 MSTP(87)=4
61669C...Primordial kT compensation along chaings (default = 0 : uniform)
61670 MSTP(90)=1
61671C...Colour Reconnections
61672 MSTP(95)=1
61673 PARP(78)=0.2D0
61674C...Lambda_FSR scale.
61675 PARJ(81)=0.23D0
61676C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61677 MSTP(89)=1
61678 MSTP(88)=0
61679C PARP(79)=2D0
61680 PARP(80)=0.01D0
61681C...Peterson charm frag, and c and b hadr parameters
61682 MSTJ(11)=3
61683 PARJ(54)=-0.07
61684 PARJ(55)=-0.006
61685C... Output
61686 IF (M13.GE.1) THEN
61687 WRITE(M11,5030) ' '
61688 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61689 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61690 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61691 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61692 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61693 WRITE(M11,5030) CH60
61694 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61695 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61696 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61697 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61698 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61699 WRITE(M11,5030) CH60
61700 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61701 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61702 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61703 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61704 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61705 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61706 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61707 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61708 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61709 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61710 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61711 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61712 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61713 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61714 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61715 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61716 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61717 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61718 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61719 IF (MSTJ(11).LE.3) THEN
61720 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61721 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61722 ELSE
61723 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61724 ENDIF
61725 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61726 ENDIF
61727
61728C=======================================================================
61729C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61730C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61731C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61732 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61733 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61734 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61735 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61736 WRITE(M11,5010) ITUNE, CHNAME
61737 CH60='see R.D. Field, in hep-ph/0610012'
61738 WRITE(M11,5030) CH60
61739 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61740 WRITE(M11,5030) CH60
61741 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61742 CH60='LEP parameters tuned by Professor'
61743 WRITE(M11,5030) CH60
61744 ENDIF
61745 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61746 WRITE(M11,5010) ITUNE, CHNAME
61747 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61748 WRITE(M11,5030) CH60
61749 CH60='LEP/Tevatron parameters tuned by Professor'
61750 WRITE(M11,5030) CH60
61751 ENDIF
61752
61753C...Make sure we start from old default fragmentation parameters
61754 PARJ(81) = 0.29
61755 PARJ(82) = 1.0
61756
61757C...Use Professor's LEP pars if ITUNE >= 110
61758C...(i.e., for A-Pro, DW-Pro etc)
61759 IF (ITUNE.LT.110) THEN
61760C...# Old defaults
61761 MSTJ(11) = 4
61762C...# Old default flavour parameters
61763 PARJ(21) = 0.36
61764 PARJ(41) = 0.30
61765 PARJ(42) = 0.58
61766 PARJ(46) = 1.0
61767 PARJ(82) = 1.0
61768 ELSE
61769C...# Tuned flavour parameters:
61770 PARJ(1) = 0.073
61771 PARJ(2) = 0.2
61772 PARJ(3) = 0.94
61773 PARJ(4) = 0.032
61774 PARJ(11) = 0.31
61775 PARJ(12) = 0.4
61776 PARJ(13) = 0.54
61777 PARJ(25) = 0.63
61778 PARJ(26) = 0.12
61779C...# Switch on Bowler:
61780 MSTJ(11) = 5
61781C...# Fragmentation
61782 PARJ(21) = 0.325
61783 PARJ(41) = 0.5
61784 PARJ(42) = 0.6
61785 PARJ(47) = 0.67
61786 PARJ(81) = 0.29
61787 PARJ(82) = 1.65
61788 ENDIF
61789
61790C...Remove middle digit now for Professor variants, since identical pars
61791 ITUNEB=ITUNE
61792 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61793 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61794 ENDIF
61795
61796C...Multiple interactions on, old framework
61797 MSTP(81)=1
61798C...Fast IR cutoff energy scaling by default
61799 PARP(89)=1800D0
61800 PARP(90)=0.25D0
61801C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61802 MSTP(51)=7
61803 MSTP(52)=1
61804 IF (ITUNEB.EQ.105) THEN
61805 MSTP(51)=10150
61806 MSTP(52)=2
61807 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61808 MSTP(52)=2
61809 MSTP(54)=2
61810 MSTP(51)=10042
61811 MSTP(53)=10042
61812 ENDIF
61813C...Double Gaussian matter distribution.
61814 MSTP(82)=4
61815 PARP(83)=0.5D0
61816 PARP(84)=0.4D0
61817C...FSR activity.
61818 PARP(71)=4D0
61819C...Fragmentation functions and c and b parameters
61820C...(only if not using Professor)
61821 IF (ITUNE.LE.109) THEN
61822 MSTJ(11)=4
61823 PARJ(54)=-0.05
61824 PARJ(55)=-0.005
61825 ENDIF
61826
61827C...Tune A and AW
61828 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61829C...pT0.
61830 PARP(82)=2.0D0
61831c...String drawing almost completely minimizes string length.
61832 PARP(85)=0.9D0
61833 PARP(86)=0.95D0
61834C...ISR cutoff, muR scale factor, and phase space size
61835 PARP(62)=1D0
61836 PARP(64)=1D0
61837 PARP(67)=4D0
61838C...Intrinsic kT, size, and max
61839 MSTP(91)=1
61840 PARP(91)=1D0
61841 PARP(93)=5D0
61842C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61843 IF (ITUNEB.EQ.101) THEN
61844 PARP(62)=1.25D0
61845 PARP(64)=0.2D0
61846 PARP(91)=2.1D0
61847 PARP(92)=15.0D0
61848 ENDIF
61849
61850C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61851 ELSEIF (ITUNEB.EQ.102) THEN
61852C...pT0.
61853 PARP(82)=1.9D0
61854c...String drawing completely minimizes string length.
61855 PARP(85)=1.0D0
61856 PARP(86)=1.0D0
61857C...ISR cutoff, muR scale factor, and phase space size
61858 PARP(62)=1.25D0
61859 PARP(64)=0.2D0
61860 PARP(67)=1D0
61861C...Intrinsic kT, size, and max
61862 MSTP(91)=1
61863 PARP(91)=2.1D0
61864 PARP(93)=15D0
61865
61866C...Tune DW
61867 ELSEIF (ITUNEB.EQ.103) THEN
61868C...pT0.
61869 PARP(82)=1.9D0
61870c...String drawing completely minimizes string length.
61871 PARP(85)=1.0D0
61872 PARP(86)=1.0D0
61873C...ISR cutoff, muR scale factor, and phase space size
61874 PARP(62)=1.25D0
61875 PARP(64)=0.2D0
61876 PARP(67)=2.5D0
61877C...Intrinsic kT, size, and max
61878 MSTP(91)=1
61879 PARP(91)=2.1D0
61880 PARP(93)=15D0
61881
61882C...Tune DWT
61883 ELSEIF (ITUNEB.EQ.104) THEN
61884C...pT0.
61885 PARP(82)=1.9409D0
61886C...Run II ref scale and slow scaling
61887 PARP(89)=1960D0
61888 PARP(90)=0.16D0
61889c...String drawing completely minimizes string length.
61890 PARP(85)=1.0D0
61891 PARP(86)=1.0D0
61892C...ISR cutoff, muR scale factor, and phase space size
61893 PARP(62)=1.25D0
61894 PARP(64)=0.2D0
61895 PARP(67)=2.5D0
61896C...Intrinsic kT, size, and max
61897 MSTP(91)=1
61898 PARP(91)=2.1D0
61899 PARP(93)=15D0
61900
61901C...Tune QW
61902 ELSEIF(ITUNEB.EQ.105) THEN
61903 IF (M13.GE.1) THEN
61904 WRITE(M11,5030) ' '
61905 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61906 & 'externally linked'
61907 WRITE(M11,5035) CH70
61908 ENDIF
61909C...pT0.
61910 PARP(82)=1.1D0
61911c...String drawing completely minimizes string length.
61912 PARP(85)=1.0D0
61913 PARP(86)=1.0D0
61914C...ISR cutoff, muR scale factor, and phase space size
61915 PARP(62)=1.25D0
61916 PARP(64)=0.2D0
61917 PARP(67)=2.5D0
61918C...Intrinsic kT, size, and max
61919 MSTP(91)=1
61920 PARP(91)=2.1D0
61921 PARP(93)=15D0
61922
61923C...Tune D6 and D6T
61924 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61925 IF (M13.GE.1) THEN
61926 WRITE(M11,5030) ' '
61927 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61928 & 'externally linked'
61929 WRITE(M11,5035) CH70
61930 ENDIF
61931C...The "Rick" proton, double gauss with 0.5/0.4
61932 MSTP(82)=4
61933 PARP(83)=0.5D0
61934 PARP(84)=0.4D0
61935c...String drawing completely minimizes string length.
61936 PARP(85)=1.0D0
61937 PARP(86)=1.0D0
61938 IF (ITUNEB.EQ.108) THEN
61939C...D6: pT0, Run I ref scale, and fast energy scaling
61940 PARP(82)=1.8D0
61941 PARP(89)=1800D0
61942 PARP(90)=0.25D0
61943 ELSE
61944C...D6T: pT0, Run II ref scale, and slow energy scaling
61945 PARP(82)=1.8387D0
61946 PARP(89)=1960D0
61947 PARP(90)=0.16D0
61948 ENDIF
61949C...ISR cutoff, muR scale factor, and phase space size
61950 PARP(62)=1.25D0
61951 PARP(64)=0.2D0
61952 PARP(67)=2.5D0
61953C...Intrinsic kT, size, and max
61954 MSTP(91)=1
61955 PARP(91)=2.1D0
61956 PARP(93)=15D0
61957
61958C...Old ATLAS-DC2 5-parameter tune
61959 ELSEIF(ITUNEB.EQ.106) THEN
61960 IF (M13.GE.1) THEN
61961 WRITE(M11,5010) ITUNE, CHNAME
61962 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61963 WRITE(M11,5030) CH60
61964 CH60=' R. Field in hep-ph/0610012,'
61965 WRITE(M11,5030) CH60
61966 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61967 WRITE(M11,5030) CH60
61968 ENDIF
61969C... pT0.
61970 PARP(82)=1.8D0
61971C... Different ref and rescaling pacee
61972 PARP(89)=1000D0
61973 PARP(90)=0.16D0
61974C... Parameters of mass distribution
61975 PARP(83)=0.5D0
61976 PARP(84)=0.5D0
61977C... Old default string drawing
61978 PARP(85)=0.33D0
61979 PARP(86)=0.66D0
61980C... ISR, phase space equivalent to Tune B
61981 PARP(62)=1D0
61982 PARP(64)=1D0
61983 PARP(67)=1D0
61984C... FSR
61985 PARP(71)=4D0
61986C... Intrinsic kT
61987 MSTP(91)=1
61988 PARP(91)=1D0
61989 PARP(93)=5D0
61990
61991C...Professor's Pro-Q20 Tune
61992 ELSEIF(ITUNE.EQ.129) THEN
61993 IF (M13.GE.1) THEN
61994 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
61995 WRITE(M11,5030) CH60
61996 ENDIF
61997 PARP(62)=2.9
61998 PARP(64)=0.14
61999 PARP(67)=2.65
62000 PARP(82)=1.9
62001 PARP(83)=0.83
62002 PARP(84)=0.6
62003 PARP(85)=0.86
62004 PARP(86)=0.93
62005 PARP(89)=1800D0
62006 PARP(90)=0.22
62007 MSTP(91)=1
62008 PARP(91)=2.1
62009 PARP(93)=5.0
62010
62011 ENDIF
62012
62013C... Output
62014 IF (M13.GE.1) THEN
62015 WRITE(M11,5030) ' '
62016 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62017 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62018 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62019 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62020 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62021 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62022 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62023 WRITE(M11,5030) CH60
62024 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62025 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62026 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62027 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62028 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62029 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62030 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62031 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62032 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62033 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62034 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62035 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62036 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62037 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62038 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62039 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62040 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62041 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62042 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62043 IF (MSTJ(11).LE.3) THEN
62044 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62045 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62046 ELSE
62047 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62048 ENDIF
62049 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62050 ENDIF
62051
62052C=======================================================================
62053C... ACR, tune A with new CR (107)
62054 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62055 IF (M13.GE.1) THEN
62056 WRITE(M11,5010) ITUNE, CHNAME
62057 CH60='Tune A modified with new colour reconnections'
62058 WRITE(M11,5030) CH60
62059 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62060 WRITE(M11,5030) CH60
62061 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62062 WRITE(M11,5030) CH60
62063 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62064 WRITE(M11,5030) CH60
62065 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62066 WRITE(M11,5030) CH60
62067 IF (ITUNE.EQ.117) THEN
62068 CH60='LEP parameters tuned by Professor'
62069 WRITE(M11,5030) CH60
62070 ENDIF
62071 ENDIF
62072 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62073 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62074 & ' with tune. Using defaults.')
62075 GOTO 100
62076 ENDIF
62077
62078C...Make sure we start from old default fragmentation parameters
62079 PARJ(81) = 0.29
62080 PARJ(82) = 1.0
62081
62082C...Use Professor's LEP pars if ITUNE >= 110
62083C...(i.e., for A-Pro, DW-Pro etc)
62084 IF (ITUNE.LT.110) THEN
62085C...# Old defaults
62086 MSTJ(11) = 4
62087C...# Old default flavour parameters
62088 PARJ(21) = 0.36
62089 PARJ(41) = 0.30
62090 PARJ(42) = 0.58
62091 PARJ(46) = 1.0
62092 PARJ(82) = 1.0
62093 ELSE
62094C...# Tuned flavour parameters:
62095 PARJ(1) = 0.073
62096 PARJ(2) = 0.2
62097 PARJ(3) = 0.94
62098 PARJ(4) = 0.032
62099 PARJ(11) = 0.31
62100 PARJ(12) = 0.4
62101 PARJ(13) = 0.54
62102 PARJ(25) = 0.63
62103 PARJ(26) = 0.12
62104C...# Switch on Bowler:
62105 MSTJ(11) = 5
62106C...# Fragmentation
62107 PARJ(21) = 0.325
62108 PARJ(41) = 0.5
62109 PARJ(42) = 0.6
62110 PARJ(47) = 0.67
62111 PARJ(81) = 0.29
62112 PARJ(82) = 1.65
62113 ENDIF
62114
62115 MSTP(81)=1
62116 PARP(89)=1800D0
62117 PARP(90)=0.25D0
62118 MSTP(82)=4
62119 PARP(83)=0.5D0
62120 PARP(84)=0.4D0
62121 MSTP(51)=7
62122 MSTP(52)=1
62123 PARP(71)=4D0
62124 PARP(82)=2.0D0
62125 PARP(85)=0.0D0
62126 PARP(86)=0.66D0
62127 PARP(62)=1D0
62128 PARP(64)=1D0
62129 PARP(67)=4D0
62130 MSTP(91)=1
62131 PARP(91)=1D0
62132 PARP(93)=5D0
62133 MSTP(95)=6
62134C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62135 PARP(78)=0.09D0
62136C...Frag functions (only if not using Professor)
62137 IF (ITUNE.LE.109) THEN
62138 MSTJ(11)=4
62139 PARJ(54)=-0.05
62140 PARJ(55)=-0.005
62141 ENDIF
62142
62143C...Output
62144 IF (M13.GE.1) THEN
62145 WRITE(M11,5030) ' '
62146 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62147 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62148 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62149 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62150 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62151 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62152 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62153 WRITE(M11,5030) CH60
62154 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62155 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62156 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62157 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62158 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62159 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62160 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62161 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62162 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62163 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62164 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62165 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62166 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62167 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62168 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62169 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62170 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62171 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62172 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62173 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62174 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62175 IF (MSTJ(11).LE.3) THEN
62176 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62177 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62178 ELSE
62179 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62180 ENDIF
62181 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62182 ENDIF
62183
62184C=======================================================================
62185C...Intermediate model. Rap tune
62186C...(retuned to post-6.406 IR factorization)
62187 ELSEIF(ITUNE.EQ.200) THEN
62188 IF (M13.GE.1) THEN
62189 WRITE(M11,5010) ITUNE, CHNAME
62190 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62191 WRITE(M11,5030) CH60
62192 ENDIF
62193 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62194 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62195 & ' with tune.')
62196 ENDIF
62197C...PDF
62198 MSTP(51)=7
62199 MSTP(52)=1
62200C...ISR
62201 PARP(62)=1D0
62202 PARP(64)=1D0
62203 PARP(67)=4D0
62204C...FSR
62205 PARP(71)=4D0
62206 PARJ(81)=0.29D0
62207C...UE
62208 MSTP(81)=11
62209 PARP(82)=2.25D0
62210 PARP(89)=1800D0
62211 PARP(90)=0.25D0
62212C... ExpOfPow(1.8) overlap profile
62213 MSTP(82)=5
62214 PARP(83)=1.8D0
62215C... Valence qq
62216 MSTP(88)=0
62217C... Rap Tune
62218 MSTP(89)=1
62219C... Default diquark, BR-g-BR supp
62220 PARP(79)=2D0
62221 PARP(80)=0.01D0
62222C... Final state reconnect.
62223 MSTP(95)=1
62224 PARP(78)=0.55D0
62225C...Fragmentation functions and c and b parameters
62226 MSTJ(11)=4
62227 PARJ(54)=-0.05
62228 PARJ(55)=-0.005
62229C... Output
62230 IF (M13.GE.1) THEN
62231 WRITE(M11,5030) ' '
62232 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62233 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62234 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62235 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62236 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62237 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62238 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62239 WRITE(M11,5030) CH60
62240 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62241 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62242 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62243 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62244 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62245 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62246 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62247 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62248 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62249 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62250 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62251 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62252 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62253 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62254 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62255 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62256 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62257 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62258 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62259 IF (MSTJ(11).LE.3) THEN
62260 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62261 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62262 ELSE
62263 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62264 ENDIF
62265 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62266 ENDIF
62267
62268C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62269C...Old model for ISR and UE, new pT-ordered model for FSR
62270 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62271 & .ITUNE.EQ.226) THEN
62272 IF (M13.GE.1) THEN
62273 WRITE(M11,5010) ITUNE, CHNAME
62274 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62275 WRITE(M11,5030) CH60
62276 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62277 WRITE(M11,5030) CH60
62278 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62279 WRITE(M11,5030) CH60
62280 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62281 WRITE(M11,5030) CH60
62282 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62283 CH60='LEP parameters tuned by Professor'
62284 WRITE(M11,5030) CH60
62285 ENDIF
62286 ENDIF
62287 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62288 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62289 & ' with tune.')
62290 ENDIF
62291C...First set as if Pythia tune A
62292C...Multiple interactions on, old framework
62293 MSTP(81)=1
62294C...Fast IR cutoff energy scaling by default
62295 PARP(89)=1800D0
62296 PARP(90)=0.25D0
62297C...Default CTEQ5L (internal)
62298 MSTP(51)=7
62299 MSTP(52)=1
62300C...Double Gaussian matter distribution.
62301 MSTP(82)=4
62302 PARP(83)=0.5D0
62303 PARP(84)=0.4D0
62304C...FSR activity.
62305 PARP(71)=4D0
62306c...String drawing almost completely minimizes string length.
62307 PARP(85)=0.9D0
62308 PARP(86)=0.95D0
62309C...ISR cutoff, muR scale factor, and phase space size
62310 PARP(62)=1D0
62311 PARP(64)=1D0
62312 PARP(67)=4D0
62313C...Intrinsic kT, size, and max
62314 MSTP(91)=1
62315 PARP(91)=1D0
62316 PARP(93)=5D0
62317C...Use 2 GeV of primordial kT for "Perugia" version
62318 IF (ITUNE.EQ.221) THEN
62319 PARP(91)=2D0
62320 PARP(93)=10D0
62321 ENDIF
62322C...Use pT-ordered FSR
62323 MSTJ(41)=12
62324C...Lambda_FSR scale for pT-ordering
62325 PARJ(81)=0.23D0
62326C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62327 PARP(82)=2.05D0
62328C...Fragmentation functions and c and b parameters
62329C...(overwritten for 211, i.e., if using Professor pars)
62330 PARJ(54)=-0.05
62331 PARJ(55)=-0.005
62332
62333C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62334 IF (ITUNE.LT.210) THEN
62335C...# Old defaults
62336 MSTJ(11) = 4
62337C...# Old default flavour parameters
62338 PARJ(21) = 0.36
62339 PARJ(41) = 0.30
62340 PARJ(42) = 0.58
62341 PARJ(46) = 1.0
62342 PARJ(82) = 1.0
62343 ELSE
62344C...# Tuned flavour parameters:
62345 PARJ(1) = 0.073
62346 PARJ(2) = 0.2
62347 PARJ(3) = 0.94
62348 PARJ(4) = 0.032
62349 PARJ(11) = 0.31
62350 PARJ(12) = 0.4
62351 PARJ(13) = 0.54
62352 PARJ(25) = 0.63
62353 PARJ(26) = 0.12
62354C...# Always use pT-ordered shower:
62355 MSTJ(41) = 12
62356C...# Switch on Bowler:
62357 MSTJ(11) = 5
62358C...# Fragmentation
62359 PARJ(21) = 3.1327e-01
62360 PARJ(41) = 4.8989e-01
62361 PARJ(42) = 1.2018e+00
62362 PARJ(47) = 1.0000e+00
62363 PARJ(81) = 2.5696e-01
62364 PARJ(82) = 8.0000e-01
62365 ENDIF
62366
62367C...221, 226 : Perugia-APT and Perugia-APT6
62368 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62369
62370 PARP(64)=0.5D0
62371 PARP(82)=2.05D0
62372 PARP(90)=0.26D0
62373 PARP(91)=2.0D0
62374C...The Perugia variants use Steve's showers off the old MPI
62375 MSTP(152)=1
62376C...And use a lower PARP(71) as suggested by Professor tunings
62377C...(although not certain that applies to Q2-pT2 hybrid)
62378 PARP(71)=2.5D0
62379
62380C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62381 IF (ITUNE.EQ.226) THEN
62382 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62383 & 'externally linked'
62384 WRITE(M11,5035) CH70
62385 MSTP(52)=2
62386 MSTP(51)=10042
62387 PARP(82)=1.95D0
62388 ENDIF
62389
62390 ENDIF
62391
62392C... Output
62393 IF (M13.GE.1) THEN
62394 WRITE(M11,5030) ' '
62395 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62396 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62397 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62398 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62399 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62400 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62401 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62402 WRITE(M11,5030) CH60
62403 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62404 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62405 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62406 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62407 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62408 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62409 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62410 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62411 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62412 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62413 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62414 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62415 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62416 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62417 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62418 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62419 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62420 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62421 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62422 IF (MSTJ(11).LE.3) THEN
62423 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62424 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62425 ELSE
62426 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62427 ENDIF
62428 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62429 ENDIF
62430
62431C======================================================================
62432C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62433 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62434 IF (M13.GE.1) THEN
62435 WRITE(M11,5010) ITUNE, CHNAME
62436 CH60='see J. Rathsman, PLB452(1999)364'
62437 WRITE(M11,5030) CH60
62438C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62439C ? WRITE(M11,5030)
62440 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62441 WRITE(M11,5030) CH60
62442 WRITE(M11,5030) ' '
62443 CH70='NB! The GAL model must be run with modified '//
62444 & 'Pythia v6.215:'
62445 WRITE(M11,5035) CH70
62446 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62447 WRITE(M11,5035) CH70
62448 WRITE(M11,5030) ' '
62449 ENDIF
62450C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62451 MSWI(2) = 3
62452 PARSCI(2) = 0.10
62453 MSWI(1) = 2
62454 PARSCI(1) = 0.44
62455 MSTJ(16) = 0
62456 PARJ(42) = 0.45
62457 PARJ(82) = 2.0
62458 PARP(62) = 2.0
62459 MSTP(81) = 1
62460 MSTP(82) = 1
62461 PARP(81) = 1.9
62462 MSTP(92) = 1
62463 IF(CHNAME.EQ.'GAL Tune 1') THEN
62464C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62465 MSTP(82)=4
62466 PARP(83)=0.25D0
62467 PARP(84)=0.5D0
62468 PARP(82) = 1.75
62469 IF (M13.GE.1) THEN
62470 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62471 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62472 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62473 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62474 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62475 ENDIF
62476 ELSE
62477 IF (M13.GE.1) THEN
62478 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62479 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62480 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62481 ENDIF
62482 ENDIF
62483C...Output
62484 IF (M13.GE.1) THEN
62485 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62486 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62487 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62488 CH40='FSI SCI/GAL selection'
62489 WRITE(M11,6040) 1, MSWI(1), CH40
62490 CH40='FSI SCI/GAL sea quark treatment'
62491 WRITE(M11,6040) 2, MSWI(2), CH40
62492 CH40='FSI SCI/GAL sea quark treatment parm'
62493 WRITE(M11,6050) 1, PARSCI(1), CH40
62494 CH40='FSI SCI/GAL string reco probability R_0'
62495 WRITE(M11,6050) 2, PARSCI(2), CH40
62496 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62497 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62498 ENDIF
62499 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62500 IF (M13.GE.1) THEN
62501 WRITE(M11,5010) ITUNE, CHNAME
62502 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62503 WRITE(M11,5030) CH60
62504 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62505 WRITE(M11,5030) CH60
62506 WRITE(M11,5030) ' '
62507 CH70='NB! The SCI model must be run with modified '//
62508 & 'Pythia v6.215:'
62509 WRITE(M11,5035) CH70
62510 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62511 WRITE(M11,5035) CH70
62512 WRITE(M11,5030) ' '
62513 ENDIF
62514C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62515 MSTP(81)=1
62516 MSTP(82)=1
62517 PARP(81)=2.2
62518 MSTP(92)=1
62519 MSWI(2)=2
62520 PARSCI(2)=0.50
62521 MSWI(1)=2
62522 PARSCI(1)=0.44
62523 MSTJ(16)=0
62524 IF (CHNAME.EQ.'SCI Tune 1') THEN
62525C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62526 MSTP(81) = 1
62527 MSTP(82) = 3
62528 PARP(82) = 2.4
62529 PARP(83) = 0.5D0
62530 PARP(62) = 1.5
62531 PARP(84)=0.25D0
62532 IF (M13.GE.1) THEN
62533 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62534 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62535 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62536 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62537 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62538 ENDIF
62539 ELSE
62540 IF (M13.GE.1) THEN
62541 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62542 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62543 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62544 ENDIF
62545 ENDIF
62546C...Output
62547 IF (M13.GE.1) THEN
62548 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62549 CH40='FSI SCI/GAL selection'
62550 WRITE(M11,6040) 1, MSWI(1), CH40
62551 CH40='FSI SCI/GAL sea quark treatment'
62552 WRITE(M11,6040) 2, MSWI(2), CH40
62553 CH40='FSI SCI/GAL sea quark treatment parm'
62554 WRITE(M11,6050) 1, PARSCI(1), CH40
62555 CH40='FSI SCI/GAL string reco probability R_0'
62556 WRITE(M11,6050) 2, PARSCI(2), CH40
62557 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62558 ENDIF
62559
62560 ELSE
62561 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62562
62563 ENDIF
62564
62565 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62566
62567 9999 RETURN
62568
62569 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62570 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62571 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62572 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62573 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62574 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62575 5035 FORMAT(' *',3x,A70,3x,'*')
62576 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62577 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62578 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62579 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62580 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62581 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62582 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62583 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62584 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62585
62586 END
62587
62588C*********************************************************************
62589
62590C...PYEXEC
62591C...Administrates the fragmentation and decay chain.
62592
62593 SUBROUTINE PYEXEC
62594
62595C...Double precision and integer declarations.
62596 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62597 IMPLICIT INTEGER(I-N)
62598 INTEGER PYK,PYCHGE,PYCOMP
62599C...Commonblocks.
62600 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62601 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62602 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62603 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62604 COMMON/PYINT1/MINT(400),VINT(400)
62605 COMMON/PYINT4/MWID(500),WIDS(500,5)
62606 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62607C...Local array.
62608 DIMENSION PS(2,6),IJOIN(100)
62609
62610C...Initialize and reset.
62611 MSTU(24)=0
62612 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62613 MSTU(29)=0
62614 MSTU(31)=MSTU(31)+1
62615 MSTU(1)=0
62616 MSTU(2)=0
62617 MSTU(3)=0
62618 IF(MSTU(17).LE.0) MSTU(90)=0
62619 MCONS=1
62620
62621C...Sum up momentum, energy and charge for starting entries.
62622 NSAV=N
62623 DO 110 I=1,2
62624 DO 100 J=1,6
62625 PS(I,J)=0D0
62626 100 CONTINUE
62627 110 CONTINUE
62628 DO 130 I=1,N
62629 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62630 DO 120 J=1,4
62631 PS(1,J)=PS(1,J)+P(I,J)
62632 120 CONTINUE
62633 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62634 130 CONTINUE
62635 PARU(21)=PS(1,4)
62636
62637C...Start by all decays of coloured resonances involved in shower.
62638 NORIG=N
62639 DO 140 I=1,NORIG
62640 IF(K(I,1).EQ.3) THEN
62641 KC=PYCOMP(K(I,2))
62642 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62643 ENDIF
62644 140 CONTINUE
62645
62646C...Prepare system for subsequent fragmentation/decay.
62647 CALL PYPREP(0)
62648 IF(MINT(51).NE.0) RETURN
62649
62650C...Loop through jet fragmentation and particle decays.
62651 MBE=0
62652 150 MBE=MBE+1
62653 IP=0
62654 160 IP=IP+1
62655 KC=0
62656 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62657 IF(KC.EQ.0) THEN
62658
62659C...Deal with any remaining undecayed resonance
62660C...(normally the task of PYEVNT, so seldom used).
62661 ELSEIF(MWID(KC).NE.0) THEN
62662 IBEG=IP
62663 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62664 IBEG=IP+1
62665 170 IBEG=IBEG-1
62666 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62667 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62668 IEND=IP-1
62669 180 IEND=IEND+1
62670 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62671 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62672 NJOIN=0
62673 DO 190 I=IBEG,IEND
62674 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62675 NJOIN=NJOIN+1
62676 IJOIN(NJOIN)=I
62677 ENDIF
62678 190 CONTINUE
62679 ENDIF
62680 CALL PYRESD(IP)
62681 CALL PYPREP(IBEG)
62682 IF(MINT(51).NE.0) RETURN
62683
62684C...Particle decay if unstable and allowed. Save long-lived particle
62685C...decays until second pass after Bose-Einstein effects.
62686 ELSEIF(KCHG(KC,2).EQ.0) THEN
62687 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62688 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62689 & CALL PYDECY(IP)
62690
62691C...Decay products may develop a shower.
62692 IF(MSTJ(92).GT.0) THEN
62693 IP1=MSTJ(92)
62694 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62695 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62696 MINT(33)=0
62697 CALL PYSHOW(IP1,IP1+1,QMAX)
62698 CALL PYPREP(IP1)
62699 IF(MINT(51).NE.0) RETURN
62700 MSTJ(92)=0
62701 ELSEIF(MSTJ(92).LT.0) THEN
62702 IP1=-MSTJ(92)
62703 MINT(33)=0
62704 CALL PYSHOW(IP1,-3,P(IP,5))
62705 CALL PYPREP(IP1)
62706 IF(MINT(51).NE.0) RETURN
62707 MSTJ(92)=0
62708 ENDIF
62709
62710C...Jet fragmentation: string or independent fragmentation.
62711 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62712 MFRAG=MSTJ(1)
62713 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62714 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62715 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62716 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62717 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62718 ENDIF
62719 ENDIF
62720 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62721 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62722 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62723 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62724 ENDIF
62725
62726C...Loop back if enough space left in PYJETS and no error abort.
62727 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62728 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62729 GOTO 160
62730 ELSEIF(IP.LT.N) THEN
62731 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62732 ENDIF
62733
62734C...Include simple Bose-Einstein effect parametrization if desired.
62735 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62736 CALL PYBOEI(NSAV)
62737 GOTO 150
62738 ENDIF
62739
62740C...Check that momentum, energy and charge were conserved.
62741 DO 210 I=1,N
62742 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62743 DO 200 J=1,4
62744 PS(2,J)=PS(2,J)+P(I,J)
62745 200 CONTINUE
62746 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62747 210 CONTINUE
62748 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62749 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62750 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62751 &'(PYEXEC:) four-momentum was not conserved')
62752 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62753 &'(PYEXEC:) charge was not conserved')
62754
62755 RETURN
62756 END
62757
62758C*********************************************************************
62759
62760C...PYPREP
62761C...Rearranges partons along strings.
62762C...Special considerations for systems with junctions, with
62763C...possibility of junction-antijunction annihilation.
62764C...Allows small systems to collapse into one or two particles.
62765C...Checks flavours and colour singlet invariant masses.
62766
62767 SUBROUTINE PYPREP(IP)
62768
62769C...Double precision and integer declarations.
62770 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62771 INTEGER PYK,PYCHGE,PYCOMP
62772C...Commonblocks.
62773 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62774 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62775 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62776 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62777 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62778 COMMON/PYINT1/MINT(400),VINT(400)
62779C...The common block of colour tags.
62780 COMMON/PYCTAG/NCT,MCT(4000,2)
62781 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62782 &/PYPARS/
62783 DATA NERRPR/0/
62784 SAVE NERRPR
62785C...Local arrays.
62786 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62787 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62788 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62789 &IJCP(0:6),TJUOLD(5)
62790 CHARACTER CHTMP*6
62791
62792C...Function to give four-product.
62793 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)
62794
62795C...Rearrange parton shower product listing along strings: begin loop.
62796 MSTU(24)=0
62797 NOLD=N
62798 I1=N
62799 NJUNC=0
62800 NPIECE=0
62801 NJJSTR=0
62802 MSTU32=MSTU(32)+1
62803 DO 100 I=MAX(1,IP),N
62804C...First store junction positions.
62805 IF(K(I,1).EQ.42) THEN
62806 NJUNC=NJUNC+1
62807 IJUNC(NJUNC,0)=I
62808 IJUNC(NJUNC,4)=0
62809 ENDIF
62810 100 CONTINUE
62811
62812 DO 250 MQGST=1,3
62813 DO 240 I=MAX(1,IP),N
62814C...Special treatment for junctions
62815 IF (K(I,1).LE.0) GOTO 240
62816 IF(K(I,1).EQ.42) THEN
62817C...MQGST=2: Look for junction-junction strings (not detected in the
62818C...main search below).
62819 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62820 IF (NJJSTR.EQ.0) THEN
62821 NJJSTR = (3*NJUNC-NPIECE)/2
62822 ENDIF
62823C...Check how many already identified strings end on this junction
62824 ILC=0
62825 DO 110 J=1,NPIECE
62826 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62827 110 CONTINUE
62828C...If less than 3, remaining must be to another junction
62829 IF (ILC.LT.3) THEN
62830 IF (ILC.NE.2) THEN
62831C...Multiple j-j connections not handled yet.
62832 CALL PYERRM(2,
62833 & '(PYPREP:) Too many junction-junction strings.')
62834 MINT(51)=1
62835 RETURN
62836 ENDIF
62837C...The colour information in the junction is unreadable for the
62838C...colour space search further down in this routine, so we must
62839C...start on the colour mother of this junction and then "artificially"
62840C...prevent the colour mother from connecting here again.
62841 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62842 KCS=4
62843 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62844C...Switch colour if the junction-junction leg is presumably a
62845C...junction mother leg rather than a junction daughter leg.
62846 IF (ITJUNC.GE.3) KCS=9-KCS
62847 IF (MINT(33).EQ.0) THEN
62848C...Find the unconnected leg and reorder junction daughter pointers so
62849C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62850C...piece.
62851 IA=MOD(K(I,4),MSTU(5))
62852 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62853 ITMP=MOD(K(I,5),MSTU(5))
62854 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62855 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62856 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62857 ELSE
62858 K(I,5)=K(I,5)+(IA-ITMP)
62859 ENDIF
62860 K(I,4)=K(I,4)+(ITMP-IA)
62861 IA=ITMP
62862 ENDIF
62863 IF (ITJUNC.LE.2) THEN
62864C...Beam baryon junction
62865 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62866 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62867C...Else 1 -> 2 decay junction
62868 ELSE
62869 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62870 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62871 ENDIF
62872 I1BEG = I1
62873 NSTP = 0
62874 GOTO 170
62875C...Alternatively use colour tag information.
62876 ELSE
62877C...Find a final state parton with appropriate dangling colour tag.
62878 JCT=0
62879 IA=0
62880 IJUMO=K(I,3)
62881 DO 140 J1=MAX(1,IP),N
62882 IF (K(J1,1).NE.3) GOTO 140
62883C...Check for matching final-state colour tag
62884 IMATCH=0
62885 DO 120 J2=MAX(1,IP),N
62886 IF (K(J2,1).NE.3) GOTO 120
62887 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62888 120 CONTINUE
62889 IF (IMATCH.EQ.1) GOTO 140
62890C...Check whether this colour tag belongs to the present junction
62891C...by seeing whether any parton with this colour tag has the same
62892C...mother as the junction.
62893 JCT=MCT(J1,KCS-3)
62894 IMATCH=0
62895 DO 130 J2=MINT(84)+1,N
62896 IMO2=K(J2,3)
62897C...First scattering partons have IMO1 = 3 and 4.
62898 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62899 & IMO2=IMO2-2
62900 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62901 & IMATCH=1
62902 130 CONTINUE
62903 IF (IMATCH.EQ.0) GOTO 140
62904 IA=J1
62905 140 CONTINUE
62906C...Check for junction-junction strings without intermediate final state
62907C...glue (not detected above).
62908 IF (IA.EQ.0) THEN
62909 DO 160 MJU=1,NJUNC
62910 IJU2=IJUNC(MJU,0)
62911 IF (IJU2.EQ.I) GOTO 160
62912 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62913C...Only opposite types of junctions can connect to each other.
62914 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62915 IS=0
62916 DO 150 J=1,NPIECE
62917 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62918 150 CONTINUE
62919 IF (IS.EQ.3) GOTO 160
62920 IB=I
62921 IA=IJU2
62922 160 CONTINUE
62923 ENDIF
62924C...Switch to other side of adjacent parton and step from there.
62925 KCS=9-KCS
62926 I1BEG = I1
62927 NSTP = 0
62928 GOTO 170
62929 ENDIF
62930 ELSE IF (ILC.NE.3) THEN
62931 ENDIF
62932 ENDIF
62933 ENDIF
62934
62935C...Look for coloured string endpoint, or (later) leftover gluon.
62936 IF(K(I,1).NE.3) GOTO 240
62937 KC=PYCOMP(K(I,2))
62938 IF(KC.EQ.0) GOTO 240
62939 KQ=KCHG(KC,2)
62940 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62941
62942C...Pick up loose string end.
62943 KCS=4
62944 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62945 IA=I
62946 IB=I
62947 I1BEG=I1
62948 NSTP=0
62949 170 NSTP=NSTP+1
62950 IF(NSTP.GT.4*N) THEN
62951 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62952 MINT(51)=1
62953 RETURN
62954 ENDIF
62955
62956C...Copy undecayed parton. Finished if reached string endpoint.
62957 IF(K(IA,1).EQ.3) THEN
62958 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62959 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62960 MINT(51)=1
62961 MSTU(24)=1
62962 RETURN
62963 ENDIF
62964 I1=I1+1
62965 K(I1,1)=2
62966 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62967 K(I1,2)=K(IA,2)
62968 K(I1,3)=IA
62969 K(I1,4)=0
62970 K(I1,5)=0
62971 DO 180 J=1,5
62972 P(I1,J)=P(IA,J)
62973 V(I1,J)=V(IA,J)
62974 180 CONTINUE
62975 K(IA,1)=K(IA,1)+10
62976 IF(K(I1,1).EQ.1) GOTO 240
62977 ENDIF
62978
62979C...Also finished (for now) if reached junction; then copy to end.
62980 IF(K(IA,1).EQ.42) THEN
62981 NCOPY=I1-I1BEG
62982 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62983 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62984 MINT(51)=1
62985 MSTU(24)=1
62986 RETURN
62987 ENDIF
62988 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62989 DO 200 ICOPY=1,NCOPY
62990 DO 190 J=1,5
62991 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
62992 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
62993 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
62994 190 CONTINUE
62995 200 CONTINUE
62996 ENDIF
62997C...For junction-junction strings, find end leg and reorder junction
62998C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
62999C...junction-junction string piece.
63000 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63001 ITMP=MOD(K(IA,4),MSTU(5))
63002 IF (ITMP.NE.IB) THEN
63003 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63004 K(IA,5)=K(IA,5)+(ITMP-IB)
63005 ELSE
63006 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63007 ENDIF
63008 K(IA,4)=K(IA,4)+(IB-ITMP)
63009 ENDIF
63010 ENDIF
63011 NPIECE=NPIECE+1
63012C...IPIECE:
63013C...0: endpoint in original ER
63014C...1:
63015C...2:
63016C...3: Parton immediately next to junction
63017C...4: Junction
63018 IPIECE(NPIECE,0)=I
63019 IPIECE(NPIECE,1)=MSTU32+1
63020 IPIECE(NPIECE,2)=MSTU32+NCOPY
63021 IPIECE(NPIECE,3)=IB
63022 IPIECE(NPIECE,4)=IA
63023 MSTU32=MSTU32+NCOPY
63024 I1=I1BEG
63025 GOTO 240
63026 ENDIF
63027
63028C...GOTO next parton in colour space.
63029 IB=IA
63030 IF (MINT(33).EQ.0) THEN
63031 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63032 & )).NE.0) THEN
63033 IA=MOD(K(IB,KCS),MSTU(5))
63034 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63035 MREV=0
63036 ELSE
63037 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63038 & MSTU(5)).EQ.0) KCS=9-KCS
63039 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63040 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63041 MREV=1
63042 ENDIF
63043 IF(IA.LE.0.OR.IA.GT.N) THEN
63044 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63045 IF(NERRPR.LT.5) THEN
63046 NERRPR=NERRPR+1
63047 WRITE(MSTU(11),*) 'started at:', I
63048 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63049 WRITE(MSTU(11),*) 'MQGST =',MQGST
63050 CALL PYLIST(4)
63051 ENDIF
63052 MINT(51)=1
63053 RETURN
63054 ENDIF
63055 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63056 & ,MSTU(5)).EQ.IB) THEN
63057 IF(MREV.EQ.1) KCS=9-KCS
63058 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63059 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63060 ELSE
63061 IF(MREV.EQ.0) KCS=9-KCS
63062 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63063 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63064 ENDIF
63065 IF(IA.NE.I) GOTO 170
63066C...Use colour tag information
63067 ELSE
63068C...First create colour tags starting on IB if none already present.
63069 IF (MCT(IB,KCS-3).EQ.0) THEN
63070 CALL PYCTTR(IB,KCS,IB)
63071 IF(MINT(51).NE.0) RETURN
63072 ENDIF
63073 JCT=MCT(IB,KCS-3)
63074 IFOUND=0
63075C...Find final state tag partner
63076 DO 210 IT=MAX(1,IP),N
63077 IF (IT.EQ.IB) GOTO 210
63078 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63079 & .0) THEN
63080 IFOUND=IFOUND+1
63081 IA=IT
63082 ENDIF
63083 210 CONTINUE
63084C...Just copy and goto next if exactly one partner found.
63085 IF (IFOUND.EQ.1) THEN
63086 GOTO 170
63087C...When no match found, match is presumably junction.
63088 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63089C...Check whether this colour tag matches a junction
63090C...by seeing whether any parton with this colour tag has the same
63091C...mother as a junction.
63092C...NB: Only type 1 and 2 junctions handled presently.
63093 DO 230 IJU=1,NJUNC
63094 IJUMO=K(IJUNC(IJU,0),3)
63095 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63096C...Colours only connect to junctions, anti-colours to antijunctions:
63097 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63098 IMATCH=0
63099 DO 220 J1=MAX(1,IP),N
63100 IF (K(J1,1).LE.0) GOTO 220
63101C...First scattering partons have IMO1 = 3 and 4.
63102 IMO=K(J1,3)
63103 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63104 & IMO=IMO-2
63105 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63106 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63107 & IMATCH=1
63108C...Attempt at handling type > 3 junctions also. Not tested.
63109 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63110 & .IJUMO) IMATCH=1
63111 220 CONTINUE
63112 IF (IMATCH.EQ.0) GOTO 230
63113 IA=IJUNC(IJU,0)
63114 IFOUND=IFOUND+1
63115 230 CONTINUE
63116
63117 IF (IFOUND.EQ.1) THEN
63118 GOTO 170
63119 ELSEIF (IFOUND.EQ.0) THEN
63120 WRITE(CHTMP,*) JCT
63121 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63122 & //CHTMP)
63123 IF(NERRPR.LT.5) THEN
63124 NERRPR=NERRPR+1
63125 CALL PYLIST(4)
63126 ENDIF
63127 MINT(51)=1
63128 RETURN
63129 ENDIF
63130 ELSEIF (IFOUND.GE.2) THEN
63131 WRITE(CHTMP,*) JCT
63132 CALL PYERRM(12
63133 & ,'(PYPREP:) too many occurences of colour line: '//
63134 & CHTMP)
63135 IF(NERRPR.LT.5) THEN
63136 NERRPR=NERRPR+1
63137 CALL PYLIST(4)
63138 ENDIF
63139 MINT(51)=1
63140 RETURN
63141 ENDIF
63142 ENDIF
63143 K(I1,1)=1
63144 240 CONTINUE
63145 250 CONTINUE
63146
63147C...Junction systems remain.
63148 IJU=0
63149 IJUS=0
63150 IJUCNT=0
63151 MREV=0
63152 IJJSTR=0
63153 260 IJUCNT=IJUCNT+1
63154 IF (IJUCNT.LE.NJUNC) THEN
63155C...If we are not processing a j-j string, treat this junction as new.
63156 IF (IJJSTR.EQ.0) THEN
63157 IJU=IJUNC(IJUCNT,0)
63158 MREV=0
63159C...If junction has already been read, ignore it.
63160 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63161C...If we are on a j-j string, goto second j-j junction.
63162 ELSE
63163 IJUCNT=IJUCNT-1
63164 IJU=IJUS
63165 ENDIF
63166C...Mark selected junction read.
63167 DO 270 J=1,NJUNC
63168 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63169 270 CONTINUE
63170C...Determine junction type
63171 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63172C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63173C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63174C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63175 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63176 IHK=0
63177 280 IHK=IHK+1
63178C...Find which quarks belong to given junction.
63179 IHF=0
63180 DO 290 IPC=1,NPIECE
63181 IF (IPIECE(IPC,4).EQ.IJU) THEN
63182 IHF=IHF+1
63183 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63184 ENDIF
63185 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63186 290 CONTINUE
63187C...IHK = 3 is special. Either normal string piece, or j-j string.
63188 IF(IHK.EQ.3) THEN
63189 IF (MREV.NE.1) THEN
63190 DO 300 IPC=1,NPIECE
63191C...If there is a j-j string starting on the present junction which has
63192C...zero length, insert next junction immediately.
63193 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63194 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63195 IJJSTR = 1
63196 GOTO 340
63197 ENDIF
63198 300 CONTINUE
63199 MREV = 1
63200C...If MREV is 1 and IHK is 3 we are finished with this system.
63201 ELSE
63202 MREV=0
63203 GOTO 260
63204 ENDIF
63205 ENDIF
63206
63207C...If we've gotten this far, then either IHK < 3, or
63208C...an interjunction string exists, or just a third normal string.
63209 IJUNC(IJUCNT,IHK)=0
63210 IJJSTR = 0
63211C..Order pieces belonging to this junction. Also look for j-j.
63212 DO 310 IPC=1,NPIECE
63213 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63214 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63215 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63216 IJUNC(IJUCNT,IHK)=IPC
63217 IJJSTR = 1
63218 MREV = 0
63219 ENDIF
63220 310 CONTINUE
63221C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63222 IPC=IJUNC(IJUCNT,IHK)
63223C...Temporary solution to cover for bug.
63224 IF(IPC.LE.0) THEN
63225 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63226 MINT(51)=1
63227 RETURN
63228 ENDIF
63229 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63230 I1=I1+1
63231 DO 320 J=1,5
63232 K(I1,J)=K(MSTU(4)-ICP,J)
63233 P(I1,J)=P(MSTU(4)-ICP,J)
63234 V(I1,J)=V(MSTU(4)-ICP,J)
63235 320 CONTINUE
63236 330 CONTINUE
63237 K(I1,1)=2
63238C...Mark last quark.
63239 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63240C...Do not insert junctions at wrong places.
63241 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63242C...Insert junction.
63243 340 IJUS = IJU
63244 IF (IHK.EQ.3) THEN
63245C...Shift to end junction if a j-j string has been processed.
63246 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63247 MREV= 1
63248 ENDIF
63249 I1=I1+1
63250 DO 350 J=1,5
63251 K(I1,J)=0
63252 P(I1,J)=0.
63253 V(I1,J)=0.
63254 350 CONTINUE
63255 K(I1,1)=41
63256 K(IJUS,1)=K(IJUS,1)+10
63257 K(I1,2)=K(IJUS,2)
63258 K(I1,3)=IJUS
63259 360 IF (IHK.LT.3) GOTO 280
63260 ELSE
63261 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63262 MINT(51)=1
63263 RETURN
63264 ENDIF
63265 IF (IJUCNT.NE.NJUNC) GOTO 260
63266 ENDIF
63267 N=I1
63268
63269C...Rearrange three strings from junction, e.g. in case one has been
63270C...shortened by shower, so the last is the largest-energy one.
63271 IF(NJUNC.GE.1) THEN
63272C...Find systems with exactly one junction.
63273 MJUN1=0
63274 NBEG=NOLD+1
63275 DO 470 I=NOLD+1,N
63276 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63277 ELSEIF(K(I,1).EQ.41) THEN
63278 MJUN1=MJUN1+1
63279 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63280 MJUN1=0
63281 NBEG=I+1
63282 ELSE
63283 NEND=I
63284C...Sum up energy-momentum in each junction string.
63285 DO 370 J=1,5
63286 PJU(1,J)=0D0
63287 PJU(2,J)=0D0
63288 PJU(3,J)=0D0
63289 370 CONTINUE
63290 NJU=0
63291 DO 390 I1=NBEG,NEND
63292 IF(K(I1,2).NE.21) THEN
63293 NJU=NJU+1
63294 IJUR(NJU)=I1
63295 ENDIF
63296 DO 380 J=1,5
63297 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63298 380 CONTINUE
63299 390 CONTINUE
63300C...Find which of them has highest energy (minus mass) in rest frame.
63301 DO 400 J=1,5
63302 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63303 400 CONTINUE
63304 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63305 & PJU(4,3)**2))
63306 DO 410 I2=1,3
63307 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63308 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63309 410 CONTINUE
63310 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63311C...Decide how to rearrange so that new last has highest energy.
63312 IF(PJU(1,6).LT.PJU(2,6)) THEN
63313 IRNG(1,1)=IJUR(1)
63314 IRNG(1,2)=IJUR(2)-1
63315 IRNG(2,1)=IJUR(4)
63316 IRNG(2,2)=IJUR(3)+1
63317 IRNG(4,1)=IJUR(3)-1
63318 IRNG(4,2)=IJUR(2)
63319 ELSE
63320 IRNG(1,1)=IJUR(4)
63321 IRNG(1,2)=IJUR(3)+1
63322 IRNG(2,1)=IJUR(2)
63323 IRNG(2,2)=IJUR(3)-1
63324 IRNG(4,1)=IJUR(2)-1
63325 IRNG(4,2)=IJUR(1)
63326 ENDIF
63327 IRNG(3,1)=IJUR(3)
63328 IRNG(3,2)=IJUR(3)
63329C...Copy in correct order below bottom of current event record.
63330 I2=N
63331 DO 440 II=1,4
63332 DO 430 I1=IRNG(II,1),IRNG(II,2),
63333 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63334 I2=I2+1
63335 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63336 CALL PYERRM(11,
63337 & '(PYPREP:) no more memory left in PYJETS')
63338 MINT(51)=1
63339 MSTU(24)=1
63340 RETURN
63341 ENDIF
63342 DO 420 J=1,5
63343 K(I2,J)=K(I1,J)
63344 P(I2,J)=P(I1,J)
63345 V(I2,J)=V(I1,J)
63346 420 CONTINUE
63347 IF(K(I2,1).EQ.1) K(I2,1)=2
63348 430 CONTINUE
63349 440 CONTINUE
63350 K(I2,1)=1
63351C...Copy back up, overwriting but now in correct order.
63352 DO 460 I1=NBEG,NEND
63353 I2=I1-NBEG+N+1
63354 DO 450 J=1,5
63355 K(I1,J)=K(I2,J)
63356 P(I1,J)=P(I2,J)
63357 V(I1,J)=V(I2,J)
63358 450 CONTINUE
63359 460 CONTINUE
63360 ENDIF
63361 MJUN1=0
63362 NBEG=I+1
63363 ENDIF
63364 470 CONTINUE
63365
63366C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63367C...to two q-qbar systems.
63368C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63369 IF (MSTJ(19).NE.1) THEN
63370 MJUN1 = 0
63371 JJGLUE = 0
63372 NBEG = NOLD+1
63373C...Force collapse when MSTJ(19)=2.
63374 IF (MSTJ(19).EQ.2) THEN
63375 DELMJJ = 1D9
63376 DELMQQ = 0D0
63377 ENDIF
63378C...Find systems with exactly two junctions.
63379 DO 700 I=NOLD+1,N
63380C...Count junctions
63381 IF (K(I,1).EQ.41) THEN
63382 MJUN1 = MJUN1+1
63383C...Check for interjunction gluons
63384 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63385 JJGLUE = 1
63386 ENDIF
63387 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63388C...If end of system reached with either zero or one junction, restart
63389C...with next system.
63390 MJUN1 = 0
63391 JJGLUE = 0
63392 NBEG = I+1
63393 ELSEIF(K(I,1).EQ.1) THEN
63394C...If end of system reached with exactly two junctions, compute string
63395C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63396C...length measure for the (q-qbar)(q-qbar) topology.
63397 NEND=I
63398C...Loop down through chain.
63399 ISID=0
63400 DO 480 I1=NBEG,NEND
63401C...Store string piece division locations in event record
63402 IF (K(I1,2).NE.21) THEN
63403 ISID = ISID+1
63404 IJCP(ISID) = I1
63405 ENDIF
63406 480 CONTINUE
63407C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63408 ISW=0
63409 IF (PYR(0).LT.0.5D0) ISW=1
63410C...Randomly choose which qqbar string gets the jj gluons.
63411 IGS=1
63412 IF (PYR(0).GT.0.5D0) IGS=2
63413C...Only compute string lengths when no topology forced.
63414 IF (MSTJ(19).EQ.0) THEN
63415C...Repeat following for each junction
63416 DO 570 IJU=1,2
63417C...Initialize iterative procedure for finding JRF
63418 IJRFIT=0
63419 DO 490 IX=1,3
63420 TJUOLD(IX)=0D0
63421 490 CONTINUE
63422 TJUOLD(4)=1D0
63423C...Start iteration. Sum up momenta in string pieces
63424 500 DO 540 IJS=1,3
63425C...JD=-1 for first junction, +1 for second junction.
63426C...Find out where piece starts and ends and which direction to go.
63427 JD=2*IJU-3
63428 IF (IJS.LE.2) THEN
63429 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63430 IB = IJCP((IJU-1)*7 - JD*IJS)
63431 ELSEIF (IJS.EQ.3) THEN
63432 JD =-JD
63433 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63434 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63435 ENDIF
63436C...Initialize junction pull 4-vector.
63437 DO 510 J=1,5
63438 PUL(IJS,J)=0D0
63439 510 CONTINUE
63440C...Initialize weight
63441 PWT = 0D0
63442 PWTOLD = 0D0
63443C...Sum up (weighted) momenta along each string piece
63444 DO 530 ISP=IA,IB,JD
63445C...If present parton not last in chain
63446 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63447C...If last parton was a junction, store present weight
63448 IF (K(ISP-JD,2).EQ.88) THEN
63449 PWTOLD = PWT
63450C...If last parton was a quark, reset to stored weight.
63451 ELSEIF (K(ISP-JD,2).NE.21) THEN
63452 PWT = PWTOLD
63453 ENDIF
63454 ENDIF
63455C...Skip next parton if weight already large
63456 IF (PWT.GT.10D0) GOTO 530
63457C...Compute momentum in TJUOLD frame:
63458 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63459 & )*P(ISP,3)
63460 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63461 DO 520 J=1,3
63462 TMP=P(ISP,J)+TJUOLD(J)*BFC
63463 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63464 520 CONTINUE
63465C...Boosted energy
63466 TMP=TJUOLD(4)*P(ISP,4)+TDP
63467 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63468C...Update weight
63469 PWT=PWT+TMP/PARJ(48)
63470C...Put |p| rather than m in 5th slot
63471 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63472 & +PUL(IJS,3)**2)
63473 530 CONTINUE
63474 540 CONTINUE
63475C...Compute boost
63476 IJRFIT=IJRFIT+1
63477 CALL PYJURF(PUL,T)
63478C...Combine new boost (T) with old boost (TJUOLD)
63479 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63480 DO 550 IX=1,3
63481 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63482 & ))
63483 550 CONTINUE
63484 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63485 & **2)
63486C...If last boost small, accept JRF, else iterate.
63487C...Also prevent possibility of infinite loop.
63488 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63489 & IJRFIT.LT.MSTJ(18))THEN
63490 GOTO 500
63491 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63492 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63493 ENDIF
63494C...Store final boost, with change of sign since TJJ motion vector.
63495 DO 560 IX=1,3
63496 TJJ(IJU,IX)=-TJUOLD(IX)
63497 560 CONTINUE
63498 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63499 & +TJJ(IJU,3)**2)
63500 570 CONTINUE
63501C...String length measure for (q-qbar)(q-qbar) topology.
63502C...Note only momenta of nearest partons used (since rest of system
63503C...identical).
63504 IF (JJGLUE.EQ.0) THEN
63505 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63506 & -1,IJCP(5-ISW)+1)
63507 ELSE
63508C...Put jj gluons on selected string (IGS selected randomly above).
63509 IF (IGS.EQ.1) THEN
63510 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63511 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63512 ELSE
63513 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63514 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63515 & ,IJCP(5-ISW)+1)
63516 ENDIF
63517 ENDIF
63518C...String length measure for q-q-j-j-q-q topology.
63519 T1G1=0D0
63520 T2G2=0D0
63521 T1T2=0D0
63522 T1P1=0D0
63523 T1P2=0D0
63524 T2P3=0D0
63525 T2P4=0D0
63526 ISGN=-1
63527C...Note only momenta of nearest partons used (since rest of system
63528C...identical).
63529 DO 580 IX=1,4
63530 IF (IX.EQ.4) ISGN=1
63531 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63532 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63533 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63534 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63535 IF (JJGLUE.EQ.0) THEN
63536C...Junction motion vector dot product gives length when inter-junction
63537C...gluons absent.
63538 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63539 ELSE
63540C...Junction motion vector dot products with gluon momenta give length
63541C...when inter-junction gluons present.
63542 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63543 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63544 ENDIF
63545 580 CONTINUE
63546 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63547 IF (JJGLUE.EQ.0) THEN
63548 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63549 ELSE
63550 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63551 ENDIF
63552 ENDIF
63553C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63554C...(Always the case for MSTJ(19)=2 due to initialization above)
63555 IF (DELMJJ.GT.DELMQQ) THEN
63556C...Put new system at end of event record
63557 NCOP=N
63558 DO 650 IST=1,2
63559 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63560 NCOP=NCOP+1
63561 DO 590 IX=1,5
63562 P(NCOP,IX)=P(ICOP,IX)
63563 K(NCOP,IX)=K(ICOP,IX)
63564 590 CONTINUE
63565 600 CONTINUE
63566 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63567C...Insert inter-junction gluon string piece (reversed)
63568 NJJGL=0
63569 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63570 NJJGL=NJJGL+1
63571 NCOP=NCOP+1
63572 DO 610 IX=1,5
63573 P(NCOP,IX)=P(ICOP,IX)
63574 K(NCOP,IX)=K(ICOP,IX)
63575 610 CONTINUE
63576 620 CONTINUE
63577 ENDIF
63578 IFC=-2*IST+3
63579 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63580 NCOP=NCOP+1
63581 DO 630 IX=1,5
63582 P(NCOP,IX)=P(ICOP,IX)
63583 K(NCOP,IX)=K(ICOP,IX)
63584 630 CONTINUE
63585 640 CONTINUE
63586 K(NCOP,1)=1
63587 650 CONTINUE
63588C...Copy system back in right order
63589 DO 670 ICOP=NBEG,NEND-2
63590 DO 660 IX=1,5
63591 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63592 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63593 660 CONTINUE
63594 670 CONTINUE
63595C...Shift down rest of event record
63596 DO 690 ICOP=NEND+1,N
63597 DO 680 IX=1,5
63598 P(ICOP-2,IX)=P(ICOP,IX)
63599 K(ICOP-2,IX)=K(ICOP,IX)
63600 680 CONTINUE
63601 690 CONTINUE
63602C...Update length of event record.
63603 N=N-2
63604 ENDIF
63605 MJUN1=0
63606 NBEG=I+1
63607 ENDIF
63608 700 CONTINUE
63609 ENDIF
63610 ENDIF
63611
63612C...Done if no checks on small-mass systems.
63613 IF(MSTJ(14).LT.0) RETURN
63614 IF(MSTJ(14).EQ.0) GOTO 1140
63615
63616C...Find lowest-mass colour singlet jet system.
63617 NS=N
63618 710 NSIN=N-NS
63619 PDMIN=1D0+PARJ(32)
63620 IC=0
63621 DO 770 I=MAX(1,IP),N
63622 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63623 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63624 NSIN=NSIN+1
63625 IC=I
63626 DO 720 J=1,4
63627 DPS(J)=P(I,J)
63628 720 CONTINUE
63629 MSTJ(93)=1
63630 DPS(5)=PYMASS(K(I,2))
63631 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63632 DO 730 J=1,4
63633 DPS(J)=DPS(J)+P(I,J)
63634 730 CONTINUE
63635 MSTJ(93)=1
63636 DPS(5)=DPS(5)+PYMASS(K(I,2))
63637 ELSEIF(K(I,1).EQ.2) THEN
63638 DO 740 J=1,4
63639 DPS(J)=DPS(J)+P(I,J)
63640 740 CONTINUE
63641 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63642 DO 750 J=1,4
63643 DPS(J)=DPS(J)+P(I,J)
63644 750 CONTINUE
63645 MSTJ(93)=1
63646 DPS(5)=DPS(5)+PYMASS(K(I,2))
63647 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63648 & DPS(5)
63649 IF(PD.LT.PDMIN) THEN
63650 PDMIN=PD
63651 DO 760 J=1,5
63652 DPC(J)=DPS(J)
63653 760 CONTINUE
63654 IC1=IC
63655 IC2=I
63656 ENDIF
63657 IC=0
63658 ELSE
63659 NSIN=NSIN+1
63660 ENDIF
63661 770 CONTINUE
63662
63663C...Done if lowest-mass system above threshold for string frag.
63664 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63665
63666C...Fill small-mass system as cluster.
63667 NSAV=N
63668 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63669 K(N+1,1)=11
63670 K(N+1,2)=91
63671 K(N+1,3)=IC1
63672 P(N+1,1)=DPC(1)
63673 P(N+1,2)=DPC(2)
63674 P(N+1,3)=DPC(3)
63675 P(N+1,4)=DPC(4)
63676 P(N+1,5)=PECM
63677
63678C...Set up history, assuming cluster -> 2 hadrons.
63679 NBODY=2
63680 K(N+1,4)=N+2
63681 K(N+1,5)=N+3
63682 K(N+2,1)=1
63683 K(N+3,1)=1
63684 IF(MSTU(16).NE.2) THEN
63685 K(N+2,3)=N+1
63686 K(N+3,3)=N+1
63687 ELSE
63688 K(N+2,3)=IC1
63689 K(N+3,3)=IC2
63690 ENDIF
63691 K(N+2,4)=0
63692 K(N+3,4)=0
63693 K(N+2,5)=0
63694 K(N+3,5)=0
63695 V(N+1,5)=0D0
63696 V(N+2,5)=0D0
63697 V(N+3,5)=0D0
63698
63699C...Find total flavour content - complicated by presence of junctions.
63700 NQ=0
63701 NDIQ=0
63702 DO 780 I=IC1,IC2
63703 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63704 NQ=NQ+1
63705 KFQ(NQ)=K(I,2)
63706 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63707 ENDIF
63708 780 CONTINUE
63709
63710C...If several diquarks, split up one to give even number of flavours.
63711 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63712 I1=3
63713 IF(IABS(KFQ(3)).LT.1000) I1=1
63714 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63715 KFQ(I1)=KFQ(I1)/1000
63716 NQ=4
63717 NDIQ=NDIQ-1
63718 ENDIF
63719
63720C...If four quark ends, join two to diquark.
63721 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63722 I1=1
63723 I2=2
63724 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63725 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63726 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63727 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63728 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63729 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63730 KFQ(I2)=KFQ(4)
63731 NQ=3
63732 NDIQ=1
63733 ENDIF
63734
63735C...If two quark ends, plus quark or diquark, join quarks to diquark.
63736 IF(NQ.EQ.3) THEN
63737 I1=1
63738 I2=2
63739 IF(IABS(KFQ(I1)).GT.1000) I1=3
63740 IF(IABS(KFQ(I2)).GT.1000) I2=3
63741 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63742 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63743 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63744 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63745 KFQ(I2)=KFQ(3)
63746 NQ=2
63747 NDIQ=NDIQ+1
63748 ENDIF
63749
63750C...Form two particles from flavours of lowest-mass system, if feasible.
63751 NTRY = 0
63752 790 NTRY = NTRY + 1
63753
63754C...Open string with two specified endpoint flavours.
63755 IF(NQ.EQ.2) THEN
63756 KC1=PYCOMP(KFQ(1))
63757 KC2=PYCOMP(KFQ(2))
63758 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63759 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63760 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63761 IF(KQ1+KQ2.NE.0) GOTO 1140
63762C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63763 800 K1=KFQ(1)
63764 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63765 MSTU(125)=0
63766 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63767 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63768 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63769
63770C...Open string with four specified flavours.
63771 ELSEIF(NQ.EQ.4) THEN
63772 KC1=PYCOMP(KFQ(1))
63773 KC2=PYCOMP(KFQ(2))
63774 KC3=PYCOMP(KFQ(3))
63775 KC4=PYCOMP(KFQ(4))
63776 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63777 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63778 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63779 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63780 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63781 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63782C...Combine flavours pairwise to form two hadrons.
63783 810 I1=1
63784 I2=2
63785 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63786 & IABS(KFQ(2)).GT.1000)) I2=3
63787 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63788 & IABS(KFQ(3)).GT.1000))) I2=4
63789 I3=3
63790 IF(I2.EQ.3) I3=2
63791 I4=10-I1-I2-I3
63792 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63793 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63794 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63795
63796C...Closed string.
63797 ELSE
63798 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63799C...No room for popcorn mesons in closed string -> 2 hadrons.
63800 MSTU(125)=0
63801 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63802 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63803 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63804 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63805 ENDIF
63806 P(N+2,5)=PYMASS(K(N+2,2))
63807 P(N+3,5)=PYMASS(K(N+3,2))
63808
63809C...If it does not work: try again (a number of times), give up (if no
63810C...place to shuffle momentum or too many flavours), or form one hadron.
63811 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63812 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63813 GOTO 790
63814 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63815 GOTO 1140
63816 ELSE
63817 GOTO 890
63818 END IF
63819 END IF
63820
63821C...Perform two-particle decay of jet system.
63822C...First step: find reference axis in decaying system rest frame.
63823C...(Borrow slot N+2 for temporary direction.)
63824 DO 830 J=1,4
63825 P(N+2,J)=P(IC1,J)
63826 830 CONTINUE
63827 DO 850 I=IC1+1,IC2-1
63828 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63829 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63830 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63831 DO 840 J=1,4
63832 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63833 840 CONTINUE
63834 ENDIF
63835 850 CONTINUE
63836 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63837 &-DPC(3)/DPC(4))
63838 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63839 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63840
63841C...Second step: generate isotropic/anisotropic decay.
63842 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63843 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63844 860 UE(3)=PYR(0)
63845 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63846 PT2=(1D0-UE(3)**2)*PA**2
63847 IF(MSTJ(16).LE.0) THEN
63848 PREV=0.5D0
63849 ELSE
63850 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63851 PR1=P(N+2,5)**2+PT2
63852 PR2=P(N+3,5)**2+PT2
63853 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63854 PREVCF=PARJ(42)
63855 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63856 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63857 ENDIF
63858 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63859 PHI=PARU(2)*PYR(0)
63860 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63861 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63862 DO 870 J=1,3
63863 P(N+2,J)=PA*UE(J)
63864 P(N+3,J)=-PA*UE(J)
63865 870 CONTINUE
63866 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63867 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63868
63869C...Third step: move back to event frame and set production vertex.
63870 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63871 &DPC(3)/DPC(4))
63872 DO 880 J=1,4
63873 V(N+1,J)=V(IC1,J)
63874 V(N+2,J)=V(IC1,J)
63875 V(N+3,J)=V(IC2,J)
63876 880 CONTINUE
63877 N=N+3
63878 GOTO 1120
63879
63880C...Else form one particle, if possible.
63881 890 NBODY=1
63882 K(N+1,5)=N+2
63883 DO 900 J=1,4
63884 V(N+1,J)=V(IC1,J)
63885 V(N+2,J)=V(IC1,J)
63886 900 CONTINUE
63887
63888C...Select hadron flavour from available quark flavours.
63889 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63890 GOTO 1140
63891 ELSEIF(NQ.EQ.2) THEN
63892 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63893 ELSE
63894 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63895 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63896 ENDIF
63897 IF(K(N+2,2).EQ.0) GOTO 910
63898 P(N+2,5)=PYMASS(K(N+2,2))
63899
63900C...Use old algorithm for E/p conservation? (EN)
63901 IF (MSTJ(16).LE.0) GOTO 1080
63902
63903C...Find the string piece closest to the cluster by a loop
63904C...over the undecayed partons not in present cluster. (EN)
63905 DGLOMI=1D30
63906 IBEG=0
63907 I0=0
63908 NJUNC=0
63909 DO 940 I1=MAX(1,IP),N-1
63910 IF(K(I1,1).EQ.1) NJUNC=0
63911 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63912 IF(K(I1,1).EQ.41) GOTO 940
63913 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63914 I0=0
63915 ELSEIF(K(I1,1).EQ.2) THEN
63916 IF(I0.EQ.0) I0=I1
63917 I2=I1
63918 920 I2=I2+1
63919 IF(K(I2,1).EQ.41) GOTO 940
63920 IF(K(I2,1).GT.10) GOTO 920
63921 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63922 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63923 & NJUNC.EQ.0) GOTO 940
63924 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63925 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63926 & K(I2,1).NE.1)) GOTO 940
63927
63928C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63929 DO 930 J=1,3
63930 E1(J)=P(I1,J)/P(I1,4)
63931 E2(J)=P(I2,J)/P(I2,4)
63932 ECL(J)=P(N+1,J)/P(N+1,4)
63933 E3(J)=E2(J)-E1(J)
63934 E4(J)=ECL(J)-E1(J)
63935 930 CONTINUE
63936
63937C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63938 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63939 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63940 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63941 IF(E34.LE.0D0) THEN
63942 DDMIN=E4S
63943 ELSEIF(E34.LT.E3S) THEN
63944 DDMIN=E4S-E34**2/E3S
63945 ELSE
63946 DDMIN=E4S-2D0*E34+E3S
63947 ENDIF
63948
63949C...Is this the smallest so far?
63950 IF(DDMIN.LT.DGLOMI) THEN
63951 DGLOMI=DDMIN
63952 IBEG=I0
63953 IPCS=I1
63954 ENDIF
63955 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63956 I0=0
63957 ENDIF
63958 940 CONTINUE
63959
63960C... Check if there are any strings to connect to the new gluon. (EN)
63961 IF (IBEG.EQ.0) GOTO 1080
63962
63963C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63964 IF (P(N+1,5).GE.P(N+2,5)) THEN
63965
63966C...Construct 'gluon' that is needed to put hadron on the mass shell.
63967 FRAC=P(N+2,5)/P(N+1,5)
63968 DO 950 J=1,5
63969 P(N+2,J)=FRAC*P(N+1,J)
63970 PG(J)=(1D0-FRAC)*P(N+1,J)
63971 950 CONTINUE
63972
63973C... Copy string with new gluon put in.
63974 N=N+2
63975 I=IBEG-1
63976 960 I=I+1
63977 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63978 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
63979 N=N+1
63980 DO 970 J=1,5
63981 K(N,J)=K(I,J)
63982 P(N,J)=P(I,J)
63983 V(N,J)=V(I,J)
63984 970 CONTINUE
63985 K(I,1)=K(I,1)+10
63986 K(I,4)=N
63987 K(I,5)=N
63988 K(N,3)=I
63989 IF(I.EQ.IPCS) THEN
63990 N=N+1
63991 DO 980 J=1,5
63992 K(N,J)=K(N-1,J)
63993 P(N,J)=PG(J)
63994 V(N,J)=V(N-1,J)
63995 980 CONTINUE
63996 K(N,2)=21
63997 K(N,3)=NSAV+1
63998 ENDIF
63999 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64000 GOTO 1120
64001
64002C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64003C...from string piece endpoints.
64004 ELSE
64005
64006C...Begin by copying string that should give energy to cluster.
64007 N=N+2
64008 I=IBEG-1
64009 990 I=I+1
64010 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64011 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64012 N=N+1
64013 DO 1000 J=1,5
64014 K(N,J)=K(I,J)
64015 P(N,J)=P(I,J)
64016 V(N,J)=V(I,J)
64017 1000 CONTINUE
64018 K(I,1)=K(I,1)+10
64019 K(I,4)=N
64020 K(I,5)=N
64021 K(N,3)=I
64022 IF(I.EQ.IPCS) I1=N
64023 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64024 I2=I1+1
64025
64026C...Set initial Phad.
64027 DO 1010 J=1,4
64028 P(NSAV+2,J)=P(NSAV+1,J)
64029 1010 CONTINUE
64030
64031C...Calculate Pg, a part of which will be added to Phad later. (EN)
64032 1020 IF(MSTJ(16).EQ.1) THEN
64033 ALPHA=1D0
64034 BETA=1D0
64035 ELSE
64036 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64037 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64038 ENDIF
64039 DO 1030 J=1,4
64040 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64041 1030 CONTINUE
64042 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64043
64044C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64045 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64046 & P(NSAV+2,3)**2
64047 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64048 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64049 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64050
64051C...If all gluon energy eaten, zero it and take a step back.
64052 ITER=0
64053 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64054 ITER=1
64055 DO 1040 J=1,4
64056 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64057 P(I1,J)=0D0
64058 1040 CONTINUE
64059 P(I1,5)=0D0
64060 K(I1,1)=K(I1,1)+10
64061 I1=I1-1
64062 IF(K(I1,1).EQ.41) ITER=-1
64063 ENDIF
64064 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64065 ITER=1
64066 DO 1050 J=1,4
64067 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64068 P(I2,J)=0D0
64069 1050 CONTINUE
64070 P(I2,5)=0D0
64071 K(I2,1)=K(I2,1)+10
64072 I2=I2+1
64073 IF(K(I2,1).EQ.41) ITER=-1
64074 ENDIF
64075 IF(ITER.EQ.1) GOTO 1020
64076
64077C...If also all endpoint energy eaten, revert to old procedure.
64078 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64079 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64080 DO 1060 I=NSAV+3,N
64081 IM=K(I,3)
64082 K(IM,1)=K(IM,1)-10
64083 K(IM,4)=0
64084 K(IM,5)=0
64085 1060 CONTINUE
64086 N=NSAV
64087 GOTO 1080
64088 ENDIF
64089
64090C... Construct the collapsed hadron and modified string partons.
64091 DO 1070 J=1,4
64092 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64093 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64094 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64095 1070 CONTINUE
64096 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64097 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64098
64099C...Finished with string collapse in new scheme.
64100 GOTO 1120
64101 ENDIF
64102
64103C... Use old algorithm; by choice or when in trouble.
64104 1080 CONTINUE
64105C...Find parton/particle which combines to largest extra mass.
64106 IR=0
64107 HA=0D0
64108 HSM=0D0
64109 DO 1100 MCOMB=1,3
64110 IF(IR.NE.0) GOTO 1100
64111 DO 1090 I=MAX(1,IP),N
64112 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64113 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64114 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64115 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64116 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64117 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64118 & GOTO 1090
64119 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64120 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64121 IF(HSR.GT.HSM) THEN
64122 IR=I
64123 HA=HCR
64124 HSM=HSR
64125 ENDIF
64126 1090 CONTINUE
64127 1100 CONTINUE
64128
64129C...Shuffle energy and momentum to put new particle on mass shell.
64130 IF(IR.NE.0) THEN
64131 HB=PECM**2+HA
64132 HC=P(N+2,5)**2+HA
64133 HD=P(IR,5)**2+HA
64134 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64135 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64136 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64137 DO 1110 J=1,4
64138 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64139 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64140 1110 CONTINUE
64141 N=N+2
64142 ELSE
64143 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64144 RETURN
64145 ENDIF
64146
64147C...Mark collapsed system and store daughter pointers. Iterate.
64148 1120 DO 1130 I=IC1,IC2
64149 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64150 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64151 K(I,1)=K(I,1)+10
64152 IF(MSTU(16).NE.2) THEN
64153 K(I,4)=NSAV+1
64154 K(I,5)=NSAV+1
64155 ELSE
64156 K(I,4)=NSAV+2
64157 K(I,5)=NSAV+1+NBODY
64158 ENDIF
64159 ENDIF
64160 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64161 1130 CONTINUE
64162 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64163
64164C...Check flavours and invariant masses in parton systems.
64165 1140 NP=0
64166 KFN=0
64167 KQS=0
64168 NJU=0
64169 DO 1150 J=1,5
64170 DPS(J)=0D0
64171 1150 CONTINUE
64172 DO 1180 I=MAX(1,IP),N
64173 IF(K(I,1).EQ.41) NJU=NJU+1
64174 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64175 KC=PYCOMP(K(I,2))
64176 IF(KC.EQ.0) GOTO 1180
64177 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64178 IF(KQ.EQ.0) GOTO 1180
64179 NP=NP+1
64180 IF(KQ.NE.2) THEN
64181 KFN=KFN+1
64182 KQS=KQS+KQ
64183 MSTJ(93)=1
64184 DPS(5)=DPS(5)+PYMASS(K(I,2))
64185 ENDIF
64186 DO 1160 J=1,4
64187 DPS(J)=DPS(J)+P(I,J)
64188 1160 CONTINUE
64189 IF(K(I,1).EQ.1) THEN
64190 NFERR=0
64191 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64192 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64193 ELSEIF(NJU.EQ.1) THEN
64194 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64195 ELSEIF(NJU.EQ.2) THEN
64196 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64197 ELSEIF(NJU.GE.3) THEN
64198 NFERR=1
64199 ENDIF
64200 IF(NFERR.EQ.1) THEN
64201 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64202 MINT(51)=1
64203 RETURN
64204 ENDIF
64205 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64206 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64207 & '(PYPREP:) too small mass in jet system')
64208 NP=0
64209 KFN=0
64210 KQS=0
64211 NJU=0
64212 DO 1170 J=1,5
64213 DPS(J)=0D0
64214 1170 CONTINUE
64215 ENDIF
64216 1180 CONTINUE
64217
64218 RETURN
64219 END
64220
64221C*********************************************************************
64222
64223C...PYSTRF
64224C...Handles the fragmentation of an arbitrary colour singlet
64225C...jet system according to the Lund string fragmentation model.
64226
64227 SUBROUTINE PYSTRF(IP)
64228
64229C...Double precision and integer declarations.
64230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64231 IMPLICIT INTEGER(I-N)
64232 INTEGER PYK,PYCHGE,PYCOMP
64233C...Commonblocks.
64234 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64235 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64236 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64237 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64238C...Local arrays. All MOPS variables ends with MO
64239 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64240 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64241 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64242 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64243 &PBST(3,5),TJUOLD(5)
64244
64245C...Function: four-product of two vectors.
64246 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)
64247 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64248 &DP(I,3)*DP(J,3)
64249
64250C...Reset counters.
64251 MSTJ(91)=0
64252 NSAV=N
64253 MSTU90=MSTU(90)
64254 NP=0
64255 KQSUM=0
64256 DO 100 J=1,5
64257 DPS(J)=0D0
64258 100 CONTINUE
64259 MJU(1)=0
64260 MJU(2)=0
64261 NTRYFN=0
64262 IJUORI(1)=0
64263 IJUORI(2)=0
64264
64265C...Identify parton system.
64266 I=IP-1
64267 110 I=I+1
64268 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64269 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64270 IF(MSTU(21).GE.1) RETURN
64271 ENDIF
64272 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64273 KC=PYCOMP(K(I,2))
64274 IF(KC.EQ.0) GOTO 110
64275 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64276 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64277 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64278 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64279 IF(MSTU(21).GE.1) RETURN
64280 ENDIF
64281
64282C...Take copy of partons to be considered. Check flavour sum.
64283 NP=NP+1
64284 DO 120 J=1,5
64285 K(N+NP,J)=K(I,J)
64286 P(N+NP,J)=P(I,J)
64287 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64288 120 CONTINUE
64289 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64290 K(N+NP,3)=I
64291 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64292 IF(K(I,1).EQ.41) THEN
64293 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64294 MJU(1)=N+NP
64295 IJUORI(1)=I
64296 ELSE
64297 MJU(2)=N+NP
64298 IJUORI(2)=I
64299 ENDIF
64300 ENDIF
64301 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64302 IF(MOD(KQSUM,3).NE.0) THEN
64303 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64304 IF(MSTU(21).GE.1) RETURN
64305 ENDIF
64306 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64307
64308C...Boost copied system to CM frame (for better numerical precision).
64309 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64310 MBST=0
64311 MSTU(33)=1
64312 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64313 & -DPS(3)/DPS(4))
64314 ELSE
64315 MBST=1
64316 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64317 DO 130 I=N+1,N+NP
64318 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64319 IF(P(I,3).GT.0D0) THEN
64320 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64321 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64322 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64323 ELSE
64324 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64325 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64326 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64327 ENDIF
64328 130 CONTINUE
64329 ENDIF
64330
64331C...Search for very nearby partons that may be recombined.
64332 NTRYR=0
64333 NTRYWR=0
64334 PARU12=PARU(12)
64335 PARU13=PARU(13)
64336 MJU(3)=MJU(1)
64337 MJU(4)=MJU(2)
64338 NR=NP
64339 NRMIN=2
64340 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64341 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64342 140 IF(NR.GT.NRMIN) THEN
64343 PDRMIN=2D0*PARU12
64344 DO 150 I=N+1,N+NR
64345 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64346 I1=I+1
64347 IF(I.EQ.N+NR) I1=N+1
64348 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64349 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64350 & GOTO 150
64351 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64352 & GOTO 150
64353 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64354 & P(I1,2)**2+P(I1,3)**2))
64355 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64356 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64357 IF(PDR.LT.PDRMIN) THEN
64358 IR=I
64359 PDRMIN=PDR
64360 ENDIF
64361 150 CONTINUE
64362
64363C...Recombine very nearby partons to avoid machine precision problems.
64364 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64365 DO 160 J=1,4
64366 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64367 160 CONTINUE
64368 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64369 & P(N+1,3)**2))
64370 NR=NR-1
64371 GOTO 140
64372 ELSEIF(PDRMIN.LT.PARU12) THEN
64373 DO 170 J=1,4
64374 P(IR,J)=P(IR,J)+P(IR+1,J)
64375 170 CONTINUE
64376 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64377 & P(IR,3)**2))
64378 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64379 DO 190 I=IR+1,N+NR-1
64380 K(I,1)=K(I+1,1)
64381 K(I,2)=K(I+1,2)
64382 DO 180 J=1,5
64383 P(I,J)=P(I+1,J)
64384 180 CONTINUE
64385 190 CONTINUE
64386 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64387 NR=NR-1
64388 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64389 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64390 GOTO 140
64391 ENDIF
64392 ENDIF
64393 NTRYR=NTRYR+1
64394
64395C...Reset particle counter. Skip ahead if no junctions are present;
64396C...this is usually the case!
64397 NRS=MAX(5*NR+11,NP)
64398 NTRY=0
64399 200 NTRY=NTRY+1
64400 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64401 PARU12=4D0*PARU12
64402 PARU13=2D0*PARU13
64403 GOTO 140
64404 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64405 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64406 IF(MSTU(21).GE.1) RETURN
64407 ENDIF
64408 I=N+NRS
64409 MSTU(90)=MSTU90
64410 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64411 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64412 & ' junction strings not handled by MSTJ(12)>3 options')
64413 DO 640 JT=1,2
64414 NJS(JT)=0
64415 IF(MJU(JT).EQ.0) GOTO 640
64416 JS=3-2*JT
64417
64418C++SKANDS
64419C...Find and sum up momentum on three sides of junction.
64420C...Begin with previous boost = zero.
64421 IJRFIT=0
64422 DO 210 IX=1,3
64423 TJUOLD(IX)=0D0
64424 210 CONTINUE
64425C...Prevent IJU (specifically IJU(5)) from containing junk below
64426 DO 215 IU=1,6
64427 IJU(IU)=0
64428 215 CONTINUE
64429 TJUOLD(4)=1D0
64430 220 IU=0
64431C...Beginning and end of string system in event record.
64432 I1BEG=N+1+(JT-1)*(NR-1)
64433 I1END=N+NR+(JT-1)*(1-NR)
64434C...Look for junction string piece end points
64435 DO 230 I1=I1BEG,I1END,JS
64436 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64437C...Store junction string piece end points.
64438C 1-junction systems 2-junction systems
64439C IU : 1 2 3 4 1 2 3 4 5 6
64440C 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
64441 IU=IU+1
64442 IJU(IU)=I1
64443 ENDIF
64444C...Sum over momenta, from junction outwards.
64445 230 CONTINUE
64446 DO 280 IU=1,3
64447 PWT=0D0
64448C...Initialize junction drag and string piece 4-vectors.
64449 DO 240 J=1,5
64450 PBST(IU,J)=0D0
64451 PJU(IU,J)=0D0
64452 240 CONTINUE
64453C...First two branches. Inwards out means opposite direction to JS.
64454C...(JS is 1 for JT=1, -1 for JT=2)
64455 IF (IU.LT.3) THEN
64456 I1A=IJU(IU+1)-JS
64457 I1B=IJU(IU)
64458 IDIR=-JS
64459C...Last branch (gq or gjgqgq). Direction now reversed.
64460 ELSE
64461 I1A=IJU(IU)+JS
64462 I1B=I1END
64463 IDIR=JS
64464 ENDIF
64465 DO 270 I1=I1A,I1B,IDIR
64466C...Sum up momentum directions with exponential suppression
64467C...for use in finding junction rest frame below.
64468 IF (K(I1,2).EQ.88) THEN
64469C...gjgqgq type system encountered. Use current PWT as start
64470C...for both strings.
64471 PWTOLD=PWT
64472 ELSE
64473 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64474C...Sum up string piece (boosted) 4-momenta.
64475 DO 250 J=1,4
64476 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64477 250 CONTINUE
64478C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64479C...boost is zero, see above). Skip parton if suppression factor large.
64480 IF (PWT.GT.10D0) GOTO 270
64481C...Compute momentum in current frame:
64482 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64483 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64484 DO 260 J=1,3
64485 PTMP=P(I1,J)+TJUOLD(J)*BFC
64486 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64487 260 CONTINUE
64488C...Boosted energy
64489 PTMP=TJUOLD(4)*P(I1,4)+TDP
64490 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64491 PWT=PWT+PTMP/PARJ(48)
64492 ENDIF
64493 270 CONTINUE
64494C...Put |p| rather than m in 5th slot.
64495 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64496 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64497 280 CONTINUE
64498
64499C...Calculate boost from present frame to next JRF candidate.
64500 IJRFIT=IJRFIT+1
64501 CALL PYJURF(PBST,TJU)
64502
64503C...After some iterations do not take full step in new direction.
64504 IF(IJRFIT.GT.5) THEN
64505 REDUCE=0.8D0**(IJRFIT-5)
64506 TJU(1)=REDUCE*TJU(1)
64507 TJU(2)=REDUCE*TJU(2)
64508 TJU(3)=REDUCE*TJU(3)
64509 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64510 ENDIF
64511
64512C...Combine new boost (TJU) with old boost (TJUOLD)
64513 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64514 DO 290 IX=1,3
64515 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64516 290 CONTINUE
64517 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64518
64519C...If last boost small, accept JRF, else iterate.
64520C...Also prevent possibility of infinite loop.
64521 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64522 & IJRFIT.LT.MSTJ(18)) THEN
64523 GOTO 220
64524 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64525 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64526 ENDIF
64527
64528C...Now store total boost in TJU and change perception.
64529C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64530C...TJU = junction motion vector in string CM, so the sign changes.
64531 DO 300 J=1,3
64532 TJU(J)=-TJUOLD(J)
64533 300 CONTINUE
64534 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64535
64536C--SKANDS
64537
64538C...Calculate string piece energies in junction rest frame.
64539 DO 310 IU=1,3
64540 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64541 & TJU(3)*PJU(IU,3)
64542 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64543 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64544 310 CONTINUE
64545
64546C...Start preparing for fragmentation of two strings from junction.
64547 ISTA=I
64548 NTRYER=0
64549 320 NTRYER=NTRYER+1
64550 I=ISTA
64551 DO 620 IU=1,2
64552 NS=IABS(IJU(IU+1)-IJU(IU))
64553
64554C...Junction strings: find longitudinal string directions.
64555 DO 350 IS=1,NS
64556 IS1=IJU(IU)+JS*(IS-1)
64557 IS2=IJU(IU)+JS*IS
64558 DO 330 J=1,5
64559 DP(1,J)=0.5D0*P(IS1,J)
64560 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64561 DP(2,J)=0.5D0*P(IS2,J)
64562 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64563 & (PJU(IU,5)/PBST(IU,5))
64564 330 CONTINUE
64565 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64566 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64567 DP(3,5)=DFOUR(1,1)
64568 DP(4,5)=DFOUR(2,2)
64569 DHKC=DFOUR(1,2)
64570 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64571 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64572 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64573 DP(3,5)=0D0
64574 DP(4,5)=0D0
64575 DHKC=DFOUR(1,2)
64576 ENDIF
64577 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64578 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64579 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64580 IN1=N+NR+4*IS-3
64581 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64582 DO 340 J=1,4
64583 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64584 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64585 340 CONTINUE
64586 350 CONTINUE
64587
64588C...Junction strings: initialize flavour, momentum and starting pos.
64589 ISAV=I
64590 MSTU91=MSTU(90)
64591 360 NTRY=NTRY+1
64592 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64593 PARU12=4D0*PARU12
64594 PARU13=2D0*PARU13
64595 GOTO 140
64596 ELSEIF(NTRY.GT.100) THEN
64597 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64598 IF(MSTU(21).GE.1) RETURN
64599 ENDIF
64600 I=ISAV
64601 MSTU(90)=MSTU91
64602 IRANKJ=0
64603 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64604 IF (MOD(JT+IU,2).NE.0) THEN
64605 IE(1)=K(IJU(IU),3)
64606 IF (NP-NR.NE.0) THEN
64607C...If gluons have disappeared. Original IJU must be used.
64608 IT=IP
64609 NE=1
64610 370 IT=IT+1
64611 IF (K(IT,2).NE.21) THEN
64612 NE=NE+1
64613 ENDIF
64614 IF (NE.EQ.IU+4*(JT-1)) THEN
64615 IE(1)=IT
64616 ELSEIF (IT.LE.IP+NP) THEN
64617 GOTO 370
64618 ELSE
64619 CALL PYERRM(14,'(PYSTRF:) '//
64620 & 'Original IJU could not be reconstructed!')
64621 ENDIF
64622 ENDIF
64623 ENDIF
64624 IN(4)=N+NR+1
64625 IN(5)=IN(4)+1
64626 IN(6)=N+NR+4*NS+1
64627 DO 390 JQ=1,2
64628 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64629 P(IN1,1)=2-JQ
64630 P(IN1,2)=JQ-1
64631 P(IN1,3)=1D0
64632 380 CONTINUE
64633 390 CONTINUE
64634 KFL(1)=K(IJU(IU),2)
64635 PX(1)=0D0
64636 PY(1)=0D0
64637 GAM(1)=0D0
64638 DO 400 J=1,5
64639 PJU(IU+3,J)=0D0
64640 400 CONTINUE
64641
64642C...Junction strings: find initial transverse directions.
64643 DO 410 J=1,4
64644 DP(1,J)=P(IN(4),J)
64645 DP(2,J)=P(IN(4)+1,J)
64646 DP(3,J)=0D0
64647 DP(4,J)=0D0
64648 410 CONTINUE
64649 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64650 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64651 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64652 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64653 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64654 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64655 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64656 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64657 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64658 DHC12=DFOUR(1,2)
64659 DHCX1=DFOUR(3,1)/DHC12
64660 DHCX2=DFOUR(3,2)/DHC12
64661 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64662 DHCY1=DFOUR(4,1)/DHC12
64663 DHCY2=DFOUR(4,2)/DHC12
64664 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64665 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64666 DO 420 J=1,4
64667 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64668 P(IN(6),J)=DP(3,J)
64669 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64670 & DHCYX*DP(3,J))
64671 420 CONTINUE
64672
64673C...Junction strings: produce new particle, origin.
64674 430 I=I+1
64675 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64676 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64677 IF(MSTU(21).GE.1) RETURN
64678 ENDIF
64679 IRANKJ=IRANKJ+1
64680 K(I,1)=1
64681 K(I,3)=IE(1)
64682 K(I,4)=0
64683 K(I,5)=0
64684
64685C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64686 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64687 IF(K(I,2).EQ.0) GOTO 360
64688 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64689 & IABS(KFL(3)).GT.10) THEN
64690 IF(PYR(0).GT.PARJ(19)) GOTO 440
64691 ENDIF
64692 P(I,5)=PYMASS(K(I,2))
64693 CALL PYPTDI(KFL(1),PX(3),PY(3))
64694 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64695 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64696 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64697 & MSTU(90).LT.8) THEN
64698 MSTU(90)=MSTU(90)+1
64699 MSTU(90+MSTU(90))=I
64700 PARU(90+MSTU(90))=Z
64701 ENDIF
64702 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64703 DO 450 J=1,3
64704 IN(J)=IN(3+J)
64705 450 CONTINUE
64706
64707C...Junction strings: stepping within 'low' string region.
64708 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64709 & P(IN(1),5)**2.GE.PR(1)) THEN
64710 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64711 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64712 DO 460 J=1,4
64713 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64714 460 CONTINUE
64715 GOTO 560
64716C...Has used up energy of junction string, i.e. no more hadrons in it.
64717 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64718 DO 470 J=1,5
64719 P(I,J)=0D0
64720 470 CONTINUE
64721 GOTO 600
64722C...Stepping from 'low' string region
64723 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64724 P(IN(2)+2,4)=P(IN(2)+2,3)
64725 P(IN(2)+2,1)=1D0
64726 IN(2)=IN(2)+4
64727 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64728 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64729 P(IN(1)+2,4)=P(IN(1)+2,3)
64730 P(IN(1)+2,1)=0D0
64731 IN(1)=IN(1)+4
64732 ENDIF
64733 ENDIF
64734
64735C...Junction strings: find new transverse directions.
64736 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64737 & IN(1).GT.IN(2)) GOTO 360
64738 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64739 DO 490 J=1,4
64740 DP(1,J)=P(IN(1),J)
64741 DP(2,J)=P(IN(2),J)
64742 DP(3,J)=0D0
64743 DP(4,J)=0D0
64744 490 CONTINUE
64745 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64746 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64747 DHC12=DFOUR(1,2)
64748 IF(DHC12.LE.1D-2) THEN
64749 P(IN(1)+2,4)=P(IN(1)+2,3)
64750 P(IN(1)+2,1)=0D0
64751 IN(1)=IN(1)+4
64752 GOTO 480
64753 ENDIF
64754 IN(3)=N+NR+4*NS+5
64755 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64756 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64757 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64758 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64759 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64760 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64761 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64762 DHCX1=DFOUR(3,1)/DHC12
64763 DHCX2=DFOUR(3,2)/DHC12
64764 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64765 DHCY1=DFOUR(4,1)/DHC12
64766 DHCY2=DFOUR(4,2)/DHC12
64767 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64768 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64769 DO 500 J=1,4
64770 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64771 P(IN(3),J)=DP(3,J)
64772 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64773 & DHCYX*DP(3,J))
64774 500 CONTINUE
64775C...Express pT with respect to new axes, if sensible.
64776 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64777 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64778 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64779 PX(3)=PXP
64780 PY(3)=PYP
64781 ENDIF
64782 ENDIF
64783
64784C...Junction strings: sum up known four-momentum, coefficients for m2.
64785 DO 530 J=1,4
64786 DHG(J)=0D0
64787 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64788 & PY(3)*P(IN(3)+1,J)
64789 DO 510 IN1=IN(4),IN(1)-4,4
64790 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64791 510 CONTINUE
64792 DO 520 IN2=IN(5),IN(2)-4,4
64793 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64794 520 CONTINUE
64795 530 CONTINUE
64796 DHM(1)=FOUR(I,I)
64797 DHM(2)=2D0*FOUR(I,IN(1))
64798 DHM(3)=2D0*FOUR(I,IN(2))
64799 DHM(4)=2D0*FOUR(IN(1),IN(2))
64800
64801C...Junction strings: find coefficients for Gamma expression.
64802 DO 550 IN2=IN(1)+1,IN(2),4
64803 DO 540 IN1=IN(1),IN2-1,4
64804 DHC=2D0*FOUR(IN1,IN2)
64805 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64806 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64807 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64808 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64809 540 CONTINUE
64810 550 CONTINUE
64811
64812C...Junction strings: solve (m2, Gamma) equation system for energies.
64813 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64814 IF(ABS(DHS1).LT.1D-4) GOTO 360
64815 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64816 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64817 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64818 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64819 & ABS(DHS1)-DHS2/DHS1)
64820 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64821 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64822 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64823
64824C...Junction strings: step to new region if necessary.
64825 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64826 P(IN(2)+2,4)=P(IN(2)+2,3)
64827 P(IN(2)+2,1)=1D0
64828 IN(2)=IN(2)+4
64829 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64830 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64831 P(IN(1)+2,4)=P(IN(1)+2,3)
64832 P(IN(1)+2,1)=0D0
64833 IN(1)=IN(1)+4
64834 ENDIF
64835 GOTO 480
64836 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64837 P(IN(1)+2,4)=P(IN(1)+2,3)
64838 P(IN(1)+2,1)=0D0
64839 IN(1)=IN(1)+4
64840 GOTO 480
64841 ENDIF
64842
64843C...Junction strings: particle four-momentum, remainder, loop back.
64844 560 DO 570 J=1,4
64845 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64846 & P(IN(2)+2,4)*P(IN(2),J)
64847 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64848 570 CONTINUE
64849 IF(P(I,4).LT.P(I,5)) GOTO 360
64850 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64851 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64852 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64853 KFL(1)=-KFL(3)
64854 PX(1)=-PX(3)
64855 PY(1)=-PY(3)
64856 GAM(1)=GAM(3)
64857 IF(IN(3).NE.IN(6)) THEN
64858 DO 580 J=1,4
64859 P(IN(6),J)=P(IN(3),J)
64860 P(IN(6)+1,J)=P(IN(3)+1,J)
64861 580 CONTINUE
64862 ENDIF
64863 DO 590 JQ=1,2
64864 IN(3+JQ)=IN(JQ)
64865 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64866 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64867 590 CONTINUE
64868 GOTO 430
64869 ENDIF
64870
64871C...Junction strings: save quantities left after each string.
64872 IF(IABS(KFL(1)).GT.10) GOTO 360
64873 600 I=I-1
64874 KFJH(IU)=KFL(1)
64875 DO 610 J=1,4
64876 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64877 610 CONTINUE
64878
64879C...Junction strings: loopback if much unused energy in both strings.
64880 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64881 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64882 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64883 620 CONTINUE
64884 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64885 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64886 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64887 & .AND.NTRYER.LT.10) GOTO 320
64888
64889C...Junction strings: put together to new effective string endpoint.
64890 NJS(JT)=I-ISTA
64891 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64892 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64893 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64894 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64895 DO 630 J=1,4
64896 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64897 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64898 630 CONTINUE
64899 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64900 & PJS(JT,3)**2))
64901 PJS(JT+2,5)=0D0
64902 640 CONTINUE
64903
64904C...Open versus closed strings. Choose breakup region for latter.
64905 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64906 NS=MJU(2)-MJU(1)
64907 NB=MJU(1)-N
64908 ELSEIF(MJU(1).NE.0) THEN
64909 NS=N+NR-MJU(1)
64910 NB=MJU(1)-N
64911 ELSEIF(MJU(2).NE.0) THEN
64912 NS=MJU(2)-N
64913 NB=1
64914 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64915 NS=NR-1
64916 NB=1
64917 ELSE
64918 NS=NR+1
64919 W2SUM=0D0
64920 DO 660 IS=1,NR
64921 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64922 W2SUM=W2SUM+P(N+NR+IS,1)
64923 660 CONTINUE
64924 W2RAN=PYR(0)*W2SUM
64925 NB=0
64926 670 NB=NB+1
64927 W2SUM=W2SUM-P(N+NR+NB,1)
64928 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64929 ENDIF
64930
64931C...Find longitudinal string directions (i.e. lightlike four-vectors).
64932 DO 700 IS=1,NS
64933 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64934 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64935 DO 680 J=1,5
64936 DP(1,J)=P(IS1,J)
64937 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64938 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64939 DP(2,J)=P(IS2,J)
64940 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64941 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64942 680 CONTINUE
64943 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64944 & DP(1,2)**2-DP(1,3)**2))
64945 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64946 & DP(2,2)**2-DP(2,3)**2))
64947 DP(3,5)=DFOUR(1,1)
64948 DP(4,5)=DFOUR(2,2)
64949 DHKC=DFOUR(1,2)
64950 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64951 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64952 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64953 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64954 IN1=N+NR+4*IS-3
64955 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64956 DO 690 J=1,4
64957 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64958 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64959 690 CONTINUE
64960 700 CONTINUE
64961
64962C...Begin initialization: sum up energy, set starting position.
64963 ISAV=I
64964 MSTU91=MSTU(90)
64965 710 NTRY=NTRY+1
64966 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64967 PARU12=4D0*PARU12
64968 PARU13=2D0*PARU13
64969 GOTO 140
64970 ELSEIF(NTRY.GT.100) THEN
64971 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64972 IF(MSTU(21).GE.1) RETURN
64973 ENDIF
64974 I=ISAV
64975 MSTU(90)=MSTU91
64976 DO 730 J=1,4
64977 P(N+NRS,J)=0D0
64978 DO 720 IS=1,NR
64979 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64980 720 CONTINUE
64981 730 CONTINUE
64982 DO 750 JT=1,2
64983 IRANK(JT)=0
64984 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
64985 IF(NS.GT.NR) IRANK(JT)=1
64986 IBARRK(JT)=0
64987 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
64988 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
64989 IN(3*JT+2)=IN(3*JT+1)+1
64990 IN(3*JT+3)=N+NR+4*NS+2*JT-1
64991 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
64992 P(IN1,1)=2-JT
64993 P(IN1,2)=JT-1
64994 P(IN1,3)=1D0
64995 740 CONTINUE
64996 750 CONTINUE
64997
64998C.. MOPS variables and switches
64999 NRVMO=0
65000 XBMO=1D0
65001 MSTU(121)=0
65002 MSTU(122)=0
65003
65004C...Initialize flavour and pT variables for open string.
65005 IF(NS.LT.NR) THEN
65006 PX(1)=0D0
65007 PY(1)=0D0
65008 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65009 PX(2)=-PX(1)
65010 PY(2)=-PY(1)
65011 DO 760 JT=1,2
65012 KFL(JT)=K(IE(JT),2)
65013 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65014 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65015 MSTJ(93)=1
65016 PMQ(JT)=PYMASS(KFL(JT))
65017 GAM(JT)=0D0
65018 760 CONTINUE
65019
65020C...Closed string: random initial breakup flavour, pT and vertex.
65021 ELSE
65022 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65023 IBMO=0
65024 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65025C.. Closed string: first vertex diq attempt => enforced second
65026C.. vertex diq
65027 IF(IABS(KFL(1)).GT.10)THEN
65028 IBMO=1
65029 MSTU(121)=0
65030 GOTO 770
65031 ENDIF
65032 IF(IBMO.EQ.1) MSTU(121)=-1
65033 KFL(2)=-KFL(1)
65034 CALL PYPTDI(KFL(1),PX(1),PY(1))
65035 PX(2)=-PX(1)
65036 PY(2)=-PY(1)
65037 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65038 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65039 ZR=PR3/(Z*P(N+NR+1,5)**2)
65040 IF(ZR.GE.1D0) GOTO 780
65041 DO 790 JT=1,2
65042 MSTJ(93)=1
65043 PMQ(JT)=PYMASS(KFL(JT))
65044 GAM(JT)=PR3*(1D0-Z)/Z
65045 IN1=N+NR+3+4*(JT/2)*(NS-1)
65046 P(IN1,JT)=1D0-Z
65047 P(IN1,3-JT)=JT-1
65048 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65049 P(IN1+1,JT)=ZR
65050 P(IN1+1,3-JT)=2-JT
65051 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65052 790 CONTINUE
65053 ENDIF
65054C.. MOPS variables
65055 DO 800 JT=1,2
65056 XTMO(JT)=1D0
65057 PM2QMO(JT)=PMQ(JT)**2
65058 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65059 800 CONTINUE
65060
65061C...Find initial transverse directions (i.e. spacelike four-vectors).
65062 DO 840 JT=1,2
65063 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65064 IN1=IN(3*JT+1)
65065 IN3=IN(3*JT+3)
65066 DO 810 J=1,4
65067 DP(1,J)=P(IN1,J)
65068 DP(2,J)=P(IN1+1,J)
65069 DP(3,J)=0D0
65070 DP(4,J)=0D0
65071 810 CONTINUE
65072 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65073 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65074 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65075 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65076 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65077 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65078 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65079 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65080 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65081 DHC12=DFOUR(1,2)
65082 DHCX1=DFOUR(3,1)/DHC12
65083 DHCX2=DFOUR(3,2)/DHC12
65084 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65085 DHCY1=DFOUR(4,1)/DHC12
65086 DHCY2=DFOUR(4,2)/DHC12
65087 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65088 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65089 DO 820 J=1,4
65090 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65091 P(IN3,J)=DP(3,J)
65092 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65093 & DHCYX*DP(3,J))
65094 820 CONTINUE
65095 ELSE
65096 DO 830 J=1,4
65097 P(IN3+2,J)=P(IN3,J)
65098 P(IN3+3,J)=P(IN3+1,J)
65099 830 CONTINUE
65100 ENDIF
65101 840 CONTINUE
65102
65103C...Remove energy used up in junction string fragmentation.
65104 IF(MJU(1)+MJU(2).GT.0) THEN
65105 DO 860 JT=1,2
65106 IF(NJS(JT).EQ.0) GOTO 860
65107 DO 850 J=1,4
65108 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65109 850 CONTINUE
65110 860 CONTINUE
65111 PARJST=PARJ(33)
65112 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65113 WMIN=PARJST+PMQ(1)+PMQ(2)
65114 WREM2=FOUR(N+NRS,N+NRS)
65115 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65116 NTRYWR=NTRYWR+1
65117 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65118 GOTO 140
65119 ENDIF
65120 ENDIF
65121
65122C...Produce new particle: side, origin.
65123 870 I=I+1
65124 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65125 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65126 IF(MSTU(21).GE.1) RETURN
65127 ENDIF
65128C.. New side priority for popcorn systems
65129 IF(MSTU(121).LE.0)THEN
65130 JT=1.5D0+PYR(0)
65131 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65132 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65133 ENDIF
65134 JR=3-JT
65135 JS=3-2*JT
65136 IRANK(JT)=IRANK(JT)+1
65137 K(I,1)=1
65138 K(I,4)=0
65139 K(I,5)=0
65140
65141C...Generate flavour, hadron and pT.
65142 880 K(I,3)=IE(JT)
65143 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65144 IF(K(I,2).EQ.0) GOTO 710
65145 MU90MO=MSTU(90)
65146 IF(MSTU(121).EQ.-1) GOTO 910
65147 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65148 &IABS(KFL(3)).GT.10) THEN
65149 IF(PYR(0).GT.PARJ(19)) GOTO 880
65150 ENDIF
65151 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65152 &K(I,3)=IJUORI(JT)
65153 P(I,5)=PYMASS(K(I,2))
65154 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65155 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65156
65157C...Final hadrons for small invariant mass.
65158 MSTJ(93)=1
65159 PMQ(3)=PYMASS(KFL(3))
65160 PARJST=PARJ(33)
65161 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65162 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65163 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65164 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65165 WREM2=FOUR(N+NRS,N+NRS)
65166 IF(WREM2.LT.0.10D0) GOTO 710
65167 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65168 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65169
65170C...Choose z, which gives Gamma. Shift z for heavy flavours.
65171 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65172 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65173 &MSTU(90).LT.8) THEN
65174 MSTU(90)=MSTU(90)+1
65175 MSTU(90+MSTU(90))=I
65176 PARU(90+MSTU(90))=Z
65177 ENDIF
65178 KFL1A=IABS(KFL(1))
65179 KFL2A=IABS(KFL(2))
65180 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65181 &MOD(KFL2A/1000,10)).GE.4) THEN
65182 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65183 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65184 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65185 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65186 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65187 ENDIF
65188 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65189
65190C.. MOPS baryon model modification
65191 XTMO3=(1D0-Z)*XTMO(JT)
65192 IF(IABS(KFL(3)).LE.10) NRVMO=0
65193 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65194 GTSTMO=1D0
65195 PTSTMO=1D0
65196 RTSTMO=PYR(0)
65197 IF(IABS(KFL(JT)).LE.10)THEN
65198 XBMO=MIN(XTMO3,1D0-(2D-10))
65199 GBMO=GAM(3)
65200 PMMO=0D0
65201 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65202 GTSTMO=1D0-PARF(192)**PGMO
65203 ELSE
65204 IF(IRANK(JT).EQ.1) THEN
65205 GBMO=GAM(JT)
65206 PMMO=0D0
65207 XBMO=1D0
65208 ENDIF
65209 IF(XBMO.LT.1D0-(1D-10))THEN
65210 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65211 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65212 PGMO=PGNMO
65213 ENDIF
65214 IF(MSTJ(12).GE.5)THEN
65215 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65216 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65217 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65218 PMMO=PMNMO
65219 ENDIF
65220 ENDIF
65221
65222C.. MOPS Accepting popcorn system hadron.
65223 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65224 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65225 NRVMO=I-N-NR
65226 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65227 CALL PYERRM(11,
65228 & '(PYSTRF:) no more memory left in PYJETS')
65229 IF(MSTU(21).GE.1) RETURN
65230 ENDIF
65231 IMO=I
65232 KFLMO=KFL(JT)
65233 PMQMO=PMQ(JT)
65234 PXMO=PX(JT)
65235 PYMO=PY(JT)
65236 GAMMO=GAM(JT)
65237 IRMO=IRANK(JT)
65238 XMO=XTMO(JT)
65239 DO 900 J=1,9
65240 IF(J.LE.5) THEN
65241 DO 890 LINE=1,I-N-NR
65242 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65243 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65244 890 CONTINUE
65245 ENDIF
65246 INMO(J)=IN(J)
65247 900 CONTINUE
65248 ENDIF
65249 ELSE
65250C..Reject popcorn system, flag=-1 if enforcing new one
65251 MSTU(121)=-1
65252 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65253 ENDIF
65254 ENDIF
65255
65256
65257C..Lift restoring string outside MOPS block
65258 910 IF(MSTU(121).LT.0) THEN
65259 IF(MSTU(121).EQ.-2) MSTU(121)=0
65260 MSTU(90)=MU90MO
65261 NRVMO=0
65262 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65263 I=IMO
65264 KFL(JT)=KFLMO
65265 PMQ(JT)=PMQMO
65266 PX(JT)=PXMO
65267 PY(JT)=PYMO
65268 GAM(JT)=GAMMO
65269 IRANK(JT)=IRMO
65270 XTMO(JT)=XMO
65271 DO 930 J=1,9
65272 IF(J.LE.5) THEN
65273 DO 920 LINE=1,I-N-NR
65274 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65275 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65276 920 CONTINUE
65277 ENDIF
65278 IN(J)=INMO(J)
65279 930 CONTINUE
65280 GOTO 880
65281 ENDIF
65282 XTMO(JT)=XTMO3
65283C.. MOPS end of modification
65284
65285 DO 940 J=1,3
65286 IN(J)=IN(3*JT+J)
65287 940 CONTINUE
65288
65289C...Stepping within or from 'low' string region easy.
65290 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65291 &P(IN(1),5)**2.GE.PR(JT)) THEN
65292 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65293 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65294 DO 950 J=1,4
65295 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65296 950 CONTINUE
65297 GOTO 1040
65298 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65299 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65300 P(IN(JR)+2,JT)=1D0
65301 IN(JR)=IN(JR)+4*JS
65302 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65303 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65304 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65305 P(IN(JT)+2,JT)=0D0
65306 IN(JT)=IN(JT)+4*JS
65307 ENDIF
65308 ENDIF
65309
65310C...Find new transverse directions (i.e. spacelike string vectors).
65311 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65312 &IN(1).GT.IN(2)) GOTO 710
65313 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65314 DO 970 J=1,4
65315 DP(1,J)=P(IN(1),J)
65316 DP(2,J)=P(IN(2),J)
65317 DP(3,J)=0D0
65318 DP(4,J)=0D0
65319 970 CONTINUE
65320 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65321 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65322 DHC12=DFOUR(1,2)
65323 IF(DHC12.LE.1D-2) THEN
65324 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65325 P(IN(JT)+2,JT)=0D0
65326 IN(JT)=IN(JT)+4*JS
65327 GOTO 960
65328 ENDIF
65329 IN(3)=N+NR+4*NS+5
65330 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65331 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65332 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65333 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65334 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65335 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65336 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65337 DHCX1=DFOUR(3,1)/DHC12
65338 DHCX2=DFOUR(3,2)/DHC12
65339 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65340 DHCY1=DFOUR(4,1)/DHC12
65341 DHCY2=DFOUR(4,2)/DHC12
65342 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65343 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65344 DO 980 J=1,4
65345 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65346 P(IN(3),J)=DP(3,J)
65347 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65348 & DHCYX*DP(3,J))
65349 980 CONTINUE
65350C...Express pT with respect to new axes, if sensible.
65351 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65352 & FOUR(IN(3*JT+3)+1,IN(3)))
65353 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65354 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65355 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65356 PX(3)=PXP
65357 PY(3)=PYP
65358 ENDIF
65359 ENDIF
65360
65361C...Sum up known four-momentum. Gives coefficients for m2 expression.
65362 DO 1010 J=1,4
65363 DHG(J)=0D0
65364 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65365 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65366 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65367 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65368 990 CONTINUE
65369 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65370 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65371 1000 CONTINUE
65372 1010 CONTINUE
65373 DHM(1)=FOUR(I,I)
65374 DHM(2)=2D0*FOUR(I,IN(1))
65375 DHM(3)=2D0*FOUR(I,IN(2))
65376 DHM(4)=2D0*FOUR(IN(1),IN(2))
65377
65378C...Find coefficients for Gamma expression.
65379 DO 1030 IN2=IN(1)+1,IN(2),4
65380 DO 1020 IN1=IN(1),IN2-1,4
65381 DHC=2D0*FOUR(IN1,IN2)
65382 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65383 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65384 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65385 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65386 1020 CONTINUE
65387 1030 CONTINUE
65388
65389C...Solve (m2, Gamma) equation system for energies taken.
65390 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65391 IF(ABS(DHS1).LT.1D-4) GOTO 710
65392 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65393 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65394 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65395 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65396 &ABS(DHS1)-DHS2/DHS1)
65397 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65398 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65399 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65400
65401C...Step to new region if necessary.
65402 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65403 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65404 P(IN(JR)+2,JT)=1D0
65405 IN(JR)=IN(JR)+4*JS
65406 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65407 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65408 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65409 P(IN(JT)+2,JT)=0D0
65410 IN(JT)=IN(JT)+4*JS
65411 ENDIF
65412 GOTO 960
65413 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65414 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65415 P(IN(JT)+2,JT)=0D0
65416 IN(JT)=IN(JT)+4*JS
65417 GOTO 960
65418 ENDIF
65419
65420C...Four-momentum of particle. Remaining quantities. Loop back.
65421 1040 DO 1050 J=1,4
65422 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65423 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65424 1050 CONTINUE
65425 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65426 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65427 &GOTO 200
65428 IF(P(I,4).LT.P(I,5)) GOTO 710
65429 KFL(JT)=-KFL(3)
65430 PMQ(JT)=PMQ(3)
65431 PX(JT)=-PX(3)
65432 PY(JT)=-PY(3)
65433 GAM(JT)=GAM(3)
65434 IF(IN(3).NE.IN(3*JT+3)) THEN
65435 DO 1060 J=1,4
65436 P(IN(3*JT+3),J)=P(IN(3),J)
65437 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65438 1060 CONTINUE
65439 ENDIF
65440 DO 1070 JQ=1,2
65441 IN(3*JT+JQ)=IN(JQ)
65442 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65443 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65444 1070 CONTINUE
65445 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65446 &IBARRK(JT)=0
65447 GOTO 870
65448
65449C...Final hadron: side, flavour, hadron, mass.
65450 1080 I=I+1
65451 K(I,1)=1
65452 K(I,3)=IE(JR)
65453 K(I,4)=0
65454 K(I,5)=0
65455 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65456 IF(K(I,2).EQ.0) GOTO 710
65457 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65458 &IBARRK(JT)=0
65459 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65460 &K(I,3)=IJUORI(JT)
65461 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65462 &K(I,3)=IJUORI(JR)
65463 P(I,5)=PYMASS(K(I,2))
65464 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65465
65466C...Final two hadrons: find common setup of four-vectors.
65467 JQ=1
65468 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65469 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65470 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65471 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65472 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65473 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65474 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65475 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65476 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65477 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65478 ENDIF
65479
65480C...Solve kinematics for final two hadrons, if possible.
65481 WREM2=2D0*DHR1*DHR2*DHC12
65482 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65483 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65484 IF(FD.GE.1D0) GOTO 710
65485 FA=WREM2+PR(JT)-PR(JR)
65486 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65487 PREVCF=PARJ(42)
65488 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65489 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65490 FB=SIGN(FB,JS*(PYR(0)-PREV))
65491 KFL1A=IABS(KFL(1))
65492 KFL2A=IABS(KFL(2))
65493 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65494 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65495 &4D0*WREM2*PR(JT))),DBLE(JS))
65496 DO 1090 J=1,4
65497 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65498 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65499 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65500 P(I,J)=P(N+NRS,J)-P(I-1,J)
65501 1090 CONTINUE
65502 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65503 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
65504 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65505 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65506 NTRYFN=NTRYFN+1
65507 IF(NTRYFN.LT.100) GOTO 140
65508 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65509 ENDIF
65510
65511C...Mark jets as fragmented and give daughter pointers.
65512 N=I-NRS+1
65513 DO 1100 I=NSAV+1,NSAV+NP
65514 IM=K(I,3)
65515 K(IM,1)=K(IM,1)+10
65516 IF(MSTU(16).NE.2) THEN
65517 K(IM,4)=NSAV+1
65518 K(IM,5)=NSAV+1
65519 ELSE
65520 K(IM,4)=NSAV+2
65521 K(IM,5)=N
65522 ENDIF
65523 1100 CONTINUE
65524
65525C...Document string system. Move up particles.
65526 NSAV=NSAV+1
65527 K(NSAV,1)=11
65528 K(NSAV,2)=92
65529 K(NSAV,3)=IP
65530 K(NSAV,4)=NSAV+1
65531 K(NSAV,5)=N
65532 DO 1110 J=1,4
65533 P(NSAV,J)=DPS(J)
65534 V(NSAV,J)=V(IP,J)
65535 1110 CONTINUE
65536 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65537 V(NSAV,5)=0D0
65538 DO 1130 I=NSAV+1,N
65539 DO 1120 J=1,5
65540 K(I,J)=K(I+NRS-1,J)
65541 P(I,J)=P(I+NRS-1,J)
65542 V(I,J)=0D0
65543 1120 CONTINUE
65544 1130 CONTINUE
65545 MSTU91=MSTU(90)
65546 DO 1140 IZ=MSTU90+1,MSTU91
65547 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65548 PARU9T(IZ)=PARU(90+IZ)
65549 1140 CONTINUE
65550 MSTU(90)=MSTU90
65551
65552C...Order particles in rank along the chain. Update mother pointer.
65553 DO 1160 I=NSAV+1,N
65554 DO 1150 J=1,5
65555 K(I-NSAV+N,J)=K(I,J)
65556 P(I-NSAV+N,J)=P(I,J)
65557 1150 CONTINUE
65558 1160 CONTINUE
65559 I1=NSAV
65560 DO 1190 I=N+1,2*N-NSAV
65561 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65562 I1=I1+1
65563 DO 1170 J=1,5
65564 K(I1,J)=K(I,J)
65565 P(I1,J)=P(I,J)
65566 1170 CONTINUE
65567 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65568 DO 1180 IZ=MSTU90+1,MSTU91
65569 IF(MSTU9T(IZ).EQ.I) THEN
65570 MSTU(90)=MSTU(90)+1
65571 MSTU(90+MSTU(90))=I1
65572 PARU(90+MSTU(90))=PARU9T(IZ)
65573 ENDIF
65574 1180 CONTINUE
65575 1190 CONTINUE
65576 DO 1220 I=2*N-NSAV,N+1,-1
65577 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65578 I1=I1+1
65579 DO 1200 J=1,5
65580 K(I1,J)=K(I,J)
65581 P(I1,J)=P(I,J)
65582 1200 CONTINUE
65583 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65584 DO 1210 IZ=MSTU90+1,MSTU91
65585 IF(MSTU9T(IZ).EQ.I) THEN
65586 MSTU(90)=MSTU(90)+1
65587 MSTU(90+MSTU(90))=I1
65588 PARU(90+MSTU(90))=PARU9T(IZ)
65589 ENDIF
65590 1210 CONTINUE
65591 1220 CONTINUE
65592
65593C...Boost back particle system. Set production vertices.
65594 IF(MBST.EQ.0) THEN
65595 MSTU(33)=1
65596 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65597 & DPS(3)/DPS(4))
65598 ELSE
65599 DO 1230 I=NSAV+1,N
65600 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65601 IF(P(I,3).GT.0D0) THEN
65602 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65603 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65604 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65605 ELSE
65606 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65607 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65608 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65609 ENDIF
65610 1230 CONTINUE
65611 ENDIF
65612 DO 1250 I=NSAV+1,N
65613 DO 1240 J=1,4
65614 V(I,J)=V(IP,J)
65615 1240 CONTINUE
65616 1250 CONTINUE
65617
65618 RETURN
65619 END
65620
65621C*********************************************************************
65622
65623C...PYJURF
65624C...From three given input vectors in PJU the boost VJU from
65625C...the "lab frame" to the junction rest frame is constructed.
65626
65627 SUBROUTINE PYJURF(PJU,VJU)
65628
65629C...Double precision and integer declarations.
65630 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65631 IMPLICIT INTEGER(I-N)
65632
65633C...Input, output and local arrays.
65634 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65635 DATA TWOPI/6.283186D0/
65636
65637C...Calculate masses and other invariants.
65638 DO 100 J=1,4
65639 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65640 100 CONTINUE
65641 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65642 PSUM(5)=SQRT(PSUM2)
65643 DO 120 I=1,3
65644 DO 110 J=1,3
65645 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65646 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65647 110 CONTINUE
65648 120 CONTINUE
65649
65650C...Pick I to be most massive parton and J to be the one closest to I.
65651 ITRY=0
65652 I=1
65653 IF(A(2,2).GT.A(1,1)) I=2
65654 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65655 130 ITRY=ITRY+1
65656 J=1+MOD(I,3)
65657 K=1+MOD(J,3)
65658 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65659 K=1+MOD(I,3)
65660 J=1+MOD(K,3)
65661 ENDIF
65662 PMI2=A(I,I)
65663 PMJ2=A(J,J)
65664 PMK2=A(K,K)
65665 AIJ=A(I,J)
65666 AIK=A(I,K)
65667 AJK=A(J,K)
65668
65669C...Trivial find new parton energies if all three partons are massless.
65670 IF(PMI2.LT.1D-4) THEN
65671 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65672 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65673 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65674
65675C...Else find momentum range for parton I and values at extremes.
65676 ELSE
65677 PAIMIN=0D0
65678 PEIMIN=SQRT(PMI2)
65679 PEJMIN=AIJ/PEIMIN
65680 PEKMIN=AIK/PEIMIN
65681 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65682 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65683 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65684 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65685 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65686 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65687 HI=PEIMAX**2-0.25D0*PAIMAX**2
65688 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65689 & 0.5D0*PAIMAX*AIJ)/HI
65690 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65691 & 0.5D0*PAIMAX*AIK)/HI
65692 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65693 PEKMAX=SQRT(PAKMAX**2+PMK2)
65694 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65695
65696C...If unexpected values at upper endpoint then pick another parton.
65697 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65698 I1=1+MOD(I,3)
65699 IF(A(I1,I1).GE.1D-4) THEN
65700 I=I1
65701 GOTO 130
65702 ENDIF
65703 ITRY=ITRY+1
65704 I1=1+MOD(I,3)
65705 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65706 I=I1
65707 GOTO 130
65708 ENDIF
65709 ENDIF
65710
65711C..Start binary + linear search to find solution inside range.
65712 ITER=0
65713 ITMIN=0
65714 ITMAX=0
65715 PAI=0.5D0*(PAIMIN+PAIMAX)
65716 140 ITER=ITER+1
65717
65718C...Derive momentum of other two partons and distance to root.
65719 PEI=SQRT(PAI**2+PMI2)
65720 HI=PEI**2-0.25D0*PAI**2
65721 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65722 PEJ=SQRT(PAJ**2+PMJ2)
65723 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65724 PEK=SQRT(PAK**2+PMK2)
65725 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65726
65727C...Pick next I momentum to explore, hopefully closer to root.
65728 IF(FNOW.GT.0D0) THEN
65729 PAIMIN=PAI
65730 FMIN=FNOW
65731 ITMIN=ITMIN+1
65732 ELSE
65733 PAIMAX=PAI
65734 FMAX=FNOW
65735 ITMAX=ITMAX+1
65736 ENDIF
65737 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65738 & THEN
65739 PAI=0.5D0*(PAIMIN+PAIMAX)
65740 GOTO 140
65741 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65742 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65743 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65744 GOTO 140
65745 ENDIF
65746 ENDIF
65747
65748C...Now know energies in junction rest frame.
65749 PENEW(I)=PEI
65750 PENEW(J)=PEJ
65751 PENEW(K)=PEK
65752
65753C...Boost (copy of) partons to their rest frame.
65754 VXCM=-PSUM(1)/PSUM(5)
65755 VYCM=-PSUM(2)/PSUM(5)
65756 VZCM=-PSUM(3)/PSUM(5)
65757 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65758 DO 150 I=1,3
65759 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65760 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65761 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65762 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65763 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65764 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65765 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65766 150 CONTINUE
65767
65768C...Construct difference vectors and boost to junction rest frame.
65769 DO 160 J=1,3
65770 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65771 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65772 160 CONTINUE
65773 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65774 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65775 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65776 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65777 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65778 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65779 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65780 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65781 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65782 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65783 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65784
65785C...Add two boosts, giving final result.
65786 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65787 VJU(1)=VXJU+FCM*VXCM
65788 VJU(2)=VYJU+FCM*VYCM
65789 VJU(3)=VZJU+FCM*VZCM
65790 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65791 VJU(5)=1D0
65792
65793C...In case of error in reconstruction: revert to CM frame of system.
65794 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65795 &(PCM(1,5)*PCM(2,5))
65796 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65797 &(PCM(1,5)*PCM(3,5))
65798 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65799 &(PCM(2,5)*PCM(3,5))
65800 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65801 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65802 DO 170 I=1,3
65803 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65804 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65805 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65806 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65807 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65808 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65809 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65810 170 CONTINUE
65811 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65812 &(PCM(1,5)*PCM(2,5))
65813 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65814 &(PCM(1,5)*PCM(3,5))
65815 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65816 &(PCM(2,5)*PCM(3,5))
65817 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65818 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65819 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65820 VJU(1)=VXCM
65821 VJU(2)=VYCM
65822 VJU(3)=VZCM
65823 VJU(4)=GAMCM
65824 ENDIF
65825
65826 RETURN
65827 END
65828
65829C*********************************************************************
65830
65831C...PYINDF
65832C...Handles the fragmentation of a jet system (or a single
65833C...jet) according to independent fragmentation models.
65834
65835 SUBROUTINE PYINDF(IP)
65836
65837C...Double precision and integer declarations.
65838 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65839 IMPLICIT INTEGER(I-N)
65840 INTEGER PYK,PYCHGE,PYCOMP
65841C...Commonblocks.
65842 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65843 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65844 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65845 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65846C...Local arrays.
65847 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65848 &KFLO(2),PXO(2),PYO(2),WO(2)
65849
65850C.. MOPS error message
65851 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65852 &' are not treated as expected in independent fragmentation')
65853
65854C...Reset counters. Identify parton system and take copy. Check flavour.
65855 NSAV=N
65856 MSTU90=MSTU(90)
65857 NJET=0
65858 KQSUM=0
65859 DO 100 J=1,5
65860 DPS(J)=0D0
65861 100 CONTINUE
65862 I=IP-1
65863 110 I=I+1
65864 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65865 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65866 IF(MSTU(21).GE.1) RETURN
65867 ENDIF
65868 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65869 KC=PYCOMP(K(I,2))
65870 IF(KC.EQ.0) GOTO 110
65871 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65872 IF(KQ.EQ.0) GOTO 110
65873 NJET=NJET+1
65874 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65875 DO 120 J=1,5
65876 K(NSAV+NJET,J)=K(I,J)
65877 P(NSAV+NJET,J)=P(I,J)
65878 DPS(J)=DPS(J)+P(I,J)
65879 120 CONTINUE
65880 K(NSAV+NJET,3)=I
65881 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65882 &K(I+1,1).EQ.2)) GOTO 110
65883 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65884 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65885 IF(MSTU(21).GE.1) RETURN
65886 ENDIF
65887
65888C...Boost copied system to CM frame. Find CM energy and sum flavours.
65889 IF(NJET.NE.1) THEN
65890 MSTU(33)=1
65891 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65892 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65893 ENDIF
65894 PECM=0D0
65895 DO 130 J=1,3
65896 NFI(J)=0
65897 130 CONTINUE
65898 DO 140 I=NSAV+1,NSAV+NJET
65899 PECM=PECM+P(I,4)
65900 KFA=IABS(K(I,2))
65901 IF(KFA.LE.3) THEN
65902 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65903 ELSEIF(KFA.GT.1000) THEN
65904 KFLA=MOD(KFA/1000,10)
65905 KFLB=MOD(KFA/100,10)
65906 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65907 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65908 ENDIF
65909 140 CONTINUE
65910
65911C...Loop over attempts made. Reset counters.
65912 NTRY=0
65913 150 NTRY=NTRY+1
65914 IF(NTRY.GT.200) THEN
65915 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65916 IF(MSTU(21).GE.1) RETURN
65917 ENDIF
65918 N=NSAV+NJET
65919 MSTU(90)=MSTU90
65920 DO 160 J=1,3
65921 NFL(J)=NFI(J)
65922 IFET(J)=0
65923 KFLF(J)=0
65924 160 CONTINUE
65925
65926C...Loop over jets to be fragmented.
65927 DO 230 IP1=NSAV+1,NSAV+NJET
65928 MSTJ(91)=0
65929 NSAV1=N
65930 MSTU91=MSTU(90)
65931
65932C...Initial flavour and momentum values. Jet along +z axis.
65933 KFLH=IABS(K(IP1,2))
65934 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65935 KFLO(2)=0
65936 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65937
65938C...Initial values for quark or diquark jet.
65939 170 IF(IABS(K(IP1,2)).NE.21) THEN
65940 NSTR=1
65941 KFLO(1)=K(IP1,2)
65942 CALL PYPTDI(0,PXO(1),PYO(1))
65943 WO(1)=WF
65944
65945C...Initial values for gluon treated like random quark jet.
65946 ELSEIF(MSTJ(2).LE.2) THEN
65947 NSTR=1
65948 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65949 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65950 CALL PYPTDI(0,PXO(1),PYO(1))
65951 WO(1)=WF
65952
65953C...Initial values for gluon treated like quark-antiquark jet pair,
65954C...sharing energy according to Altarelli-Parisi splitting function.
65955 ELSE
65956 NSTR=2
65957 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65958 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65959 KFLO(2)=-KFLO(1)
65960 CALL PYPTDI(0,PXO(1),PYO(1))
65961 PXO(2)=-PXO(1)
65962 PYO(2)=-PYO(1)
65963 WO(1)=WF*PYR(0)**(1D0/3D0)
65964 WO(2)=WF-WO(1)
65965 ENDIF
65966
65967C...Initial values for rank, flavour, pT and W+.
65968 DO 220 ISTR=1,NSTR
65969 180 I=N
65970 MSTU(90)=MSTU91
65971 IRANK=0
65972 KFL1=KFLO(ISTR)
65973 PX1=PXO(ISTR)
65974 PY1=PYO(ISTR)
65975 W=WO(ISTR)
65976
65977C...New hadron. Generate flavour and hadron species.
65978 190 I=I+1
65979 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65980 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65981 IF(MSTU(21).GE.1) RETURN
65982 ENDIF
65983 IRANK=IRANK+1
65984 K(I,1)=1
65985 K(I,3)=IP1
65986 K(I,4)=0
65987 K(I,5)=0
65988 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
65989 IF(K(I,2).EQ.0) GOTO 180
65990 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
65991 IF(PYR(0).GT.PARJ(19)) GOTO 200
65992 ENDIF
65993
65994C...Find hadron mass. Generate four-momentum.
65995 P(I,5)=PYMASS(K(I,2))
65996 CALL PYPTDI(KFL1,PX2,PY2)
65997 P(I,1)=PX1+PX2
65998 P(I,2)=PY1+PY2
65999 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66000 CALL PYZDIS(KFL1,KFL2,PR,Z)
66001 MZSAV=0
66002 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66003 MZSAV=1
66004 MSTU(90)=MSTU(90)+1
66005 MSTU(90+MSTU(90))=I
66006 PARU(90+MSTU(90))=Z
66007 ENDIF
66008 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66009 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66010 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66011 & P(I,3).LE.0.001D0) THEN
66012 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66013 P(I,3)=0.0001D0
66014 P(I,4)=SQRT(PR)
66015 Z=P(I,4)/W
66016 ENDIF
66017
66018C...Remaining flavour and momentum.
66019 KFL1=-KFL2
66020 PX1=-PX2
66021 PY1=-PY2
66022 W=(1D0-Z)*W
66023 DO 210 J=1,5
66024 V(I,J)=0D0
66025 210 CONTINUE
66026
66027C...Check if pL acceptable. Go back for new hadron if enough energy.
66028 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66029 I=I-1
66030 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66031 ENDIF
66032 IF(W.GT.PARJ(31)) GOTO 190
66033 N=I
66034 220 CONTINUE
66035 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66036 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66037
66038C...Rotate jet to new direction.
66039 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66040 PHI=PYANGL(P(IP1,1),P(IP1,2))
66041 MSTU(33)=1
66042 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66043 K(K(IP1,3),4)=NSAV1+1
66044 K(K(IP1,3),5)=N
66045
66046C...End of jet generation loop. Skip conservation in some cases.
66047 230 CONTINUE
66048 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66049 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66050
66051C...Subtract off produced hadron flavours, finished if zero.
66052 DO 240 I=NSAV+NJET+1,N
66053 KFA=IABS(K(I,2))
66054 KFLA=MOD(KFA/1000,10)
66055 KFLB=MOD(KFA/100,10)
66056 KFLC=MOD(KFA/10,10)
66057 IF(KFLA.EQ.0) THEN
66058 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66059 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66060 ELSE
66061 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66062 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66063 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66064 ENDIF
66065 240 CONTINUE
66066 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66067 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66068 IF(NREQ.EQ.0) GOTO 320
66069
66070C...Take away flavour of low-momentum particles until enough freedom.
66071 NREM=0
66072 250 IREM=0
66073 P2MIN=PECM**2
66074 DO 260 I=NSAV+NJET+1,N
66075 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66076 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66077 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66078 260 CONTINUE
66079 IF(IREM.EQ.0) GOTO 150
66080 K(IREM,1)=7
66081 KFA=IABS(K(IREM,2))
66082 KFLA=MOD(KFA/1000,10)
66083 KFLB=MOD(KFA/100,10)
66084 KFLC=MOD(KFA/10,10)
66085 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66086 IF(K(IREM,1).EQ.8) GOTO 250
66087 IF(KFLA.EQ.0) THEN
66088 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66089 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66090 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66091 ELSE
66092 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66093 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66094 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66095 ENDIF
66096 NREM=NREM+1
66097 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66098 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66099 IF(NREQ.GT.NREM) GOTO 250
66100 DO 270 I=NSAV+NJET+1,N
66101 IF(K(I,1).EQ.8) K(I,1)=1
66102 270 CONTINUE
66103
66104C...Find combination of existing and new flavours for hadron.
66105 280 NFET=2
66106 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66107 IF(NREQ.LT.NREM) NFET=1
66108 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66109 DO 290 J=1,NFET
66110 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66111 KFLF(J)=ISIGN(1,NFL(1))
66112 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66113 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66114 290 CONTINUE
66115 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66116 &GOTO 280
66117 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66118 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66119 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66120 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66121 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66122 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66123 IF(NFET.LE.2) KFLF(3)=0
66124 IF(KFLF(3).NE.0) THEN
66125 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66126 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66127 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66128 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66129 ELSE
66130 KFLFC=KFLF(1)
66131 ENDIF
66132 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66133 IF(KF.EQ.0) GOTO 280
66134 DO 300 J=1,MAX(2,NFET)
66135 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66136 300 CONTINUE
66137
66138C...Store hadron at random among free positions.
66139 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66140 DO 310 I=NSAV+NJET+1,N
66141 IF(K(I,1).EQ.7) NPOS=NPOS-1
66142 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66143 K(I,1)=1
66144 K(I,2)=KF
66145 P(I,5)=PYMASS(K(I,2))
66146 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66147 310 CONTINUE
66148 NREM=NREM-1
66149 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66150 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66151 IF(NREM.GT.0) GOTO 280
66152
66153C...Compensate for missing momentum in global scheme (3 options).
66154 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66155 DO 340 J=1,3
66156 PSI(J)=0D0
66157 DO 330 I=NSAV+NJET+1,N
66158 PSI(J)=PSI(J)+P(I,J)
66159 330 CONTINUE
66160 340 CONTINUE
66161 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66162 PWS=0D0
66163 DO 350 I=NSAV+NJET+1,N
66164 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66165 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66166 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66167 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66168 350 CONTINUE
66169 DO 370 I=NSAV+NJET+1,N
66170 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66171 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66172 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66173 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66174 DO 360 J=1,3
66175 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66176 360 CONTINUE
66177 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66178 370 CONTINUE
66179
66180C...Compensate for missing momentum withing each jet separately.
66181 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66182 DO 390 I=N+1,N+NJET
66183 K(I,1)=0
66184 DO 380 J=1,5
66185 P(I,J)=0D0
66186 380 CONTINUE
66187 390 CONTINUE
66188 DO 410 I=NSAV+NJET+1,N
66189 IR1=K(I,3)
66190 IR2=N+IR1-NSAV
66191 K(IR2,1)=K(IR2,1)+1
66192 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66193 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66194 DO 400 J=1,3
66195 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66196 400 CONTINUE
66197 P(IR2,4)=P(IR2,4)+P(I,4)
66198 P(IR2,5)=P(IR2,5)+PLS
66199 410 CONTINUE
66200 PSS=0D0
66201 DO 420 I=N+1,N+NJET
66202 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66203 420 CONTINUE
66204 DO 440 I=NSAV+NJET+1,N
66205 IR1=K(I,3)
66206 IR2=N+IR1-NSAV
66207 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66208 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66209 DO 430 J=1,3
66210 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66211 & PLS*P(IR1,J)
66212 430 CONTINUE
66213 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66214 440 CONTINUE
66215 ENDIF
66216
66217C...Scale momenta for energy conservation.
66218 IF(MOD(MSTJ(3),5).NE.0) THEN
66219 PMS=0D0
66220 PES=0D0
66221 PQS=0D0
66222 DO 450 I=NSAV+NJET+1,N
66223 PMS=PMS+P(I,5)
66224 PES=PES+P(I,4)
66225 PQS=PQS+P(I,5)**2/P(I,4)
66226 450 CONTINUE
66227 IF(PMS.GE.PECM) GOTO 150
66228 NECO=0
66229 460 NECO=NECO+1
66230 PFAC=(PECM-PQS)/(PES-PQS)
66231 PES=0D0
66232 PQS=0D0
66233 DO 480 I=NSAV+NJET+1,N
66234 DO 470 J=1,3
66235 P(I,J)=PFAC*P(I,J)
66236 470 CONTINUE
66237 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66238 PES=PES+P(I,4)
66239 PQS=PQS+P(I,5)**2/P(I,4)
66240 480 CONTINUE
66241 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66242 ENDIF
66243
66244C...Origin of produced particles and parton daughter pointers.
66245 490 DO 500 I=NSAV+NJET+1,N
66246 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66247 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66248 500 CONTINUE
66249 DO 510 I=NSAV+1,NSAV+NJET
66250 I1=K(I,3)
66251 K(I1,1)=K(I1,1)+10
66252 IF(MSTU(16).NE.2) THEN
66253 K(I1,4)=NSAV+1
66254 K(I1,5)=NSAV+1
66255 ELSE
66256 K(I1,4)=K(I1,4)-NJET+1
66257 K(I1,5)=K(I1,5)-NJET+1
66258 IF(K(I1,5).LT.K(I1,4)) THEN
66259 K(I1,4)=0
66260 K(I1,5)=0
66261 ENDIF
66262 ENDIF
66263 510 CONTINUE
66264
66265C...Document independent fragmentation system. Remove copy of jets.
66266 NSAV=NSAV+1
66267 K(NSAV,1)=11
66268 K(NSAV,2)=93
66269 K(NSAV,3)=IP
66270 K(NSAV,4)=NSAV+1
66271 K(NSAV,5)=N-NJET+1
66272 DO 520 J=1,4
66273 P(NSAV,J)=DPS(J)
66274 V(NSAV,J)=V(IP,J)
66275 520 CONTINUE
66276 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66277 V(NSAV,5)=0D0
66278 DO 540 I=NSAV+NJET,N
66279 DO 530 J=1,5
66280 K(I-NJET+1,J)=K(I,J)
66281 P(I-NJET+1,J)=P(I,J)
66282 V(I-NJET+1,J)=V(I,J)
66283 530 CONTINUE
66284 540 CONTINUE
66285 N=N-NJET+1
66286 DO 550 IZ=MSTU90+1,MSTU(90)
66287 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66288 550 CONTINUE
66289
66290C...Boost back particle system. Set production vertices.
66291 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66292 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66293 DO 570 I=NSAV+1,N
66294 DO 560 J=1,4
66295 V(I,J)=V(IP,J)
66296 560 CONTINUE
66297 570 CONTINUE
66298
66299 RETURN
66300 END
66301
66302C*********************************************************************
66303
66304C...PYDECY
66305C...Handles the decay of unstable particles.
66306
66307 SUBROUTINE PYDECY(IP)
66308
66309C...Double precision and integer declarations.
66310 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66311 IMPLICIT INTEGER(I-N)
66312 INTEGER PYK,PYCHGE,PYCOMP
66313C...Commonblocks.
66314 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66315 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66316 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66317 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66318 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66319C...Local arrays.
66320 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66321 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66322 CHARACTER CIDC*4
66323 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66324
66325C...Functions: momentum in two-particle decays and four-product.
66326 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66327 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)
66328
66329C...Initial values.
66330 NTRY=0
66331 NSAV=N
66332 KFA=IABS(K(IP,2))
66333 KFS=ISIGN(1,K(IP,2))
66334 KC=PYCOMP(KFA)
66335 MSTJ(92)=0
66336
66337C...Choose lifetime and determine decay vertex.
66338 IF(K(IP,1).EQ.5) THEN
66339 V(IP,5)=0D0
66340 ELSEIF(K(IP,1).NE.4) THEN
66341 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66342 ENDIF
66343 DO 100 J=1,4
66344 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66345 100 CONTINUE
66346
66347C...Determine whether decay allowed or not.
66348 MOUT=0
66349 IF(MSTJ(22).EQ.2) THEN
66350 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66351 ELSEIF(MSTJ(22).EQ.3) THEN
66352 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66353 ELSEIF(MSTJ(22).EQ.4) THEN
66354 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66355 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66356 ENDIF
66357 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66358 K(IP,1)=4
66359 RETURN
66360 ENDIF
66361
66362C...Interface to external tau decay library (for tau polarization).
66363 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66364
66365C...Starting values for pointers and momenta.
66366 ITAU=IP
66367 DO 110 J=1,4
66368 PTAU(J)=P(ITAU,J)
66369 PCMTAU(J)=P(ITAU,J)
66370 110 CONTINUE
66371
66372C...Iterate to find position and code of mother of tau.
66373 IMTAU=ITAU
66374 120 IMTAU=K(IMTAU,3)
66375
66376 IF(IMTAU.EQ.0) THEN
66377C...If no known origin then impossible to do anything further.
66378 KFORIG=0
66379 IORIG=0
66380
66381 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66382C...If tau -> tau + gamma then add gamma energy and loop.
66383 IF(K(K(IMTAU,4),2).EQ.22) THEN
66384 DO 130 J=1,4
66385 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66386 130 CONTINUE
66387 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66388 DO 140 J=1,4
66389 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66390 140 CONTINUE
66391 ENDIF
66392 GOTO 120
66393
66394 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66395C...If coming from weak decay of hadron then W is not stored in record,
66396C...but can be reconstructed by adding neutrino momentum.
66397 KFORIG=-ISIGN(24,K(ITAU,2))
66398 IORIG=0
66399 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66400 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66401 DO 150 J=1,4
66402 PCMTAU(J)=PCMTAU(J)+P(II,J)
66403 150 CONTINUE
66404 ENDIF
66405 160 CONTINUE
66406
66407 ELSE
66408C...If coming from resonance decay then find latest copy of this
66409C...resonance (may not completely agree).
66410 KFORIG=K(IMTAU,2)
66411 IORIG=IMTAU
66412 DO 170 II=IMTAU+1,IP-1
66413 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66414 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66415 170 CONTINUE
66416 DO 180 J=1,4
66417 PCMTAU(J)=P(IORIG,J)
66418 180 CONTINUE
66419 ENDIF
66420
66421C...Boost tau to rest frame of production process (where known)
66422C...and rotate it to sit along +z axis.
66423 DO 190 J=1,3
66424 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66425 190 CONTINUE
66426 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66427 & -DBETAU(2),-DBETAU(3))
66428 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66429 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66430 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66431 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66432
66433C...Call tau decay routine (if meaningful) and fill extra info.
66434 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66435 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66436 DO 200 II=NSAV+1,NSAV+NDECAY
66437 K(II,1)=1
66438 K(II,3)=IP
66439 K(II,4)=0
66440 K(II,5)=0
66441 200 CONTINUE
66442 N=NSAV+NDECAY
66443 ENDIF
66444
66445C...Boost back decay tau and decay products.
66446 DO 210 J=1,4
66447 P(ITAU,J)=PTAU(J)
66448 210 CONTINUE
66449 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66450 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66451 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66452 & DBETAU(2),DBETAU(3))
66453
66454C...Skip past ordinary tau decay treatment.
66455 MMAT=0
66456 MBST=0
66457 ND=0
66458 GOTO 630
66459 ENDIF
66460 ENDIF
66461
66462C...B-Bbar mixing: flip sign of meson appropriately.
66463 MMIX=0
66464 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66465 XBBMIX=PARJ(76)
66466 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66467 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66468 IF(MMIX.EQ.1) KFS=-KFS
66469 ENDIF
66470
66471C...Check existence of decay channels. Particle/antiparticle rules.
66472 KCA=KC
66473 IF(MDCY(KC,2).GT.0) THEN
66474 MDMDCY=MDME(MDCY(KC,2),2)
66475 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66476 ENDIF
66477 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66478 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66479 RETURN
66480 ENDIF
66481 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66482 IF(KCHG(KC,3).EQ.0) THEN
66483 KFSP=1
66484 KFSN=0
66485 IF(PYR(0).GT.0.5D0) KFS=-KFS
66486 ELSEIF(KFS.GT.0) THEN
66487 KFSP=1
66488 KFSN=0
66489 ELSE
66490 KFSP=0
66491 KFSN=1
66492 ENDIF
66493
66494C...Sum branching ratios of allowed decay channels.
66495 220 NOPE=0
66496 BRSU=0D0
66497 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66498 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66499 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66500 IF(MDME(IDL,2).GT.100) GOTO 230
66501 NOPE=NOPE+1
66502 BRSU=BRSU+BRAT(IDL)
66503 230 CONTINUE
66504 IF(NOPE.EQ.0) THEN
66505 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66506 RETURN
66507 ENDIF
66508
66509C...Select decay channel among allowed ones.
66510 240 RBR=BRSU*PYR(0)
66511 IDL=MDCY(KCA,2)-1
66512 250 IDL=IDL+1
66513 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66514 &KFSN*MDME(IDL,1).NE.3) THEN
66515 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66516 ELSEIF(MDME(IDL,2).GT.100) THEN
66517 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66518 ELSE
66519 IDC=IDL
66520 RBR=RBR-BRAT(IDL)
66521 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66522 ENDIF
66523
66524C...Start readout of decay channel: matrix element, reset counters.
66525 MMAT=MDME(IDC,2)
66526 260 NTRY=NTRY+1
66527 IF(MOD(NTRY,200).EQ.0) THEN
66528 WRITE(CIDC,'(I4)') IDC
66529C...Do not print warning for some well-known special cases.
66530 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66531 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66532 & CIDC)
66533 GOTO 240
66534 ENDIF
66535 IF(NTRY.GT.1000) THEN
66536 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66537 IF(MSTU(21).GE.1) RETURN
66538 ENDIF
66539 I=N
66540 NP=0
66541 NQ=0
66542 MBST=0
66543 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66544 DO 270 J=1,4
66545 PV(1,J)=0D0
66546 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66547 270 CONTINUE
66548 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66549 PV(1,5)=P(IP,5)
66550 PS=0D0
66551 PSQ=0D0
66552 MREM=0
66553 MHADDY=0
66554 IF(KFA.GT.80) MHADDY=1
66555C.. Random flavour and popcorn system memory.
66556 IRNDMO=0
66557 JTMO=0
66558 MSTU(121)=0
66559 MSTU(125)=10
66560
66561C...Read out decay products. Convert to standard flavour code.
66562 JTMAX=5
66563 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66564 DO 280 JT=1,JTMAX
66565 IF(JT.LE.5) KP=KFDP(IDC,JT)
66566 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66567 IF(KP.EQ.0) GOTO 280
66568 KPA=IABS(KP)
66569 KCP=PYCOMP(KPA)
66570 IF(KPA.GT.80) MHADDY=1
66571 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66572 KFP=KP
66573 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66574 KFP=KFS*KP
66575 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66576 KFP=-KFS*MOD(KFA/10,10)
66577 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66578 KFP=KFS*(100*MOD(KFA/10,100)+3)
66579 ELSEIF(KPA.EQ.81) THEN
66580 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66581 ELSEIF(KP.EQ.82) THEN
66582 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66583 IF(KFP.EQ.0) GOTO 260
66584 KFP=-KFP
66585 IRNDMO=1
66586 MSTJ(93)=1
66587 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66588 ELSEIF(KP.EQ.-82) THEN
66589 KFP=MSTU(124)
66590 ENDIF
66591 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66592
66593C...Add decay product to event record or to quark flavour list.
66594 KFPA=IABS(KFP)
66595 KQP=KCHG(KCP,2)
66596 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66597 NQ=NQ+1
66598 KFLO(NQ)=KFP
66599C...set rndmflav popcorn system pointer
66600 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66601 MSTJ(93)=2
66602 PSQ=PSQ+PYMASS(KFLO(NQ))
66603 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66604 & MOD(NQ,2).EQ.1) THEN
66605 NQ=NQ-1
66606 PS=PS-P(I,5)
66607 K(I,1)=1
66608 KFI=K(I,2)
66609 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66610 IF(K(I,2).EQ.0) GOTO 260
66611 MSTJ(93)=1
66612 P(I,5)=PYMASS(K(I,2))
66613 PS=PS+P(I,5)
66614 ELSE
66615 I=I+1
66616 NP=NP+1
66617 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66618 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66619 K(I,1)=1+MOD(NQ,2)
66620 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66621 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66622 K(I,2)=KFP
66623 K(I,3)=IP
66624 K(I,4)=0
66625 K(I,5)=0
66626 P(I,5)=PYMASS(KFP)
66627 PS=PS+P(I,5)
66628 ENDIF
66629 280 CONTINUE
66630
66631C...Check masses for resonance decays.
66632 IF(MHADDY.EQ.0) THEN
66633 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66634 ENDIF
66635
66636C...Choose decay multiplicity in phase space model.
66637 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66638 PSP=PS
66639 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66640 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66641 300 NTRY=NTRY+1
66642C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66643 IF(IRNDMO.EQ.0) THEN
66644 MSTU(121)=0
66645 JTMO=0
66646 ELSEIF(IRNDMO.EQ.1) THEN
66647 IRNDMO=2
66648 ELSE
66649 GOTO 260
66650 ENDIF
66651 IF(NTRY.GT.1000) THEN
66652 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66653 IF(MSTU(21).GE.1) RETURN
66654 ENDIF
66655 IF(MMAT.LE.20) THEN
66656 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66657 & SIN(PARU(2)*PYR(0))
66658 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66659 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66660 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66661 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66662 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66663 ELSE
66664 ND=MMAT-20
66665 ENDIF
66666C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66667 MSTU(125)=ND-NQ/2
66668 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66669
66670C...Form hadrons from flavour content.
66671 DO 310 JT=1,NQ
66672 KFL1(JT)=KFLO(JT)
66673 310 CONTINUE
66674 IF(ND.EQ.NP+NQ/2) GOTO 330
66675 DO 320 I=N+NP+1,N+ND-NQ/2
66676C.. Stick to started popcorn system, else pick side at random
66677 JT=JTMO
66678 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66679 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66680 IF(K(I,2).EQ.0) GOTO 300
66681 MSTU(125)=MSTU(125)-1
66682 JTMO=0
66683 IF(MSTU(121).GT.0) JTMO=JT
66684 KFL1(JT)=-KFL2
66685 320 CONTINUE
66686 330 JT=2
66687 JT2=3
66688 JT3=4
66689 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66690 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66691 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66692 IF(JT.EQ.3) JT2=2
66693 IF(JT.EQ.4) JT3=2
66694 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66695 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66696 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66697 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66698
66699C...Check that sum of decay product masses not too large.
66700 PS=PSP
66701 DO 340 I=N+NP+1,N+ND
66702 K(I,1)=1
66703 K(I,3)=IP
66704 K(I,4)=0
66705 K(I,5)=0
66706 P(I,5)=PYMASS(K(I,2))
66707 PS=PS+P(I,5)
66708 340 CONTINUE
66709 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66710
66711C...Rescale energy to subtract off spectator quark mass.
66712 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66713 & .AND.NP.GE.3) THEN
66714 PS=PS-P(N+NP,5)
66715 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66716 DO 350 J=1,5
66717 P(N+NP,J)=PQT*PV(1,J)
66718 PV(1,J)=(1D0-PQT)*PV(1,J)
66719 350 CONTINUE
66720 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66721 ND=NP-1
66722 MREM=1
66723
66724C...Fully specified final state: check mass broadening effects.
66725 ELSE
66726 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66727 ND=NP
66728 ENDIF
66729
66730C...Determine position of grandmother, number of sisters.
66731 NM=0
66732 KFAS=0
66733 MSGN=0
66734 IF(MMAT.EQ.3) THEN
66735 IM=K(IP,3)
66736 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66737 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66738 IF(IM.NE.0) THEN
66739 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66740 IF(K(IL,3).EQ.IM) NM=NM+1
66741 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66742 360 CONTINUE
66743 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66744 & MOD(KFAM/1000,10).NE.0) NM=0
66745 IF(NM.EQ.2) THEN
66746 KFAS=IABS(K(ISIS,2))
66747 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66748 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66749 ENDIF
66750 ENDIF
66751 ENDIF
66752
66753C...Kinematics of one-particle decays.
66754 IF(ND.EQ.1) THEN
66755 DO 370 J=1,4
66756 P(N+1,J)=P(IP,J)
66757 370 CONTINUE
66758 GOTO 630
66759 ENDIF
66760
66761C...Calculate maximum weight ND-particle decay.
66762 PV(ND,5)=P(N+ND,5)
66763 IF(ND.GE.3) THEN
66764 WTMAX=1D0/WTCOR(ND-2)
66765 PMAX=PV(1,5)-PS+P(N+ND,5)
66766 PMIN=0D0
66767 DO 380 IL=ND-1,1,-1
66768 PMAX=PMAX+P(N+IL,5)
66769 PMIN=PMIN+P(N+IL+1,5)
66770 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66771 380 CONTINUE
66772 ENDIF
66773
66774C...Find virtual gamma mass in Dalitz decay.
66775 390 IF(ND.EQ.2) THEN
66776 ELSEIF(MMAT.EQ.2) THEN
66777 PMES=4D0*PMAS(11,1)**2
66778 PMRHO2=PMAS(131,1)**2
66779 PGRHO2=PMAS(131,2)**2
66780 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66781 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66782 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66783 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66784 IF(WT.LT.PYR(0)) GOTO 400
66785 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66786
66787C...M-generator gives weight. If rejected, try again.
66788 ELSE
66789 410 RORD(1)=1D0
66790 DO 440 IL1=2,ND-1
66791 RSAV=PYR(0)
66792 DO 420 IL2=IL1-1,1,-1
66793 IF(RSAV.LE.RORD(IL2)) GOTO 430
66794 RORD(IL2+1)=RORD(IL2)
66795 420 CONTINUE
66796 430 RORD(IL2+1)=RSAV
66797 440 CONTINUE
66798 RORD(ND)=0D0
66799 WT=1D0
66800 DO 450 IL=ND-1,1,-1
66801 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66802 & (PV(1,5)-PS)
66803 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66804 450 CONTINUE
66805 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66806 ENDIF
66807
66808C...Perform two-particle decays in respective CM frame.
66809 460 DO 480 IL=1,ND-1
66810 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66811 UE(3)=2D0*PYR(0)-1D0
66812 PHI=PARU(2)*PYR(0)
66813 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66814 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66815 DO 470 J=1,3
66816 P(N+IL,J)=PA*UE(J)
66817 PV(IL+1,J)=-PA*UE(J)
66818 470 CONTINUE
66819 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66820 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66821 480 CONTINUE
66822
66823C...Lorentz transform decay products to lab frame.
66824 DO 490 J=1,4
66825 P(N+ND,J)=PV(ND,J)
66826 490 CONTINUE
66827 DO 530 IL=ND-1,1,-1
66828 DO 500 J=1,3
66829 BE(J)=PV(IL,J)/PV(IL,4)
66830 500 CONTINUE
66831 GA=PV(IL,4)/PV(IL,5)
66832 DO 520 I=N+IL,N+ND
66833 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66834 DO 510 J=1,3
66835 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66836 510 CONTINUE
66837 P(I,4)=GA*(P(I,4)+BEP)
66838 520 CONTINUE
66839 530 CONTINUE
66840
66841C...Check that no infinite loop in matrix element weight.
66842 NTRY=NTRY+1
66843 IF(NTRY.GT.800) GOTO 560
66844
66845C...Matrix elements for omega and phi decays.
66846 IF(MMAT.EQ.1) THEN
66847 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66848 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66849 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66850 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66851
66852C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66853 ELSEIF(MMAT.EQ.2) THEN
66854 FOUR12=FOUR(N+1,N+2)
66855 FOUR13=FOUR(N+1,N+3)
66856 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66857 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66858 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66859
66860C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66861C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66862C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66863 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66864 FOUR10=FOUR(IP,IM)
66865 FOUR12=FOUR(IP,N+1)
66866 FOUR02=FOUR(IM,N+1)
66867 PMS1=P(IP,5)**2
66868 PMS0=P(IM,5)**2
66869 PMS2=P(N+1,5)**2
66870 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66871 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66872 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66873 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66874 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66875 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66876
66877C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66878 ELSEIF(MMAT.EQ.4) THEN
66879 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66880 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66881 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66882 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66883 & ((1D0-HX3)/(HX1*HX2))**2
66884 IF(WT.LT.2D0*PYR(0)) GOTO 390
66885 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66886 & GOTO 390
66887
66888C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66889 ELSEIF(MMAT.EQ.41) THEN
66890 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66891 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66892 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66893 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66894
66895C...Matrix elements for weak decays (only semileptonic for c and b)
66896 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66897 & .AND.ND.EQ.3) THEN
66898 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66899 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66900 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66901 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66902 DO 550 J=1,4
66903 P(N+NP+1,J)=0D0
66904 DO 540 IS=N+3,N+NP
66905 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66906 540 CONTINUE
66907 550 CONTINUE
66908 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66909 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66910 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66911 ENDIF
66912
66913C...Scale back energy and reattach spectator.
66914 560 IF(MREM.EQ.1) THEN
66915 DO 570 J=1,5
66916 PV(1,J)=PV(1,J)/(1D0-PQT)
66917 570 CONTINUE
66918 ND=ND+1
66919 MREM=0
66920 ENDIF
66921
66922C...Low invariant mass for system with spectator quark gives particle,
66923C...not two jets. Readjust momenta accordingly.
66924 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66925 MSTJ(93)=1
66926 PM2=PYMASS(K(N+2,2))
66927 MSTJ(93)=1
66928 PM3=PYMASS(K(N+3,2))
66929 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66930 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66931 K(N+2,1)=1
66932 KFTEMP=K(N+2,2)
66933 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66934 IF(K(N+2,2).EQ.0) GOTO 260
66935 P(N+2,5)=PYMASS(K(N+2,2))
66936 PS=P(N+1,5)+P(N+2,5)
66937 PV(2,5)=P(N+2,5)
66938 MMAT=0
66939 ND=2
66940 GOTO 460
66941 ELSEIF(MMAT.EQ.44) THEN
66942 MSTJ(93)=1
66943 PM3=PYMASS(K(N+3,2))
66944 MSTJ(93)=1
66945 PM4=PYMASS(K(N+4,2))
66946 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66947 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66948 K(N+3,1)=1
66949 KFTEMP=K(N+3,2)
66950 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66951 IF(K(N+3,2).EQ.0) GOTO 260
66952 P(N+3,5)=PYMASS(K(N+3,2))
66953 DO 580 J=1,3
66954 P(N+3,J)=P(N+3,J)+P(N+4,J)
66955 580 CONTINUE
66956 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)
66957 HA=P(N+1,4)**2-P(N+2,4)**2
66958 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66959 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66960 & (P(N+1,3)-P(N+2,3))**2
66961 HD=(PV(1,4)-P(N+3,4))**2
66962 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66963 HF=HD*HC-HB**2
66964 HG=HD*HC-HA*HB
66965 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66966 DO 590 J=1,3
66967 PCOR=HH*(P(N+1,J)-P(N+2,J))
66968 P(N+1,J)=P(N+1,J)+PCOR
66969 P(N+2,J)=P(N+2,J)-PCOR
66970 590 CONTINUE
66971 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)
66972 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)
66973 ND=ND-1
66974 ENDIF
66975
66976C...Check invariant mass of W jets. May give one particle or start over.
66977 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66978 &.AND.IABS(K(N+1,2)).LT.10) THEN
66979 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66980 MSTJ(93)=1
66981 PM1=PYMASS(K(N+1,2))
66982 MSTJ(93)=1
66983 PM2=PYMASS(K(N+2,2))
66984 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
66985 KFLDUM=INT(1.5D0+PYR(0))
66986 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
66987 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
66988 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
66989 PSM=PYMASS(KF1)+PYMASS(KF2)
66990 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
66991 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
66992 IF(MMAT.EQ.48) GOTO 390
66993 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
66994 K(N+1,1)=1
66995 KFTEMP=K(N+1,2)
66996 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
66997 IF(K(N+1,2).EQ.0) GOTO 260
66998 P(N+1,5)=PYMASS(K(N+1,2))
66999 K(N+2,2)=K(N+3,2)
67000 P(N+2,5)=P(N+3,5)
67001 PS=P(N+1,5)+P(N+2,5)
67002 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67003 PV(2,5)=P(N+3,5)
67004 MMAT=0
67005 ND=2
67006 GOTO 460
67007 ENDIF
67008
67009C...Phase space decay of partons from W decay.
67010 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67011 KFLO(1)=K(N+1,2)
67012 KFLO(2)=K(N+2,2)
67013 K(N+1,1)=K(N+3,1)
67014 K(N+1,2)=K(N+3,2)
67015 DO 620 J=1,5
67016 PV(1,J)=P(N+1,J)+P(N+2,J)
67017 P(N+1,J)=P(N+3,J)
67018 620 CONTINUE
67019 PV(1,5)=PMR
67020 N=N+1
67021 NP=0
67022 NQ=2
67023 PS=0D0
67024 MSTJ(93)=2
67025 PSQ=PYMASS(KFLO(1))
67026 MSTJ(93)=2
67027 PSQ=PSQ+PYMASS(KFLO(2))
67028 MMAT=11
67029 GOTO 290
67030 ENDIF
67031
67032C...Boost back for rapidly moving particle.
67033 630 N=N+ND
67034 IF(MBST.EQ.1) THEN
67035 DO 640 J=1,3
67036 BE(J)=P(IP,J)/P(IP,4)
67037 640 CONTINUE
67038 GA=P(IP,4)/P(IP,5)
67039 DO 660 I=NSAV+1,N
67040 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67041 DO 650 J=1,3
67042 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67043 650 CONTINUE
67044 P(I,4)=GA*(P(I,4)+BEP)
67045 660 CONTINUE
67046 ENDIF
67047
67048C...Fill in position of decay vertex.
67049 DO 680 I=NSAV+1,N
67050 DO 670 J=1,4
67051 V(I,J)=VDCY(J)
67052 670 CONTINUE
67053 V(I,5)=0D0
67054 680 CONTINUE
67055
67056C...Set up for parton shower evolution from jets.
67057 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67058 K(NSAV+1,1)=3
67059 K(NSAV+2,1)=3
67060 K(NSAV+3,1)=3
67061 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67062 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67063 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67064 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67065 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67066 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67067 MSTJ(92)=-(NSAV+1)
67068 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67069 K(NSAV+2,1)=3
67070 K(NSAV+3,1)=3
67071 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67072 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67073 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67074 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67075 MSTJ(92)=NSAV+2
67076 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67077 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67078 K(NSAV+1,1)=3
67079 K(NSAV+2,1)=3
67080 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67081 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67082 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67083 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67084 MSTJ(92)=NSAV+1
67085 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67086 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67087 MSTJ(92)=NSAV+1
67088 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67089 & THEN
67090 K(NSAV+1,1)=3
67091 K(NSAV+2,1)=3
67092 K(NSAV+3,1)=3
67093 KCP=PYCOMP(K(NSAV+1,2))
67094 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67095 JCON=4
67096 IF(KQP.LT.0) JCON=5
67097 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67098 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67099 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67100 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67101 MSTJ(92)=NSAV+1
67102 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67103 K(NSAV+1,1)=3
67104 K(NSAV+3,1)=3
67105 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67106 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67107 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67108 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67109 MSTJ(92)=NSAV+1
67110 ENDIF
67111
67112C...Mark decayed particle; special option for B-Bbar mixing.
67113 IF(K(IP,1).EQ.5) K(IP,1)=15
67114 IF(K(IP,1).LE.10) K(IP,1)=11
67115 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67116 K(IP,4)=NSAV+1
67117 K(IP,5)=N
67118
67119 RETURN
67120 END
67121
67122
67123C*********************************************************************
67124
67125C...PYDCYK
67126C...Handles flavour production in the decay of unstable particles
67127C...and small string clusters.
67128
67129 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67130
67131C...Double precision and integer declarations.
67132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67133 IMPLICIT INTEGER(I-N)
67134 INTEGER PYK,PYCHGE,PYCOMP
67135C...Commonblocks.
67136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67138 SAVE /PYDAT1/,/PYDAT2/
67139
67140
67141C.. Call PYKFDI directly if no popcorn option is on
67142 IF(MSTJ(12).LT.2) THEN
67143 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67144 MSTU(124)=KFL3
67145 RETURN
67146 ENDIF
67147
67148 KFL3=0
67149 KF=0
67150 IF(KFL1.EQ.0) RETURN
67151 KF1A=IABS(KFL1)
67152 KF2A=IABS(KFL2)
67153
67154 NSTO=130
67155 NMAX=MIN(MSTU(125),10)
67156
67157C.. Identify rank 0 cluster qq
67158 IRANK=1
67159 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67160
67161 IF(KF2A.GT.0)THEN
67162C.. Join jets: Fails if store not empty
67163 IF(MSTU(121).GT.0) THEN
67164 MSTU(121)=0
67165 RETURN
67166 ENDIF
67167 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67168 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67169C.. Pick popcorn meson from store, return same qq, decrease store
67170 KF=MSTU(NSTO+MSTU(121))
67171 KFL3=-KFL1
67172 MSTU(121)=MSTU(121)-1
67173 ELSE
67174C.. Generate new flavour. Then done if no diquark is generated
67175 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67176 IF(MSTU(121).EQ.-1) GOTO 100
67177 MSTU(124)=KFL3
67178 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67179
67180C.. Simple case if no dynamical popcorn suppressions are considered
67181 IF(MSTJ(12).LT.4) THEN
67182 IF(MSTU(121).EQ.0) RETURN
67183 NMES=1
67184 KFPREV=-KFL3
67185 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67186C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67187 IF(IABS(KFL3).LE.10)THEN
67188 KFL3=-KFPREV
67189 RETURN
67190 ENDIF
67191 GOTO 120
67192 ENDIF
67193
67194C test output qq against fake Gamma, then return if no popcorn.
67195 GB=2D0
67196 IF(IRANK.NE.0)THEN
67197 CALL PYZDIS(1,2103,5D0,Z)
67198 GB=5D0*(1D0-Z)/Z
67199 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67200 MSTU(121)=0
67201 GOTO 100
67202 ENDIF
67203 ENDIF
67204 IF(MSTU(121).EQ.0) RETURN
67205
67206C..Set store size memory. Pick fake dynamical variables of qq.
67207 NMES=MSTU(121)
67208 CALL PYPTDI(1,PX3,PY3)
67209 X=1D0
67210 POPM=0D0
67211 G=GB
67212 POPG=GB
67213
67214C.. Pick next popcorn meson, test with fake dynamical variables
67215 110 KFPREV=-KFL3
67216 PX1=-PX3
67217 PY1=-PY3
67218 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67219 IF(MSTU(121).EQ.-1) GOTO 100
67220 CALL PYPTDI(KFL3,PX3,PY3)
67221 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67222 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67223 G=(1D0-Z)*(G+PM/Z)
67224 X=(1D0-Z)*X
67225
67226 PTST=1D0
67227 GTST=1D0
67228 RTST=PYR(0)
67229 IF(MSTJ(12).GT.4)THEN
67230 POPMN=SQRT((1D0-X)*(G/X-GB))
67231 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67232 PTST=EXP((POPM-POPMN)*PARF(193))
67233 POPM=POPMN
67234 ENDIF
67235 IF(IRANK.NE.0)THEN
67236 POPGN=X*GB
67237 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67238 POPG=POPGN
67239 ENDIF
67240 IF(RTST.GT.PTST*GTST)THEN
67241 MSTU(121)=0
67242 IF(RTST.GT.PTST) MSTU(121)=-1
67243 GOTO 100
67244 ENDIF
67245
67246C.. Store meson
67247 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67248 IF(MSTU(121).GT.0) GOTO 110
67249
67250C.. Test accepted system size. If OK set global popcorn size variable.
67251 IF(NMES.GT.NMAX)THEN
67252 KF=0
67253 KFL3=0
67254 RETURN
67255 ENDIF
67256 MSTU(121)=NMES
67257 ENDIF
67258
67259 RETURN
67260 END
67261
67262C********************************************************************
67263
67264C...PYKFDI
67265C...Generates a new flavour pair and combines off a hadron
67266
67267 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67268
67269C...Double precision and integer declarations.
67270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67271 IMPLICIT INTEGER(I-N)
67272 INTEGER PYK,PYCHGE,PYCOMP
67273C...Commonblocks.
67274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67276 SAVE /PYDAT1/,/PYDAT2/
67277C...Local arrays.
67278 DIMENSION PD(7)
67279
67280 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67281
67282C...Default flavour values. Input consistency checks.
67283 KF1A=IABS(KFL1)
67284 KF2A=IABS(KFL2)
67285 KFL3=0
67286 KF=0
67287 IF(KF1A.EQ.0) RETURN
67288 IF(KF2A.NE.0)THEN
67289 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67290 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67291 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67292 ENDIF
67293
67294C...Check if tabulated flavour probabilities are to be used.
67295 IF(MSTJ(15).EQ.1) THEN
67296 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67297 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67298 & ' together with MSTJ(12)>=5 modification')
67299 KTAB1=-1
67300 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67301 KFL1A=MOD(KF1A/1000,10)
67302 KFL1B=MOD(KF1A/100,10)
67303 KFL1S=MOD(KF1A,10)
67304 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67305 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67306 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67307 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67308 KTAB2=0
67309 IF(KF2A.NE.0) THEN
67310 KTAB2=-1
67311 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67312 KFL2A=MOD(KF2A/1000,10)
67313 KFL2B=MOD(KF2A/100,10)
67314 KFL2S=MOD(KF2A,10)
67315 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67316 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67317 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67318 ENDIF
67319 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67320 ENDIF
67321
67322C.. Recognize rank 0 diquark case
67323 100 IRANK=1
67324 KFDIQ=MAX(KF1A,KF2A)
67325 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67326
67327C.. Join two flavours to meson or baryon. Test for popcorn.
67328 IF(KF2A.GT.0)THEN
67329 MBARY=0
67330 IF(KFDIQ.GT.10) THEN
67331 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67332 & CALL PYNMES(KFDIQ)
67333 IF(MSTU(121).NE.0) THEN
67334 MSTU(121)=0
67335 RETURN
67336 ENDIF
67337 MBARY=2
67338 ENDIF
67339 KFQOLD=KF1A
67340 KFQVER=KF2A
67341 GOTO 130
67342 ENDIF
67343
67344C.. Separate incoming flavours, curtain flavour consistency check
67345 KFIN=KFL1
67346 KFQOLD=KF1A
67347 KFQPOP=KF1A/10000
67348 IF(KF1A.GT.10)THEN
67349 KFIN=-KFL1
67350 KFL1A=MOD(KF1A/1000,10)
67351 KFL1B=MOD(KF1A/100,10)
67352 IF(IRANK.EQ.0)THEN
67353 QAWT=1D0
67354 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67355 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67356 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67357 ENDIF
67358 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67359 MSTU(121)=0
67360 RETURN
67361 ENDIF
67362 KFQOLD=KFL1A+KFL1B-KFQPOP
67363 ENDIF
67364
67365C...Meson/baryon choice. Set number of mesons if starting a popcorn
67366C...system.
67367 110 MBARY=0
67368 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67369 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67370 MBARY=1
67371 CALL PYNMES(0)
67372 ENDIF
67373 ELSEIF(KF1A.GT.10)THEN
67374 MBARY=2
67375 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67376 IF(MSTU(121).GT.0) MBARY=-1
67377 ENDIF
67378
67379C..x->H+q: Choose single vertex quark. Jump to form hadron.
67380 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67381 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67382 KFL3=ISIGN(KFQVER,-KFIN)
67383 GOTO 130
67384 ENDIF
67385
67386C..x->H+qq: (IDW=proper PARF position for diquark weights)
67387 IDW=160
67388 IF(MBARY.EQ.1)THEN
67389 IF(MSTU(121).EQ.0) IDW=150
67390 SQWT=PARF(IDW+1)
67391 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67392 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67393C.. Shift to s-curtain parameters if needed
67394 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67395 PARF(194)=PARF(138)*PARF(139)
67396 PARF(193)=PARJ(8)+PARJ(9)
67397 ENDIF
67398 ENDIF
67399
67400C.. x->H+qq: Get vertex quark
67401 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67402 IDW=MSTU(122)
67403 MSTU(121)=MSTU(121)-1
67404 IF(IDW.EQ.170) THEN
67405 IF(MSTU(121).EQ.0)THEN
67406 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67407 ELSE
67408 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67409 ENDIF
67410 ELSE
67411 IF(MSTU(121).EQ.0)THEN
67412 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67413 ELSE
67414 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67415 ENDIF
67416 ENDIF
67417 IPOS=200+30*IPOS+1
67418
67419 IMES=-1
67420 RMES=PYR(0)*PARF(194)
67421 120 IMES=IMES+1
67422 RMES=RMES-PARF(IPOS+IMES)
67423 IF(IMES.EQ.30) THEN
67424 MSTU(121)=-1
67425 KF=-111
67426 RETURN
67427 ENDIF
67428 IF(RMES.GT.0D0) GOTO 120
67429 KMUL=IMES/5
67430 KFJ=2*KMUL+1
67431 IF(KMUL.EQ.2) KFJ=10003
67432 IF(KMUL.EQ.3) KFJ=10001
67433 IF(KMUL.EQ.4) KFJ=20003
67434 IF(KMUL.EQ.5) KFJ=5
67435 IDIAG=0
67436 KFQVER=MOD(IMES,5)+1
67437 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67438 IF(KFQVER.GT.3)THEN
67439 IDIAG=KFQVER-3
67440 KFQVER=KFQOLD
67441 ENDIF
67442 ELSE
67443 IF(MBARY.EQ.-1) IDW=170
67444 SQWT=PARF(IDW+2)
67445 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67446 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67447 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67448 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67449 KFQVER=KFQPOP
67450 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67451 ENDIF
67452 ENDIF
67453
67454C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67455 KFLDS=3
67456 IF(KFQPOP.NE.KFQVER)THEN
67457 SWT=PARF(IDW+7)
67458 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67459 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67460 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67461 ENDIF
67462 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67463 & +10000*KFQPOP
67464 KFL3=ISIGN(KFDIQ,KFIN)
67465
67466C..x->M+y: flavour for meson.
67467 130 IF(MBARY.LE.0)THEN
67468 KFLA=MAX(KFQOLD,KFQVER)
67469 KFLB=MIN(KFQOLD,KFQVER)
67470 KFS=ISIGN(1,KFL1)
67471 IF(KFLA.NE.KFQOLD) KFS=-KFS
67472C... Form meson, with spin and flavour mixing for diagonal states.
67473 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67474 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67475 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67476 RETURN
67477 ENDIF
67478 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67479 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67480 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67481 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67482 IF(PYR(0).LT.PARJ(14)) KMUL=2
67483 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67484 RMUL=PYR(0)
67485 IF(RMUL.LT.PARJ(15)) KMUL=3
67486 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67487 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67488 ENDIF
67489 KFLS=3
67490 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67491 IF(KMUL.EQ.5) KFLS=5
67492 IF(KFLA.NE.KFLB)THEN
67493 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67494 ELSE
67495 RMIX=PYR(0)
67496 IMIX=2*KFLA+10*KMUL
67497 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67498 & INT(RMIX+PARF(IMIX)))+KFLS
67499 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67500 ENDIF
67501 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67502 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67503
67504C..Optional extra suppression of eta and eta'.
67505C..Allow shift to qq->B+q in old version (set IRANK to 0)
67506 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67507 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67508 IF(KF2A.GT.0) GOTO 130
67509 IF(MSTJ(12).LT.4) IRANK=0
67510 GOTO 110
67511 ENDIF
67512 ENDIF
67513 MSTU(121)=0
67514
67515C.. x->B+y: Flavour for baryon
67516 ELSE
67517 KFLA=KFQVER
67518 IF(KF1A.LE.10) KFLA=KFQOLD
67519 KFLB=MOD(KFDIQ/1000,10)
67520 KFLC=MOD(KFDIQ/100,10)
67521 KFLDS=MOD(KFDIQ,10)
67522 KFLD=MAX(KFLA,KFLB,KFLC)
67523 KFLF=MIN(KFLA,KFLB,KFLC)
67524 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67525
67526C... SU(6) factors for formation of baryon.
67527 KBARY=3
67528 KDMAX=5
67529 KFLG=KFLB
67530 IF(KFLB.NE.KFLC)THEN
67531 KBARY=2*KFLDS-1
67532 KDMAX=1+KFLDS/2
67533 IF(KFLB.GT.2) KDMAX=KDMAX+2
67534 ENDIF
67535 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67536 KBARY=KBARY+1
67537 KFLG=KFLA
67538 ENDIF
67539
67540 SU6MAX=PARF(140+KDMAX)
67541 SU6DEC=PARJ(18)
67542 SU6S =PARF(146)
67543 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67544 SU6MAX=1D0
67545 SU6DEC=1D0
67546 SU6S =1D0
67547 ENDIF
67548 SU6OCT=PARF(60+KBARY)
67549 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67550 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67551 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67552 ELSE
67553 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67554 ENDIF
67555 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67556
67557C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67558 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67559 MSTU(121)=0
67560 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67561 GOTO 110
67562 ENDIF
67563
67564C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67565 KSIG=1
67566 KFLS=2
67567 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67568 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67569 KSIG=KFLDS/3
67570 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67571 ENDIF
67572 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67573 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67574 ENDIF
67575 RETURN
67576
67577C...Use tabulated probabilities to select new flavour and hadron.
67578 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67579 KT3L=1
67580 KT3U=6
67581 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67582 KT3L=1
67583 KT3U=6
67584 ELSEIF(KTAB2.EQ.0) THEN
67585 KT3L=1
67586 KT3U=22
67587 ELSE
67588 KT3L=KTAB2
67589 KT3U=KTAB2
67590 ENDIF
67591 RFL=0D0
67592 DO 160 KTS=0,2
67593 DO 150 KT3=KT3L,KT3U
67594 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67595 150 CONTINUE
67596 160 CONTINUE
67597 RFL=PYR(0)*RFL
67598 DO 180 KTS=0,2
67599 KTABS=KTS
67600 DO 170 KT3=KT3L,KT3U
67601 KTAB3=KT3
67602 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67603 IF(RFL.LE.0D0) GOTO 190
67604 170 CONTINUE
67605 180 CONTINUE
67606 190 CONTINUE
67607
67608C...Reconstruct flavour of produced quark/diquark.
67609 IF(KTAB3.LE.6) THEN
67610 KFL3A=KTAB3
67611 KFL3B=0
67612 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67613 ELSE
67614 KFL3A=1
67615 IF(KTAB3.GE.8) KFL3A=2
67616 IF(KTAB3.GE.11) KFL3A=3
67617 IF(KTAB3.GE.16) KFL3A=4
67618 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67619 KFL3=1000*KFL3A+100*KFL3B+1
67620 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67621 & KFL3+2
67622 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67623 ENDIF
67624
67625C...Reconstruct meson code.
67626 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67627 &KFL3B.NE.0)) THEN
67628 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67629 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67630 KF=110+2*KTABS+1
67631 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67632 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67633 & 25*KTABS)) KF=330+2*KTABS+1
67634 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67635 KFLA=MAX(KTAB1,KTAB3)
67636 KFLB=MIN(KTAB1,KTAB3)
67637 KFS=ISIGN(1,KFL1)
67638 IF(KFLA.NE.KF1A) KFS=-KFS
67639 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67640 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67641 KFS=ISIGN(1,KFL1)
67642 IF(KFL1A.EQ.KFL3A) THEN
67643 KFLA=MAX(KFL1B,KFL3B)
67644 KFLB=MIN(KFL1B,KFL3B)
67645 IF(KFLA.NE.KFL1B) KFS=-KFS
67646 ELSEIF(KFL1A.EQ.KFL3B) THEN
67647 KFLA=KFL3A
67648 KFLB=KFL1B
67649 KFS=-KFS
67650 ELSEIF(KFL1B.EQ.KFL3A) THEN
67651 KFLA=KFL1A
67652 KFLB=KFL3B
67653 ELSEIF(KFL1B.EQ.KFL3B) THEN
67654 KFLA=MAX(KFL1A,KFL3A)
67655 KFLB=MIN(KFL1A,KFL3A)
67656 IF(KFLA.NE.KFL1A) KFS=-KFS
67657 ELSE
67658 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67659 GOTO 100
67660 ENDIF
67661 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67662
67663C...Reconstruct baryon code.
67664 ELSE
67665 IF(KTAB1.GE.7) THEN
67666 KFLA=KFL3A
67667 KFLB=KFL1A
67668 KFLC=KFL1B
67669 ELSE
67670 KFLA=KFL1A
67671 KFLB=KFL3A
67672 KFLC=KFL3B
67673 ENDIF
67674 KFLD=MAX(KFLA,KFLB,KFLC)
67675 KFLF=MIN(KFLA,KFLB,KFLC)
67676 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67677 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67678 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67679 ENDIF
67680
67681C...Check that constructed flavour code is an allowed one.
67682 IF(KFL2.NE.0) KFL3=0
67683 KC=PYCOMP(KF)
67684 IF(KC.EQ.0) THEN
67685 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67686 & 'failed')
67687 GOTO 100
67688 ENDIF
67689
67690 RETURN
67691 END
67692
67693C*********************************************************************
67694
67695C...PYNMES
67696C...Generates number of popcorn mesons and stores some relevant
67697C...parameters.
67698
67699 SUBROUTINE PYNMES(KFDIQ)
67700
67701C...Double precision and integer declarations.
67702 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67703 IMPLICIT INTEGER(I-N)
67704 INTEGER PYK,PYCHGE,PYCOMP
67705C...Commonblocks.
67706 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67707 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67708 SAVE /PYDAT1/,/PYDAT2/
67709
67710 MSTU(121)=0
67711 IF(MSTJ(12).LT.2) RETURN
67712
67713C..Old version: Get 1 or 0 popcorn mesons
67714 IF(MSTJ(12).LT.5)THEN
67715 POPWT=PARF(131)
67716 IF(KFDIQ.NE.0) THEN
67717 KFDIQA=IABS(KFDIQ)
67718 KFA=MOD(KFDIQA/1000,10)
67719 KFB=MOD(KFDIQA/100,10)
67720 KFS=MOD(KFDIQA,10)
67721 POPWT=PARF(132)
67722 IF(KFA.EQ.3) POPWT=PARF(133)
67723 IF(KFB.EQ.3) POPWT=PARF(134)
67724 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67725 ENDIF
67726 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67727 RETURN
67728 ENDIF
67729
67730C..New version: Store popcorn- or rank 0 diquark parameters
67731 MSTU(122)=170
67732 PARF(193)=PARJ(8)
67733 PARF(194)=PARF(139)
67734 IF(KFDIQ.NE.0) THEN
67735 MSTU(122)=180
67736 PARF(193)=PARJ(10)
67737 PARF(194)=PARF(140)
67738 ENDIF
67739 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67740 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67741 & '(PYNMES:) Neglecting too large popcorn possibility')
67742 RETURN
67743 ENDIF
67744
67745C..New version: Get number of popcorn mesons
67746 100 RTST=PYR(0)
67747 MSTU(121)=-1
67748 110 MSTU(121)=MSTU(121)+1
67749 RTST=RTST/PARF(194)
67750 IF(RTST.LT.1D0) GOTO 110
67751 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67752 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67753 RETURN
67754 END
67755
67756C***************************************************************
67757
67758C...PYKFIN
67759C...Precalculates a set of diquark and popcorn weights.
67760
67761 SUBROUTINE PYKFIN
67762
67763C...Double precision and integer declarations.
67764 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67765 IMPLICIT INTEGER(I-N)
67766 INTEGER PYK,PYCHGE,PYCOMP
67767C...Commonblocks.
67768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67770 SAVE /PYDAT1/,/PYDAT2/
67771
67772 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67773
67774
67775 MSTU(123)=1
67776C..Diquark indices for dimensional variables
67777 IUD1=1
67778 IUU1=2
67779 IUS0=3
67780 ISU0=4
67781 IUS1=5
67782 ISU1=6
67783 ISS1=7
67784
67785C.. *** SU(6) factors **
67786C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67787 PARF(146)=1D0
67788 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67789 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67790 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67791 DO 100 I=1,6
67792 SU6(I)=PARF(60+I)
67793 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67794 100 CONTINUE
67795 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67796 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67797 DO 110 I=1,6
67798 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67799 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67800 110 CONTINUE
67801
67802C..SU(6)max q q' s,c,b
67803 SU6MUD =MAX(SU6(1) , SU6(8) )
67804 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67805 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67806 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67807 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67808 SU6M(IUS0)=SU6M(ISU0)
67809 SU6M(ISS1)=SU6M(IUU1)
67810 SU6M(IUS1)=SU6M(ISU1)
67811
67812C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67813 PARF(141)=SU6MUD
67814 PARF(142)=SU6M(IUD1)
67815 PARF(143)=SU6M(ISU0)
67816 PARF(144)=SU6M(ISU1)
67817 PARF(145)=SU6M(ISS1)
67818
67819C..diquark SU(6) survival =
67820C..sum over quark (quark tunnel weight)*(SU(6)).
67821 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67822 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67823 DMB(IUS0)=DMB(ISU0)
67824 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67825 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67826 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67827 DMB(IUS1)=DMB(ISU1)
67828 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67829
67830C.. *** Tunneling factors for Diquark production***
67831C.. T: half a curtain pair = sqrt(curtain pair factor)
67832 IF(MSTJ(12).GE.5) THEN
67833 PMUD0=PYMASS(2101)
67834 PMUD1=PYMASS(2103)-PMUD0
67835 PMUS0=PYMASS(3201)-PMUD0
67836 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67837 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67838 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67839 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67840 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67841 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67842 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67843 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67844 QBB(IUD1)=QBB(IUU1)
67845 ELSE
67846 PAR2M=SQRT(PARJ(2))
67847 PAR3M=SQRT(PARJ(3))
67848 PAR4M=SQRT(PARJ(4))
67849 QBB(ISU0)=PAR2M*PAR3M
67850 QBB(IUS0)=PAR3M
67851 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67852 QBB(IUU1)=PAR4M
67853 QBB(ISU1)=PAR4M*QBB(ISU0)
67854 QBB(IUS1)=PAR4M*QBB(IUS0)
67855 QBB(IUD1)=PAR4M
67856 ENDIF
67857
67858C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67859 QBM(ISU0)=QBB(ISU0)
67860 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67861 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67862 QBM(IUU1)=6D0*QBB(IUU1)
67863 QBM(ISU1)=3D0*QBB(ISU1)
67864 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67865 QBM(IUD1)=3D0*QBB(IUD1)
67866
67867C.. Combine T and tau to diquark weight for q-> B+B+..
67868 DO 120 I=1,7
67869 QBB(I)=QBB(I)*QBM(I)
67870 120 CONTINUE
67871
67872 IF(MSTJ(12).GE.5)THEN
67873C..New version: tau for rank 0 diquark.
67874 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67875 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67876 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67877 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67878 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67879 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67880 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67881
67882C..New version: curtain flavour ratios.
67883C.. s/u for q->B+M+...
67884C.. s/u for rank 0 diquark: su -> ...M+B+...
67885C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67886 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67887 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67888 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67889 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67890 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67891 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67892 ELSE
67893C..Old version: reset unused rank 0 diquark weights and
67894C.. unused diquark SU(6) survival weights
67895 DO 130 I=1,7
67896 IF(MSTJ(12).LT.3) DMB(I)=1D0
67897 DMB(7+I)=1D0
67898 130 CONTINUE
67899
67900C..Old version: Shuffle PARJ(7) into tau
67901 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67902 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67903 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67904
67905C..Old version: curtain flavour ratios.
67906C.. s/u for q->B+M+...
67907C.. s/u for rank 0 diquark: su -> ...M+B+...
67908C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67909 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67910 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67911 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67912 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67913 ENDIF
67914
67915C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67916C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67917 DO 140 I=1,7
67918 DMB(7+I)=DMB(7+I)*DMB(I)
67919 DMB(I)=DMB(I)*QBM(I)
67920 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67921 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67922 140 CONTINUE
67923
67924C.. *** Popcorn factors ***
67925
67926 IF(MSTJ(12).LT.5)THEN
67927C.. Old version: Resulting popcorn weights.
67928 PARF(138)=PARJ(6)
67929 WS=PARF(135)*PARF(138)
67930 WQ=WU*PARJ(5)/3D0
67931 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67932 PARF(133)=WQ*
67933 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67934 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67935 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67936 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67937 & (1D0+QBB(IUD1)+QBB(IUU1)+
67938 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67939 ELSE
67940C..New version: Store weights for popcorn mesons,
67941C..get prel. popcorn weights.
67942 DO 150 IPOS=201,1400
67943 PARF(IPOS)=0D0
67944 150 CONTINUE
67945 DO 160 I=138,140
67946 PARF(I)=0D0
67947 160 CONTINUE
67948 IPOS=200
67949 PARF(193)=PARJ(8)
67950 DO 240 MR=0,7,7
67951 IF(MR.EQ.7) PARF(193)=PARJ(10)
67952 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
67953 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67954 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
67955 DO 230 NMES=0,1
67956 IF(NMES.EQ.1) SQWT=PARJ(2)
67957 DO 220 KFQPOP=1,4
67958 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
67959 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
67960 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
67961 QQWT=0.5D0
67962 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
67963 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
67964 ENDIF
67965 DO 210 KFQOLD =1,5
67966 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
67967 IF(NMES.EQ.1) THEN
67968 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
67969 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
67970 ENDIF
67971 WTTOT=0D0
67972 WTFAIL=0D0
67973 DO 190 KMUL=0,5
67974 PJWT=PARJ(12+KMUL)
67975 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
67976 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
67977 IF(PJWT.LE.0D0) GOTO 190
67978 IF(PJWT.GT.1D0) PJWT=1D0
67979 IMES=5*KMUL
67980 IMIX=2*KFQOLD+10*KMUL
67981 KFJ=2*KMUL+1
67982 IF(KMUL.EQ.2) KFJ=10003
67983 IF(KMUL.EQ.3) KFJ=10001
67984 IF(KMUL.EQ.4) KFJ=20003
67985 IF(KMUL.EQ.5) KFJ=5
67986 DO 180 KFQVER =1,3
67987 KFLA=MAX(KFQOLD,KFQVER)
67988 KFLB=MIN(KFQOLD,KFQVER)
67989 SWT=PARJ(11+KFLA/3+KFLA/4)
67990 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
67991 SWT=SWT*PJWT
67992 QWT=SQWT/(2D0+SQWT)
67993 IF(KFQVER.LT.3)THEN
67994 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
67995 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
67996 ENDIF
67997 IF(KFQVER.NE.KFQOLD)THEN
67998 IMES=IMES+1
67999 KFM=100*KFLA+10*KFLB+KFJ
68000 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68001 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68002 WTTOT=WTTOT+PARF(IPOS+IMES)
68003 ELSE
68004 DO 170 ID=3,5
68005 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68006 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68007 IF(ID.EQ.5) DWT=PARF(IMIX)
68008 KFM=110*(ID-2)+KFJ
68009 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68010 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68011 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68012 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68013 PARF(IPOS+5*KMUL+ID)=
68014 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68015 ENDIF
68016 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68017 170 CONTINUE
68018 ENDIF
68019 180 CONTINUE
68020 190 CONTINUE
68021 DO 200 IMES=1,30
68022 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68023 200 CONTINUE
68024 IF(MR.EQ.7) PARF(140)=
68025 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68026 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68027 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68028 IPOS=IPOS+30
68029 210 CONTINUE
68030 220 CONTINUE
68031 230 CONTINUE
68032 240 CONTINUE
68033 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68034 MSTU(121)=0
68035
68036 ENDIF
68037
68038C..Recombine diquark weights to flavour and spin ratios
68039 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68040 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68041 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68042 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68043 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68044 PARF(155)=QBB(ISU1)/QBB(ISU0)
68045 PARF(156)=QBB(IUS1)/QBB(IUS0)
68046 PARF(157)=QBB(IUD1)
68047
68048 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68049 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68050 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68051 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68052 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68053 PARF(165)=QBM(ISU1)/QBM(ISU0)
68054 PARF(166)=QBM(IUS1)/QBM(IUS0)
68055 PARF(167)=QBM(IUD1)
68056
68057 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68058 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68059 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68060 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68061 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68062 PARF(175)=DMB(ISU1)/DMB(ISU0)
68063 PARF(176)=DMB(IUS1)/DMB(IUS0)
68064 PARF(177)=DMB(IUD1)
68065
68066 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68067 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68068 PARF(187)=DMB(7+IUD1)
68069
68070 RETURN
68071 END
68072
68073
68074C*********************************************************************
68075
68076C...PYPTDI
68077C...Generates transverse momentum according to a Gaussian.
68078
68079 SUBROUTINE PYPTDI(KFL,PX,PY)
68080
68081C...Double precision and integer declarations.
68082 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68083 IMPLICIT INTEGER(I-N)
68084 INTEGER PYK,PYCHGE,PYCOMP
68085C...Commonblocks.
68086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68087 SAVE /PYDAT1/
68088
68089C...Generate p_T and azimuthal angle, gives p_x and p_y.
68090 KFLA=IABS(KFL)
68091 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68092 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68093 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68094 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68095 PHI=PARU(2)*PYR(0)
68096 PX=PT*COS(PHI)
68097 PY=PT*SIN(PHI)
68098
68099 RETURN
68100 END
68101
68102C*********************************************************************
68103
68104C...PYZDIS
68105C...Generates the longitudinal splitting variable z.
68106
68107 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68108
68109C...Double precision and integer declarations.
68110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68111 IMPLICIT INTEGER(I-N)
68112 INTEGER PYK,PYCHGE,PYCOMP
68113C...Commonblocks.
68114 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68115 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68116 SAVE /PYDAT1/,/PYDAT2/
68117
68118C...Check if heavy flavour fragmentation.
68119 KFLA=IABS(KFL1)
68120 KFLB=IABS(KFL2)
68121 KFLH=KFLA
68122 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68123
68124C...Lund symmetric scaling function: determine parameters of shape.
68125 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68126 &MSTJ(11).GE.4) THEN
68127 FA=PARJ(41)
68128 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68129 IF(KFLB.GE.10) FA=FA+PARJ(45)
68130 FBB=PARJ(42)
68131 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68132 FB=FBB*PR
68133 FC=1D0
68134 IF(KFLA.GE.10) FC=FC-PARJ(45)
68135 IF(KFLB.GE.10) FC=FC+PARJ(45)
68136 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68137 FRED=PARJ(46)
68138 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68139 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68140 ENDIF
68141 MC=1
68142 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68143
68144C...Determine position of maximum. Special cases for a = 0 or a = c.
68145 IF(FA.LT.0.02D0) THEN
68146 MA=1
68147 ZMAX=1D0
68148 IF(FC.GT.FB) ZMAX=FB/FC
68149 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68150 MA=2
68151 ZMAX=FB/(FB+FC)
68152 ELSE
68153 MA=3
68154 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68155 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68156 ENDIF
68157
68158C...Subdivide z range if distribution very peaked near endpoint.
68159 MMAX=2
68160 IF(ZMAX.LT.0.1D0) THEN
68161 MMAX=1
68162 ZDIV=2.75D0*ZMAX
68163 IF(MC.EQ.1) THEN
68164 FINT=1D0-LOG(ZDIV)
68165 ELSE
68166 ZDIVC=ZDIV**(1D0-FC)
68167 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68168 ENDIF
68169 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68170 MMAX=3
68171 FSCB=SQRT(4D0+(FC/FB)**2)
68172 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68173 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68174 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68175 FINT=1D0+FB*(1D0-ZDIV)
68176 ENDIF
68177
68178C...Choice of z, preweighted for peaks at low or high z.
68179 100 Z=PYR(0)
68180 FPRE=1D0
68181 IF(MMAX.EQ.1) THEN
68182 IF(FINT*PYR(0).LE.1D0) THEN
68183 Z=ZDIV*Z
68184 ELSEIF(MC.EQ.1) THEN
68185 Z=ZDIV**Z
68186 FPRE=ZDIV/Z
68187 ELSE
68188 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68189 FPRE=(ZDIV/Z)**FC
68190 ENDIF
68191 ELSEIF(MMAX.EQ.3) THEN
68192 IF(FINT*PYR(0).LE.1D0) THEN
68193 Z=ZDIV+LOG(Z)/FB
68194 FPRE=EXP(FB*(Z-ZDIV))
68195 ELSE
68196 Z=ZDIV+Z*(1D0-ZDIV)
68197 ENDIF
68198 ENDIF
68199
68200C...Weighting according to correct formula.
68201 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68202 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68203 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68204 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68205 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68206
68207C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68208 ELSE
68209 FC=PARJ(50+MAX(1,KFLH))
68210 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68211 110 Z=PYR(0)
68212 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68213 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68214 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68215 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68216 & GOTO 110
68217 ELSE
68218 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68219 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68220 ENDIF
68221 ENDIF
68222
68223 RETURN
68224 END
68225
68226C*********************************************************************
68227
68228C...PYSHOW
68229C...Generates timelike parton showers from given partons.
68230
68231 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68232
68233C...Double precision and integer declarations.
68234 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68235 IMPLICIT INTEGER(I-N)
68236 INTEGER PYK,PYCHGE,PYCOMP
68237C...Parameter statement to help give large particle numbers.
68238 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68239 &KEXCIT=4000000,KDIMEN=5000000)
68240 PARAMETER (MAXNUR=1000)
68241C...Commonblocks.
68242 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68243 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68244 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68245 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68246 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68247 COMMON/PYINT1/MINT(400),VINT(400)
68248 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68249C...Local arrays.
68250 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68251 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68252 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68253 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68254 &IREF(1000)
68255
68256C...Check that QMAX not too low.
68257 IF(MSTJ(41).LE.0) THEN
68258 RETURN
68259 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68260 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68261 ELSE
68262 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68263 & RETURN
68264 ENDIF
68265
68266C...Store positions of shower initiating partons.
68267 MPSPD=0
68268 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68269 NPA=1
68270 IPA(1)=IP1
68271 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68272 & MSTU(32))) THEN
68273 NPA=2
68274 IPA(1)=IP1
68275 IPA(2)=IP2
68276 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68277 & .AND.IP2.GE.-80) THEN
68278 NPA=IABS(IP2)
68279 DO 100 I=1,NPA
68280 IPA(I)=IP1+I-1
68281 100 CONTINUE
68282 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68283 &IP2.EQ.-100) THEN
68284 MPSPD=1
68285 NPA=2
68286 IPA(1)=IP1+6
68287 IPA(2)=IP1+7
68288 ELSE
68289 CALL PYERRM(12,
68290 & '(PYSHOW:) failed to reconstruct showering system')
68291 IF(MSTU(21).GE.1) RETURN
68292 ENDIF
68293
68294C...Send off to PYPTFS for pT-ordered evolution if requested,
68295C...if at least 2 partons, and without predefined shower branchings.
68296 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68297 &MPSPD.EQ.0) THEN
68298 NPART=NPA
68299 DO 110 II=1,NPART
68300 IPART(II)=IPA(II)
68301 PTPART(II)=0.5D0*QMAX
68302 110 CONTINUE
68303 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68304 RETURN
68305 ENDIF
68306
68307C...Initialization of cutoff masses etc.
68308 DO 120 IFL=0,40
68309 ISCOL(IFL)=0
68310 ISCHG(IFL)=0
68311 KSH(IFL)=0
68312 120 CONTINUE
68313 ISCOL(21)=1
68314 KSH(21)=1
68315 PMTH(1,21)=PYMASS(21)
68316 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68317 PMTH(3,21)=2D0*PMTH(2,21)
68318 PMTH(4,21)=PMTH(3,21)
68319 PMTH(5,21)=PMTH(3,21)
68320 PMTH(1,22)=PYMASS(22)
68321 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68322 PMTH(3,22)=2D0*PMTH(2,22)
68323 PMTH(4,22)=PMTH(3,22)
68324 PMTH(5,22)=PMTH(3,22)
68325 PMQTH1=PARJ(82)
68326 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68327 PMQT1E=MIN(PMQTH1,PARJ(90))
68328 PMQTH2=PMTH(2,21)
68329 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68330 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68331 DO 130 IFL=1,5
68332 ISCOL(IFL)=1
68333 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68334 KSH(IFL)=1
68335 PMTH(1,IFL)=PYMASS(IFL)
68336 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68337 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68338 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68339 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68340 130 CONTINUE
68341 DO 140 IFL=11,15,2
68342 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68343 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68344 PMTH(1,IFL)=PYMASS(IFL)
68345 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68346 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68347 PMTH(4,IFL)=PMTH(3,IFL)
68348 PMTH(5,IFL)=PMTH(3,IFL)
68349 140 CONTINUE
68350 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68351 ALAMS=PARJ(81)**2
68352 ALFM=LOG(PT2MIN/ALAMS)
68353
68354C...Check on phase space available for emission.
68355 IREJ=0
68356 DO 150 J=1,5
68357 PS(J)=0D0
68358 150 CONTINUE
68359 PM=0D0
68360 KFLA(2)=0
68361 DO 170 I=1,NPA
68362 KFLA(I)=IABS(K(IPA(I),2))
68363 PMA(I)=P(IPA(I),5)
68364C...Special cutoff masses for initial partons (may be a heavy quark,
68365C...squark, ..., and need not be on the mass shell).
68366 IR=30+I
68367 IF(NPA.LE.1) IREF(I)=IR
68368 IF(NPA.GE.2) IREF(I+1)=IR
68369 ISCOL(IR)=0
68370 ISCHG(IR)=0
68371 KSH(IR)=0
68372 IF(KFLA(I).LE.8) THEN
68373 ISCOL(IR)=1
68374 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68375 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68376 & KFLA(I).EQ.17) THEN
68377 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68378 ELSEIF(KFLA(I).EQ.21) THEN
68379 ISCOL(IR)=1
68380 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68381 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68382 ISCOL(IR)=1
68383 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68384 ISCOL(IR)=1
68385C...QUARKONIA+++
68386C...same for QQ~[3S18]
68387 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68388 & KFLA(I).EQ.9900553)) THEN
68389 ISCOL(IR)=1
68390C...QUARKONIA---
68391 ENDIF
68392
68393C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68394C...(only intended for studying the effects of switching such rad on/off)
68395 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68396 ISCOL(IR)=0
68397 ISCHG(IR)=0
68398 ENDIF
68399
68400 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68401 PMTH(1,IR)=PMA(I)
68402 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68403 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68404 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68405 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68406 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68407 ELSEIF(ISCOL(IR).EQ.1) THEN
68408 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68409 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68410 PMTH(4,IR)=PMTH(3,IR)
68411 PMTH(5,IR)=PMTH(3,IR)
68412 ELSEIF(ISCHG(IR).EQ.1) THEN
68413 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68414 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68415 PMTH(4,IR)=PMTH(3,IR)
68416 PMTH(5,IR)=PMTH(3,IR)
68417 ENDIF
68418 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68419 PM=PM+PMA(I)
68420 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68421 DO 160 J=1,4
68422 PS(J)=PS(J)+P(IPA(I),J)
68423 160 CONTINUE
68424 170 CONTINUE
68425 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68426 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68427 IF(NPA.EQ.1) PS(5)=PS(4)
68428 IF(PS(5).LE.PM+PMQT1E) RETURN
68429
68430C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68431 KFSRCE=0
68432 IF(IP2.LE.0) THEN
68433 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68434 KFSRCE=IABS(K(K(IP1,3),2))
68435 ELSE
68436 IPAR1=MAX(1,K(IP1,3))
68437 IPAR2=MAX(1,K(IP2,3))
68438 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68439 & KFSRCE=IABS(K(K(IPAR1,3),2))
68440 ENDIF
68441 ITYPES=0
68442 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68443 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68444 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68445 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68446 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68447 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68448 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68449 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68450
68451C...Identify two primary showerers.
68452 ITYPE1=0
68453 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68454 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68455 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68456 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68457 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68458 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68459 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68460 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68461 ITYPE2=0
68462 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68463 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68464 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68465 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68466 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68467 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68468 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68469 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68470
68471C...Order of showerers. Presence of gluino.
68472 ITYPMN=MIN(ITYPE1,ITYPE2)
68473 ITYPMX=MAX(ITYPE1,ITYPE2)
68474 IORD=1
68475 IF(ITYPE1.GT.ITYPE2) IORD=2
68476 IGLUI=0
68477 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68478
68479C...Check if 3-jet matrix elements to be used.
68480 M3JC=0
68481 ALPHA=0.5D0
68482 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68483 IF(MSTJ(38).NE.0) THEN
68484 M3JC=MSTJ(38)
68485 ALPHA=PARJ(80)
68486 MSTJ(38)=0
68487 ELSEIF(MSTJ(47).GE.6) THEN
68488 M3JC=MSTJ(47)
68489 ELSE
68490 ICLASS=1
68491 ICOMBI=4
68492
68493C...Vector/axial vector -> q + qbar; q -> q + V.
68494 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68495 & ITYPES.EQ.3)) THEN
68496 ICLASS=2
68497 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68498 ICOMBI=1
68499 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68500 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68501C...gamma*/Z0: assume e+e- initial state if unknown.
68502 EI=-1D0
68503 IF(KFSRCE.EQ.23) THEN
68504 IANNFL=K(K(IP1,3),3)
68505 IF(IANNFL.NE.0) THEN
68506 KANNFL=IABS(K(IANNFL,2))
68507 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68508 ENDIF
68509 ENDIF
68510 AI=SIGN(1D0,EI+0.1D0)
68511 VI=AI-4D0*EI*PARU(102)
68512 EF=KCHG(KFLA(1),1)/3D0
68513 AF=SIGN(1D0,EF+0.1D0)
68514 VF=AF-4D0*EF*PARU(102)
68515 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68516 SH=PS(5)**2
68517 SQMZ=PMAS(23,1)**2
68518 SQWZ=PS(5)*PMAS(23,2)
68519 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68520 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68521 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68522 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68523 ICOMBI=3
68524 ALPHA=VECT/(VECT+AXIV)
68525 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68526 ICOMBI=4
68527 ENDIF
68528C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68529 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68530 ICLASS=2
68531 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68532 & ITYPES.EQ.1)) THEN
68533 ICLASS=3
68534
68535C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68536 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68537 ICLASS=4
68538 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68539 ICOMBI=1
68540 ELSEIF(KFSRCE.EQ.36) THEN
68541 ICOMBI=2
68542 ENDIF
68543 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68544 & ITYPES.EQ.1)) THEN
68545 ICLASS=5
68546
68547C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68548 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68549 & ITYPES.EQ.3)) THEN
68550 ICLASS=6
68551 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68552 & ITYPES.EQ.2)) THEN
68553 ICLASS=7
68554 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68555 ICLASS=8
68556 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68557 & ITYPES.EQ.2)) THEN
68558 ICLASS=9
68559
68560C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68561 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68562 & ITYPES.EQ.5)) THEN
68563 ICLASS=10
68564 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68565 & ITYPES.EQ.2)) THEN
68566 ICLASS=11
68567 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68568 & ITYPES.EQ.1)) THEN
68569 ICLASS=12
68570
68571C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68572 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68573 ICLASS=13
68574 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68575 & ITYPES.EQ.2)) THEN
68576 ICLASS=14
68577 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68578 & ITYPES.EQ.1)) THEN
68579 ICLASS=15
68580
68581C...g -> ~g + ~g (eikonal approximation).
68582 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68583 ICLASS=16
68584 ENDIF
68585 M3JC=5*ICLASS+ICOMBI
68586 ENDIF
68587 ENDIF
68588
68589C...Find if interference with initial state partons.
68590 MIIS=0
68591 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68592 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68593 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68594 &MIIS=MSTJ(50)-3
68595 IF(MIIS.NE.0) THEN
68596 DO 190 I=1,2
68597 KCII(I)=0
68598 KCA=PYCOMP(KFLA(I))
68599 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68600 NIIS(I)=0
68601 IF(KCII(I).NE.0) THEN
68602 DO 180 J=1,2
68603 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68604 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68605 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68606 NIIS(I)=NIIS(I)+1
68607 IIIS(I,NIIS(I))=ICSI
68608 ENDIF
68609 180 CONTINUE
68610 ENDIF
68611 190 CONTINUE
68612 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68613 ENDIF
68614
68615C...Boost interfering initial partons to rest frame
68616C...and reconstruct their polar and azimuthal angles.
68617 IF(MIIS.NE.0) THEN
68618 DO 210 I=1,2
68619 DO 200 J=1,5
68620 K(N+I,J)=K(IPA(I),J)
68621 P(N+I,J)=P(IPA(I),J)
68622 V(N+I,J)=0D0
68623 200 CONTINUE
68624 210 CONTINUE
68625 DO 230 I=3,2+NIIS(1)
68626 DO 220 J=1,5
68627 K(N+I,J)=K(IIIS(1,I-2),J)
68628 P(N+I,J)=P(IIIS(1,I-2),J)
68629 V(N+I,J)=0D0
68630 220 CONTINUE
68631 230 CONTINUE
68632 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68633 DO 240 J=1,5
68634 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68635 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68636 V(N+I,J)=0D0
68637 240 CONTINUE
68638 250 CONTINUE
68639 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68640 & -PS(2)/PS(4),-PS(3)/PS(4))
68641 PHI=PYANGL(P(N+1,1),P(N+1,2))
68642 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68643 THE=PYANGL(P(N+1,3),P(N+1,1))
68644 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68645 DO 260 I=3,2+NIIS(1)
68646 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68647 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68648 260 CONTINUE
68649 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68650 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68651 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68652 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68653 270 CONTINUE
68654 ENDIF
68655
68656C...Boost 3 or more partons to their rest frame.
68657 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68658 &-PS(2)/PS(4),-PS(3)/PS(4))
68659
68660C...Define imagined single initiator of shower for parton system.
68661 NS=N
68662 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68663 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68664 IF(MSTU(21).GE.1) RETURN
68665 ENDIF
68666 280 N=NS
68667 IF(NPA.GE.2) THEN
68668 K(N+1,1)=11
68669 K(N+1,2)=21
68670 K(N+1,3)=0
68671 K(N+1,4)=0
68672 K(N+1,5)=0
68673 P(N+1,1)=0D0
68674 P(N+1,2)=0D0
68675 P(N+1,3)=0D0
68676 P(N+1,4)=PS(5)
68677 P(N+1,5)=PS(5)
68678 V(N+1,5)=PS(5)**2
68679 N=N+1
68680 IREF(1)=21
68681 ENDIF
68682
68683C...Loop over partons that may branch.
68684 NEP=NPA
68685 IM=NS
68686 IF(NPA.EQ.1) IM=NS-1
68687 290 IM=IM+1
68688 IF(N.GT.NS) THEN
68689 IF(IM.GT.N) GOTO 600
68690 KFLM=IABS(K(IM,2))
68691 IR=IREF(IM-NS)
68692 IF(KSH(IR).EQ.0) GOTO 290
68693 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68694 IGM=K(IM,3)
68695 ELSE
68696 IGM=-1
68697 ENDIF
68698 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68699 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68700 IF(MSTU(21).GE.1) RETURN
68701 ENDIF
68702
68703C...Position of aunt (sister to branching parton).
68704C...Origin and flavour of daughters.
68705 IAU=0
68706 IF(IGM.GT.0) THEN
68707 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68708 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68709 ENDIF
68710 IF(IGM.GE.0) THEN
68711 K(IM,4)=N+1
68712 DO 300 I=1,NEP
68713 K(N+I,3)=IM
68714 300 CONTINUE
68715 ELSE
68716 K(N+1,3)=IPA(1)
68717 ENDIF
68718 IF(IGM.LE.0) THEN
68719 DO 310 I=1,NEP
68720 K(N+I,2)=K(IPA(I),2)
68721 310 CONTINUE
68722 ELSEIF(KFLM.NE.21) THEN
68723 K(N+1,2)=K(IM,2)
68724 K(N+2,2)=K(IM,5)
68725 IREF(N+1-NS)=IREF(IM-NS)
68726 IREF(N+2-NS)=IABS(K(N+2,2))
68727 ELSEIF(K(IM,5).EQ.21) THEN
68728 K(N+1,2)=21
68729 K(N+2,2)=21
68730 IREF(N+1-NS)=21
68731 IREF(N+2-NS)=21
68732 ELSE
68733 K(N+1,2)=K(IM,5)
68734 K(N+2,2)=-K(IM,5)
68735 IREF(N+1-NS)=IABS(K(N+1,2))
68736 IREF(N+2-NS)=IABS(K(N+2,2))
68737 ENDIF
68738
68739C...Reset flags on daughters and tries made.
68740 DO 320 IP=1,NEP
68741 K(N+IP,1)=3
68742 K(N+IP,4)=0
68743 K(N+IP,5)=0
68744 KFLD(IP)=IABS(K(N+IP,2))
68745 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68746 ITRY(IP)=0
68747 ISL(IP)=0
68748 ISI(IP)=0
68749 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68750 320 CONTINUE
68751 ISLM=0
68752
68753C...Maximum virtuality of daughters.
68754 IF(IGM.LE.0) THEN
68755 DO 330 I=1,NPA
68756 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68757 P(N+I,5)=MIN(QMAX,PS(5))
68758 IR=IREF(N+I-NS)
68759 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68760 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68761 330 CONTINUE
68762 ELSE
68763 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68764 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68765 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68766 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68767 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68768 ENDIF
68769 DO 340 I=1,NEP
68770 PMSD(I)=P(N+I,5)
68771 IF(ISI(I).EQ.1) THEN
68772 IR=IREF(N+I-NS)
68773 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68774 ENDIF
68775 V(N+I,5)=P(N+I,5)**2
68776 340 CONTINUE
68777
68778C...Choose one of the daughters for evolution.
68779 350 INUM=0
68780 IF(NEP.EQ.1) INUM=1
68781 DO 360 I=1,NEP
68782 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68783 360 CONTINUE
68784 DO 370 I=1,NEP
68785 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68786 IR=IREF(N+I-NS)
68787 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68788 ENDIF
68789 370 CONTINUE
68790 IF(INUM.EQ.0) THEN
68791 RMAX=0D0
68792 DO 380 I=1,NEP
68793 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68794 RPM=P(N+I,5)/PMSD(I)
68795 IR=IREF(N+I-NS)
68796 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68797 RMAX=RPM
68798 INUM=I
68799 ENDIF
68800 ENDIF
68801 380 CONTINUE
68802 ENDIF
68803
68804C...Cancel choice of predetermined daughter already treated.
68805 INUM=MAX(1,INUM)
68806 INUMT=INUM
68807 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68808 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68809 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68810 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68811 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68812 ENDIF
68813
68814C...Store information on choice of evolving daughter.
68815 IEP(1)=N+INUM
68816 DO 390 I=2,NEP
68817 IEP(I)=IEP(I-1)+1
68818 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68819 390 CONTINUE
68820 DO 400 I=1,NEP
68821 KFL(I)=IABS(K(IEP(I),2))
68822 400 CONTINUE
68823 ITRY(INUM)=ITRY(INUM)+1
68824 IF(ITRY(INUM).GT.200) THEN
68825 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68826 IF(MSTU(21).GE.1) RETURN
68827 ENDIF
68828 Z=0.5D0
68829 IR=IREF(IEP(1)-NS)
68830 IF(KSH(IR).EQ.0) GOTO 450
68831 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68832
68833C...Check if evolution already predetermined for daughter.
68834 IPSPD=0
68835 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68836 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68837 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68838 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68839 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68840 ENDIF
68841 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68842 ISSET(INUM)=0
68843 IF(IPSPD.NE.0) ISSET(INUM)=1
68844 ENDIF
68845
68846C...Select side for interference with initial state partons.
68847 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68848 III=IEP(1)-NS-1
68849 ISII(III)=0
68850 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68851 ISII(III)=1
68852 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68853 IF(PYR(0).GT.0.5D0) ISII(III)=1
68854 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68855 ISII(III)=1
68856 IF(PYR(0).GT.0.5D0) ISII(III)=2
68857 ENDIF
68858 ENDIF
68859
68860C...Calculate allowed z range.
68861 IF(NEP.EQ.1) THEN
68862 PMED=PS(4)
68863 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68864 PMED=P(IM,5)
68865 ELSE
68866 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68867 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68868 ENDIF
68869 IF(MOD(MSTJ(43),2).EQ.1) THEN
68870 ZC=PMTH(2,21)/PMED
68871 ZCE=PMTH(2,22)/PMED
68872 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68873 ELSE
68874 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68875 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68876 PMTMPE=PMTH(2,22)
68877 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68878 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68879 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68880 ENDIF
68881 ZC=MIN(ZC,0.491D0)
68882 ZCE=MIN(ZCE,0.49991D0)
68883 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68884 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68885 P(IEP(1),5)=PMTH(1,IR)
68886 V(IEP(1),5)=P(IEP(1),5)**2
68887 GOTO 450
68888 ENDIF
68889
68890C...Integral of Altarelli-Parisi z kernel for QCD.
68891C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68892 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68893 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68894C...QUARKONIA+++
68895C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68896 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68897 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68898 FBR=6D0*LOG((1D0-ZC)/ZC)
68899C...QUARKONIA---
68900 ELSEIF(MSTJ(49).EQ.0) THEN
68901 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68902 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68903
68904C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68905 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68906 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68907 ELSEIF(MSTJ(49).EQ.1) THEN
68908 FBR=(1D0-2D0*ZC)/3D0
68909 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68910
68911C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68912 ELSEIF(KFL(1).EQ.21) THEN
68913 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68914 ELSE
68915 FBR=2D0*LOG((1D0-ZC)/ZC)
68916 ENDIF
68917
68918C...Reset QCD probability for colourless.
68919 IF(ISCOL(IR).EQ.0) FBR=0D0
68920
68921C...Integral of Altarelli-Parisi kernel for photon emission.
68922 FBRE=0D0
68923 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68924 IF(KFL(1).LE.18) THEN
68925 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68926 ENDIF
68927 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68928 ENDIF
68929
68930C...Inner veto algorithm starts. Find maximum mass for evolution.
68931 410 PMS=V(IEP(1),5)
68932 IF(IGM.GE.0) THEN
68933 PM2=0D0
68934 DO 420 I=2,NEP
68935 PM=P(IEP(I),5)
68936 IRI=IREF(IEP(I)-NS)
68937 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68938 PM2=PM2+PM
68939 420 CONTINUE
68940 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68941 ENDIF
68942
68943C...Select mass for daughter in QCD evolution.
68944 B0=27D0/6D0
68945 DO 430 IFF=4,MSTJ(45)
68946 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
68947 430 CONTINUE
68948C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68949 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
68950C...Already predetermined choice.
68951 IF(IPSPD.NE.0) THEN
68952 PMSQCD=P(IPSPD,5)**2
68953 ELSEIF(FBR.LT.1D-3) THEN
68954 PMSQCD=0D0
68955 ELSEIF(MSTJ(44).LE.0) THEN
68956 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
68957 ELSEIF(MSTJ(44).EQ.1) THEN
68958 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
68959 ELSE
68960 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
68961 ENDIF
68962C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68963 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
68964 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
68965 V(IEP(1),5)=PMSQCD
68966 MCE=1
68967
68968C...Select mass for daughter in QED evolution.
68969 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
68970C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
68971 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
68972 IF(FBRE.LT.1D-3) THEN
68973 PMSQED=0D0
68974 ELSE
68975 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
68976 & (PARU(101)*FBRE)))
68977 ENDIF
68978C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
68979 PMSQED=PMSQED+PMTH(1,IR)**2
68980 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
68981 & PMTH(2,IR)**2
68982 IF(PMSQED.GT.PMSQCD) THEN
68983 V(IEP(1),5)=PMSQED
68984 MCE=2
68985 ENDIF
68986 ENDIF
68987
68988C...Check whether daughter mass below cutoff.
68989 P(IEP(1),5)=SQRT(V(IEP(1),5))
68990 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
68991 P(IEP(1),5)=PMTH(1,IR)
68992 V(IEP(1),5)=P(IEP(1),5)**2
68993 GOTO 450
68994 ENDIF
68995
68996C...Already predetermined choice of z, and flavour in g -> qqbar.
68997 IF(IPSPD.NE.0) THEN
68998 IPSGD1=K(IPSPD,4)
68999 IPSGD2=K(IPSPD,5)
69000 PMSGD1=P(IPSGD1,5)**2
69001 PMSGD2=P(IPSGD2,5)**2
69002 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69003 & 4D0*PMSGD1*PMSGD2))
69004 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69005 & PMSGD1+PMSGD2)/ALAMPS
69006 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69007 IF(KFL(1).NE.21) THEN
69008 K(IEP(1),5)=21
69009 ELSE
69010 K(IEP(1),5)=IABS(K(IPSGD1,2))
69011 ENDIF
69012
69013C...Select z value of branching: q -> qgamma.
69014 ELSEIF(MCE.EQ.2) THEN
69015 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69016 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69017 K(IEP(1),5)=22
69018
69019C...QUARKONIA+++
69020C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69021 ELSEIF(MSTJ(49).EQ.0.AND.
69022 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69023 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69024C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69025 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69026 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69027 K(IEP(1),5)=21
69028C...QUARKONIA---
69029
69030C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69031 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69032 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69033C...Only do z weighting when no ME correction afterwards.
69034 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69035 K(IEP(1),5)=21
69036 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69037 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69038 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69039 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69040 K(IEP(1),5)=21
69041 ELSEIF(MSTJ(49).NE.1) THEN
69042 Z=PYR(0)
69043 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69044 KFLB=1+INT(MSTJ(45)*PYR(0))
69045 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69046 IF(PMQ.GE.1D0) GOTO 410
69047 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69048 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69049 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69050 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69051 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69052 ELSE
69053 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69054 ENDIF
69055 K(IEP(1),5)=KFLB
69056
69057C...Ditto for scalar gluon model.
69058 ELSEIF(KFL(1).NE.21) THEN
69059 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69060 K(IEP(1),5)=21
69061 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69062 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69063 K(IEP(1),5)=21
69064 ELSE
69065 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69066 KFLB=1+INT(MSTJ(45)*PYR(0))
69067 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69068 IF(PMQ.GE.1D0) GOTO 410
69069 K(IEP(1),5)=KFLB
69070 ENDIF
69071
69072C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69073 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69074 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69075 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69076 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69077 ELSE
69078 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69079 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69080 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69081 IF(PT2APP.LT.PT2MIN) GOTO 410
69082 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69083 ENDIF
69084 ENDIF
69085
69086C...Check if z consistent with chosen m.
69087 IF(KFL(1).EQ.21) THEN
69088 IRGD1=IABS(K(IEP(1),5))
69089 IRGD2=IRGD1
69090 ELSE
69091 IRGD1=IR
69092 IRGD2=IABS(K(IEP(1),5))
69093 ENDIF
69094 IF(NEP.EQ.1) THEN
69095 PED=PS(4)
69096 ELSEIF(NEP.GE.3) THEN
69097 PED=P(IEP(1),4)
69098 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69099 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69100 ELSE
69101 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69102 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69103 ENDIF
69104 IF(MOD(MSTJ(43),2).EQ.1) THEN
69105 PMQTH3=0.5D0*PARJ(82)
69106 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69107 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69108 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69109 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69110 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69111 & 4D0*PMQ1*PMQ2)))
69112 ZH=1D0+PMQ1-PMQ2
69113 ELSE
69114 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69115 ZH=1D0
69116 ENDIF
69117 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69118 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69119 ELSEIF(IPSPD.NE.0) THEN
69120 ELSE
69121 ZL=0.5D0*(ZH-ZD)
69122 ZU=0.5D0*(ZH+ZD)
69123 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69124 ENDIF
69125 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69126 &(1D0-ZU)))
69127 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69128
69129C...Width suppression for q -> q + g.
69130 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69131 IF(IGM.EQ.0) THEN
69132 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69133 ELSE
69134 EGLU=PMED*(1D0-Z)
69135 ENDIF
69136 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69137 IF(MSTJ(40).EQ.1) THEN
69138 IF(CHI.LT.PYR(0)) GOTO 410
69139 ELSEIF(MSTJ(40).EQ.2) THEN
69140 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69141 ENDIF
69142 ENDIF
69143
69144C...Three-jet matrix element correction.
69145 IF(M3JC.GE.1) THEN
69146 WME=1D0
69147 WSHOW=1D0
69148
69149C...QED matrix elements: only for massless case so far.
69150 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69151 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69152 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69153 X3=(1D0-X1)+(1D0-X2)
69154 KI1=K(IPA(INUM),2)
69155 KI2=K(IPA(3-INUM),2)
69156 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69157 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69158 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69159 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69160 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69161 ELSEIF(MCE.EQ.2) THEN
69162
69163C...QCD matrix elements, including mass effects.
69164 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69165 PS1ME=V(IEP(1),5)
69166 PM1ME=PMTH(1,IR)
69167 M3JCC=M3JC
69168 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69169C...QCD ME: original parton, first branching.
69170 PM2ME=PMTH(1,63-IR)
69171 ECMME=PS(5)
69172 ELSEIF(IR.GE.31) THEN
69173C...QCD ME: original parton, subsequent branchings.
69174 PM2ME=PMTH(1,63-IR)
69175 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69176 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69177 ELSEIF(K(IM,2).EQ.21) THEN
69178C...QCD ME: secondary partons, first branching.
69179 PM2ME=PM1ME
69180 ZMME=V(IM,1)
69181 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69182 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69183 & 4D0*PS1ME*PM2ME**2))
69184 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69185 & V(IM,5)
69186 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69187 M3JCC=66
69188 ELSE
69189C...QCD ME: secondary partons, subsequent branchings.
69190 PM2ME=PM1ME
69191 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69192 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69193 M3JCC=66
69194 ENDIF
69195C...Construct ME variables.
69196 R1ME=PM1ME/ECMME
69197 R2ME=PM2ME/ECMME
69198 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69199 X2=1D0+R2ME**2-PS1ME/ECMME**2
69200C...Call ME, with right order important for two inequivalent showerers.
69201 IF(IR.EQ.IORD+30) THEN
69202 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69203 ELSE
69204 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69205 ENDIF
69206C...Split up total ME when two radiating partons.
69207 ISPRAD=1
69208 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69209 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69210 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69211 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69212 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69213 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69214 & MAX(1D-10,2D0-X1-X2)
69215C...Evaluate shower rate to be compared with.
69216 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69217 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69218 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69219 ELSEIF(MSTJ(49).NE.1) THEN
69220
69221C...Toy model scalar theory matrix elements; no mass effects.
69222 ELSE
69223 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69224 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69225 X3=(1D0-X1)+(1D0-X2)
69226 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69227 WME=X3**2
69228 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69229 & PARJ(171)
69230 ENDIF
69231
69232 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69233 ENDIF
69234
69235C...Impose angular ordering by rejection of nonordered emission.
69236 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69237 PEMAO=V(IM,1)*P(IM,4)
69238 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69239 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69240 MAOD=0
69241 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69242 & .OR.MSTJ(42).EQ.7)) THEN
69243 MAOD=0
69244 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69245 & .OR.MSTJ(42).EQ.6)) THEN
69246 MAOD=1
69247 PMDAO=PMTH(2,K(IEP(1),5))
69248 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69249 ELSE
69250 MAOD=1
69251 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69252 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69253 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69254 ENDIF
69255 MAOM=1
69256 IAOM=IM
69257 440 IF(K(IAOM,5).EQ.22) THEN
69258 IAOM=K(IAOM,3)
69259 IF(K(IAOM,3).LE.NS) MAOM=0
69260 IF(MAOM.EQ.1) GOTO 440
69261 ENDIF
69262 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69263 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69264 IF(THE2ID.LT.THE2IM) GOTO 410
69265 ENDIF
69266 ENDIF
69267
69268C...Impose user-defined maximum angle at first branching.
69269 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69270 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69271 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69272 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69273 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69274 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69275 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69276 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69277 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69278 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69279 ENDIF
69280 ENDIF
69281
69282C...Impose angular constraint in first branching from interference
69283C...with initial state partons.
69284 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69285 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69286 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69287 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69288 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69289 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69290 ENDIF
69291 ENDIF
69292
69293C...End of inner veto algorithm. Check if only one leg evolved so far.
69294 450 V(IEP(1),1)=Z
69295 ISL(1)=0
69296 ISL(2)=0
69297 IF(NEP.EQ.1) GOTO 490
69298 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69299 DO 460 I=1,NEP
69300 IR=IREF(N+I-NS)
69301 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69302 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69303 ENDIF
69304 460 CONTINUE
69305
69306C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69307 IF(NEP.GE.3) THEN
69308 PMSUM=0D0
69309 DO 470 I=1,NEP
69310 PMSUM=PMSUM+P(N+I,5)
69311 470 CONTINUE
69312 IF(PMSUM.GE.PS(5)) GOTO 350
69313 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69314 DO 480 I1=N+1,N+2
69315 IRDA=IREF(I1-NS)
69316 IF(KSH(IRDA).EQ.0) GOTO 480
69317 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69318 IF(IRDA.EQ.21) THEN
69319 IRGD1=IABS(K(I1,5))
69320 IRGD2=IRGD1
69321 ELSE
69322 IRGD1=IRDA
69323 IRGD2=IABS(K(I1,5))
69324 ENDIF
69325 I2=2*N+3-I1
69326 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69327 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69328 ELSE
69329 IF(I1.EQ.N+1) ZM=V(IM,1)
69330 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69331 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69332 & 4D0*V(N+1,5)*V(N+2,5))
69333 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69334 & V(IM,5)
69335 ENDIF
69336 IF(MOD(MSTJ(43),2).EQ.1) THEN
69337 PMQTH3=0.5D0*PARJ(82)
69338 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69339 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69340 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69341 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69342 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69343 & 4D0*PMQ1*PMQ2)))
69344 ZH=1D0+PMQ1-PMQ2
69345 ELSE
69346 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69347 ZH=1D0
69348 ENDIF
69349 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69350 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69351 ELSE
69352 ZL=0.5D0*(ZH-ZD)
69353 ZU=0.5D0*(ZH+ZD)
69354 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69355 & ISSET(1).EQ.0) THEN
69356 ISL(1)=1
69357 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69358 & ISSET(2).EQ.0) THEN
69359 ISL(2)=1
69360 ENDIF
69361 ENDIF
69362 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69363 & ZL*(1D0-ZU)))
69364 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69365 480 CONTINUE
69366 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69367 ISL(3-ISLM)=0
69368 ISLM=3-ISLM
69369 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69370 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69371 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69372 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69373 IF(ISL(1).EQ.1) ISL(2)=0
69374 IF(ISL(1).EQ.0) ISLM=1
69375 IF(ISL(2).EQ.0) ISLM=2
69376 ENDIF
69377 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69378 ENDIF
69379 IRD1=IREF(N+1-NS)
69380 IRD2=IREF(N+2-NS)
69381 IF(IGM.GT.0) THEN
69382 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69383 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69384 PMQ1=V(N+1,5)/V(IM,5)
69385 PMQ2=V(N+2,5)/V(IM,5)
69386 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69387 & 4D0*PMQ1*PMQ2)))
69388 ZH=1D0+PMQ1-PMQ2
69389 ZL=0.5D0*(ZH-ZD)
69390 ZU=0.5D0*(ZH+ZD)
69391 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69392 ENDIF
69393 ENDIF
69394
69395C...Accepted branch. Construct four-momentum for initial partons.
69396 490 MAZIP=0
69397 MAZIC=0
69398 IF(NEP.EQ.1) THEN
69399 P(N+1,1)=0D0
69400 P(N+1,2)=0D0
69401 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69402 & P(N+1,5))))
69403 P(N+1,4)=P(IPA(1),4)
69404 V(N+1,2)=P(N+1,4)
69405 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69406 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69407 P(N+1,1)=0D0
69408 P(N+1,2)=0D0
69409 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69410 P(N+1,4)=PED1
69411 P(N+2,1)=0D0
69412 P(N+2,2)=0D0
69413 P(N+2,3)=-P(N+1,3)
69414 P(N+2,4)=P(IM,5)-PED1
69415 V(N+1,2)=P(N+1,4)
69416 V(N+2,2)=P(N+2,4)
69417 ELSEIF(NEP.GE.3) THEN
69418C...Rescale all momenta for energy conservation.
69419 LOOP=0
69420 PES=0D0
69421 PQS=0D0
69422 DO 510 I=1,NEP
69423 DO 500 J=1,4
69424 P(N+I,J)=P(IPA(I),J)
69425 500 CONTINUE
69426 PES=PES+P(N+I,4)
69427 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69428 510 CONTINUE
69429 520 LOOP=LOOP+1
69430 FAC=(PS(5)-PQS)/(PES-PQS)
69431 PES=0D0
69432 PQS=0D0
69433 DO 540 I=1,NEP
69434 DO 530 J=1,3
69435 P(N+I,J)=FAC*P(N+I,J)
69436 530 CONTINUE
69437 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)
69438 V(N+I,2)=P(N+I,4)
69439 PES=PES+P(N+I,4)
69440 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69441 540 CONTINUE
69442 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69443
69444C...Construct transverse momentum for ordinary branching in shower.
69445 ELSE
69446 ZM=V(IM,1)
69447 LOOPPT=0
69448 550 LOOPPT=LOOPPT+1
69449 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69450 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69451 IF(PZM.LE.0D0) THEN
69452 PTS=0D0
69453 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69454 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69455 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69456 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69457 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69458 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69459 ELSE
69460 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69461 ENDIF
69462 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69463 ZM=0.05D0+0.9D0*ZM
69464 GOTO 550
69465 ELSEIF(PTS.LT.0D0) THEN
69466 GOTO 280
69467 ENDIF
69468 PT=SQRT(MAX(0D0,PTS))
69469
69470C...Global statistics.
69471 MINT(353)=MINT(353)+1
69472 VINT(353)=VINT(353)+PT
69473 IF (MINT(353).EQ.1) VINT(358)=PT
69474
69475C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69476 HAZIP=0D0
69477 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69478 & .AND.IAU.NE.0) THEN
69479 IF(K(IGM,3).NE.0) MAZIP=1
69480 ZAU=V(IGM,1)
69481 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69482 IF(MAZIP.EQ.0) ZAU=0D0
69483 IF(K(IGM,2).NE.21) THEN
69484 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69485 ELSE
69486 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69487 ENDIF
69488 IF(K(N+1,2).NE.21) THEN
69489 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69490 ELSE
69491 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69492 ENDIF
69493 ENDIF
69494
69495C...Find coefficient of azimuthal asymmetry due to soft gluon
69496C...interference.
69497 HAZIC=0D0
69498 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69499 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69500 IF(K(IGM,3).NE.0) MAZIC=N+1
69501 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69502 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69503 & ZM.GT.0.5D0) MAZIC=N+2
69504 IF(K(IAU,2).EQ.22) MAZIC=0
69505 ZS=ZM
69506 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69507 ZGM=V(IGM,1)
69508 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69509 IF(MAZIC.EQ.0) ZGM=1D0
69510 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69511 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69512 HAZIC=MIN(0.95D0,HAZIC)
69513 ENDIF
69514 ENDIF
69515
69516C...Construct energies for ordinary branching in shower.
69517 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69518 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69519 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69520 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69521 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69522 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69523 P(N+1,4)=PEM*V(IM,1)
69524 ELSE
69525 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69526 & SQRT(PMLS)*ZM)/V(IM,5)
69527 ENDIF
69528
69529C...Already predetermined choice of phi angle or not
69530 PHI=PARU(2)*PYR(0)
69531 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69532 IPSPD=IP1+IM-NS-2
69533 IF(K(IPSPD,4).GT.0) THEN
69534 IPSGD1=K(IPSPD,4)
69535 IF(IM.EQ.NS+2) THEN
69536 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69537 ELSE
69538 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69539 ENDIF
69540 ENDIF
69541 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69542 IPSPD=IP1+IM-NS-2
69543 IF(K(IPSPD,4).GT.0) THEN
69544 IPSGD1=K(IPSPD,4)
69545 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69546 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69547 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69548 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69549 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69550 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69551 ENDIF
69552 ENDIF
69553
69554C...Construct momenta for ordinary branching in shower.
69555 P(N+1,1)=PT*COS(PHI)
69556 P(N+1,2)=PT*SIN(PHI)
69557 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69558 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69559 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69560 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69561 ELSEIF(PZM.GT.0D0) THEN
69562 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69563 & 2D0*PEM*P(N+1,4))/PZM
69564 ELSE
69565 P(N+1,3)=0D0
69566 ENDIF
69567 P(N+2,1)=-P(N+1,1)
69568 P(N+2,2)=-P(N+1,2)
69569 P(N+2,3)=PZM-P(N+1,3)
69570 P(N+2,4)=PEM-P(N+1,4)
69571 IF(MSTJ(43).LE.2) THEN
69572 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69573 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69574 ENDIF
69575 ENDIF
69576
69577C...Rotate and boost daughters.
69578 IF(IGM.GT.0) THEN
69579 IF(MSTJ(43).LE.2) THEN
69580 BEX=P(IGM,1)/P(IGM,4)
69581 BEY=P(IGM,2)/P(IGM,4)
69582 BEZ=P(IGM,3)/P(IGM,4)
69583 GA=P(IGM,4)/P(IGM,5)
69584 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69585 & P(IM,4))
69586 ELSE
69587 BEX=0D0
69588 BEY=0D0
69589 BEZ=0D0
69590 GA=1D0
69591 GABEP=0D0
69592 ENDIF
69593 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69594 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69595 IF(PTIMB.GT.1D-4) THEN
69596 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69597 ELSE
69598 PHI=0D0
69599 ENDIF
69600 DO 570 I=N+1,N+2
69601 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69602 & SIN(THE)*COS(PHI)*P(I,3)
69603 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69604 & SIN(THE)*SIN(PHI)*P(I,3)
69605 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69606 DP(4)=P(I,4)
69607 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69608 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69609 P(I,1)=DP(1)+DGABP*BEX
69610 P(I,2)=DP(2)+DGABP*BEY
69611 P(I,3)=DP(3)+DGABP*BEZ
69612 P(I,4)=GA*(DP(4)+DBP)
69613 570 CONTINUE
69614 ENDIF
69615
69616C...Weight with azimuthal distribution, if required.
69617 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69618 DO 580 J=1,3
69619 DPT(1,J)=P(IM,J)
69620 DPT(2,J)=P(IAU,J)
69621 DPT(3,J)=P(N+1,J)
69622 580 CONTINUE
69623 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69624 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69625 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69626 DO 590 J=1,3
69627 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69628 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69629 590 CONTINUE
69630 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69631 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69632 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69633 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69634 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69635 IF(MAZIP.NE.0) THEN
69636 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69637 & GOTO 560
69638 ENDIF
69639 IF(MAZIC.NE.0) THEN
69640 IF(MAZIC.EQ.N+2) CAD=-CAD
69641 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69642 & .LT.PYR(0)) GOTO 560
69643 ENDIF
69644 ENDIF
69645 ENDIF
69646
69647C...Azimuthal anisotropy due to interference with initial state partons.
69648 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69649 &K(N+2,2).EQ.21)) THEN
69650 III=IM-NS-1
69651 IF(ISII(III).GE.1) THEN
69652 IAZIID=N+1
69653 IF(K(N+1,2).NE.21) IAZIID=N+2
69654 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69655 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69656 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69657 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69658 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69659 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69660 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69661 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69662 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69663 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69664 & .LT.PYR(0)) GOTO 560
69665 ENDIF
69666 ENDIF
69667
69668C...Continue loop over partons that may branch, until none left.
69669 IF(IGM.GE.0) K(IM,1)=14
69670 N=N+NEP
69671 NEP=2
69672 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69673 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69674 IF(MSTU(21).GE.1) N=NS
69675 IF(MSTU(21).GE.1) RETURN
69676 ENDIF
69677 GOTO 290
69678
69679C...Set information on imagined shower initiator.
69680 600 IF(NPA.GE.2) THEN
69681 K(NS+1,1)=11
69682 K(NS+1,2)=94
69683 K(NS+1,3)=IP1
69684 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69685 K(NS+1,4)=NS+2
69686 K(NS+1,5)=NS+1+NPA
69687 IIM=1
69688 ELSE
69689 IIM=0
69690 ENDIF
69691
69692C...Reconstruct string drawing information.
69693 DO 610 I=NS+1+IIM,N
69694 KQ=KCHG(PYCOMP(K(I,2)),2)
69695 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69696 K(I,1)=1
69697 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69698 & IABS(K(I,2)).LE.18) THEN
69699 K(I,1)=1
69700 ELSEIF(K(I,1).LE.10) THEN
69701 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69702 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69703 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69704 ID1=MOD(K(I,4),MSTU(5))
69705 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69706 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69707 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69708 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69709 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69710 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69711 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69712 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69713 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69714 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69715 ELSE
69716 ID1=MOD(K(I,4),MSTU(5))
69717 ID2=ID1+1
69718 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69719 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69720 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69721 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69722 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69723 ELSE
69724 K(ID1,4)=0
69725 K(ID1,5)=0
69726 ENDIF
69727 K(ID2,4)=0
69728 K(ID2,5)=0
69729 ENDIF
69730 610 CONTINUE
69731
69732C...Transformation from CM frame.
69733 IF(NPA.EQ.1) THEN
69734 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69735 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69736 MSTU(33)=1
69737 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69738 ELSEIF(NPA.EQ.2) THEN
69739 BEX=PS(1)/PS(4)
69740 BEY=PS(2)/PS(4)
69741 BEZ=PS(3)/PS(4)
69742 GA=PS(4)/PS(5)
69743 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69744 & /(1D0+GA)-P(IPA(1),4))
69745 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69746 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69747 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69748 MSTU(33)=1
69749 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69750 ELSE
69751 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69752 & PS(3)/PS(4))
69753 MSTU(33)=1
69754 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69755 ENDIF
69756
69757C...Decay vertex of shower.
69758 DO 630 I=NS+1,N
69759 DO 620 J=1,5
69760 V(I,J)=V(IP1,J)
69761 620 CONTINUE
69762 630 CONTINUE
69763
69764C...Delete trivial shower, else connect initiators.
69765 IF(N.LE.NS+NPA+IIM) THEN
69766 N=NS
69767 ELSE
69768 DO 640 IP=1,NPA
69769 K(IPA(IP),1)=14
69770 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69771 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69772 K(NS+IIM+IP,3)=IPA(IP)
69773 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69774 IF(K(NS+IIM+IP,1).NE.1) THEN
69775 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69776 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69777 ENDIF
69778 640 CONTINUE
69779 ENDIF
69780
69781 RETURN
69782 END
69783
69784C*********************************************************************
69785
69786C...PYPTFS
69787C...Generates pT-ordered timelike final-state parton showers.
69788
69789C...MODE defines how to find radiators and recoilers.
69790C... = 0 : based on colour flow between undecayed partons.
69791C... = 1 : for IPART <= NPARTD only consider primary partons,
69792C... whether decayed or not; else as above.
69793C... = 2 : based on common history, whether decayed or not.
69794C... = 3 : use (or create) MCT color information to shower partons
69795
69796 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
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...Parameter statement to help give large particle numbers.
69803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69804 &KEXCIT=4000000,KDIMEN=5000000)
69805C...Parameter statement for maximum size of showers.
69806 PARAMETER (MAXNUR=1000)
69807C...Commonblocks.
69808 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69810 COMMON/PYCTAG/NCT,MCT(4000,2)
69811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69812 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69813 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69814 COMMON/PYINT1/MINT(400),VINT(400)
69815 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69816 &/PYINT1/
69817C...Local arrays.
69818 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69819 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69820 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69821 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69822C...Statement functions.
69823 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69824 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69825
69826C...Initial values. Check that valid system.
69827 PTGEN=0D0
69828 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69829 &MSTJ(41).NE.12) RETURN
69830 IF(NPART.LE.0) THEN
69831 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69832 RETURN
69833 ENDIF
69834 PT2CMX=PTMAX**2
69835 IORD=1
69836
69837C...Mass thresholds and Lambda for QCD evolution.
69838 PMB=PMAS(5,1)
69839 PMC=PMAS(4,1)
69840 ALAM5=PARJ(81)
69841 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69842 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69843 PMBS=PMB**2
69844 PMCS=PMC**2
69845 ALAM5S=ALAM5**2
69846 ALAM4S=ALAM4**2
69847 ALAM3S=ALAM3**2
69848
69849C...Cutoff scale for QCD evolution. Starting pT2.
69850 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69851 PT0C=0.5D0*PARJ(82)
69852 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69853
69854C...Parameters for QED evolution.
69855 AEM2PI=PARU(101)/PARU(2)
69856 PT0EQ=0.5D0*PARJ(83)
69857 PT0EL=0.5D0*PARJ(90)
69858
69859C...Reset. Remove irrelevant colour tags.
69860 NEVOL=0
69861 DO 100 J=1,4
69862 PSUM(J)=0D0
69863 100 CONTINUE
69864 DO 110 I=MINT(84)+1,N
69865 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69866 K(I,5)=0
69867 MCT(I,2)=0
69868 ENDIF
69869 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69870 K(I,4)=0
69871 MCT(I,1)=0
69872 ENDIF
69873 110 CONTINUE
69874 NPARTS=NPART
69875
69876C...Begin loop to set up showering partons. Sum four-momenta.
69877 DO 230 IP=1,NPART
69878 I=IPART(IP)
69879 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69880 IF(K(I,1).GT.10) GOTO 230
69881 ELSEIF(K(I,3).GT.MINT(84)) THEN
69882 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69883 ELSE
69884 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69885 ENDIF
69886 DO 120 J=1,4
69887 PSUM(J)=PSUM(J)+P(I,J)
69888 120 CONTINUE
69889
69890C...Find colour and charge, but skip diquarks.
69891 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69892 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69893 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69894
69895C...QUARKONIA++
69896 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69897 IF (MSTP(148).GE.1) THEN
69898C...Temporary: force no radiation from quarkonia since not yet treated
69899 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69900 & //' PYPTFS, switched off')
69901 CALL PYGIVE('MSTP(148)=0')
69902 ENDIF
69903 IF (MSTP(148).EQ.0) THEN
69904C...Skip quarkonia if radiation switched off
69905 GOTO 230
69906 ENDIF
69907 ENDIF
69908C...QUARKONIA--
69909
69910C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69911C...(only intended for studying the effects of switching such rad on/off)
69912 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69913 GOTO 230
69914 ENDIF
69915
69916C...Either colour or anticolour charge radiates; for gluon both.
69917 DO 180 JSGCOL=1,-1,-2
69918 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69919 JCOL=4+(1-JSGCOL)/2
69920 JCOLR=9-JCOL
69921
69922C...Basic info about radiating parton.
69923 NEVOL=NEVOL+1
69924 IPOS(NEVOL)=I
69925 IFLG(NEVOL)=0
69926 ISCOL(NEVOL)=JSGCOL
69927 ISCHG(NEVOL)=0
69928 PTSCA(NEVOL)=PTPART(IP)
69929
69930C...Begin search for colour recoiler when MODE = 0 or 1.
69931 IF(MODE.LE.1) THEN
69932C...Find sister with matching anticolour to the radiating parton.
69933 IROLD=I
69934 IRNEW=K(IROLD,JCOL)/MSTU(5)
69935 MOVE=1
69936
69937C...Skip radiation off loose colour ends.
69938 130 IF(IRNEW.EQ.0) THEN
69939 NEVOL=NEVOL-1
69940 GOTO 180
69941
69942C...Optionally skip radiation on dipole to beam remnant.
69943 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69944 NEVOL=NEVOL-1
69945 GOTO 180
69946
69947C...For now always skip radiation on dipole to junction.
69948 ELSEIF(K(IRNEW,2).EQ.88) THEN
69949 NEVOL=NEVOL-1
69950 GOTO 180
69951
69952C...For MODE=1: if reached primary then done.
69953 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
69954 & IRNEW.LE.NPARTD) THEN
69955
69956C...If sister stable and points back then done.
69957 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69958 & THEN
69959 IF(K(IRNEW,1).LT.10) THEN
69960
69961C...If sister unstable then go to her daughter.
69962 ELSE
69963 IROLD=IRNEW
69964 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69965 MOVE=2
69966 GOTO 130
69967 ENDIF
69968
69969C...If found mother then look for aunt.
69970 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69971 & IROLD) THEN
69972 IROLD=IRNEW
69973 IRNEW=K(IROLD,JCOL)/MSTU(5)
69974 GOTO 130
69975
69976C...If daughter stable then done.
69977 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
69978 & THEN
69979 IF(K(IRNEW,1).LT.10) THEN
69980
69981C...If daughter unstable then go to granddaughter.
69982 ELSE
69983 IROLD=IRNEW
69984 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
69985 MOVE=2
69986 GOTO 130
69987 ENDIF
69988
69989C...If daughter points to another daughter then done or move up.
69990 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
69991 & IROLD) THEN
69992 IF(K(IRNEW,1).LT.10) THEN
69993 ELSE
69994 IROLD=IRNEW
69995 IRNEW=K(IRNEW,JCOL)/MSTU(5)
69996 MOVE=1
69997 GOTO 130
69998 ENDIF
69999 ENDIF
70000
70001C...Begin search for colour recoiler when MODE = 2.
70002 ELSEIF (MODE.EQ.2) THEN
70003 IROLD=I
70004 IRNEW=K(IROLD,JCOL)/MSTU(5)
70005 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70006C...If no color partner found, pick at random among other primaries
70007C...(e.g., when the color line is traced all the way to the beam)
70008 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70009 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70010 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70011C...Step up to mother if radiating parton already branched.
70012 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70013 IROLD=IRNEW
70014 IRNEW=K(IROLD,JCOL)/MSTU(5)
70015 GOTO 140
70016C...Pick sister by history if no anticolour available.
70017 ELSE
70018 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70019 IRNEW=IROLD-1
70020 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70021 & THEN
70022 IRNEW=IROLD+1
70023C...Last resort: pick at random among other primaries.
70024 ELSE
70025 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70026 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70027 ENDIF
70028 ENDIF
70029 ENDIF
70030C...Trace down if sister branched.
70031 150 IF(K(IRNEW,1).GT.10) THEN
70032 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70033C...If no correct color-daughter found, swap.
70034 IF (IRTMP.EQ.0) THEN
70035 JCOL=9-JCOL
70036 JCOLR=9-JCOLR
70037 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70038 ENDIF
70039 IRNEW=IRTMP
70040 GOTO 150
70041 ENDIF
70042 ELSEIF (MODE.EQ.3) THEN
70043C...The following will add MCT colour tracing for unprepped events
70044C...If not done, trace Les Houches colour tags for this dipole
70045 JCOLSV=JCOL
70046 IF (MCT(I,JCOL-3).EQ.0) THEN
70047C...Special end code -1 : trace to color partner or 0, return in IEND
70048 IEND=-1
70049 CALL PYCTTR(I,JCOL,IEND)
70050C...Clean up mother/daughter 'read' tags set by PYCTTR
70051 JCOL=JCOLSV
70052 DO 160 IR=1,N
70053 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70054 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70055 MCT(IR,1)=0
70056 MCT(IR,2)=0
70057 160 CONTINUE
70058 ELSE
70059 IEND=0
70060 DO 170 IR=1,N
70061 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70062 & IEND=IR
70063 170 CONTINUE
70064 ENDIF
70065C...If no color partner, then we hit beam
70066 IF (IEND.LE.0) THEN
70067C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70068 IF (MSTP(72).LE.1) THEN
70069 NEVOL=NEVOL-1
70070 GOTO 180
70071 ELSE
70072C...Else try a random partner
70073 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70074 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70075 ENDIF
70076 ELSE
70077C...Else save recoiling colour partner
70078 IRNEW=IEND
70079 ENDIF
70080
70081 ENDIF
70082
70083C...Now found other end of colour dipole.
70084 IREC(NEVOL)=IRNEW
70085 ENDIF
70086 180 CONTINUE
70087
70088C...Also electrical charge may radiate; so far only quarks and leptons.
70089 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70090 & IABS(K(I,2)).LE.18) THEN
70091
70092C...Basic info about radiating parton.
70093 NEVOL=NEVOL+1
70094 IPOS(NEVOL)=I
70095 IFLG(NEVOL)=0
70096 ISCOL(NEVOL)=0
70097 ISCHG(NEVOL)=KCHA
70098 PTSCA(NEVOL)=PTPART(IP)
70099
70100C...Pick nearest (= smallest invariant mass) charged particle
70101C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70102 IF(MODE.LE.1) THEN
70103 IRNEW=0
70104 PM2MIN=VINT(2)
70105 DO 190 IP2=1,NPART+N-MINT(53)
70106 IF(IP2.EQ.IP) GOTO 190
70107 IF(IP2.LE.NPART) THEN
70108 I2=IPART(IP2)
70109 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70110 IF(K(I2,1).GT.10) GOTO 190
70111 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70112 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70113 ELSE
70114 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70115 ENDIF
70116 ELSE
70117 I2=MINT(53)+IP2-NPART
70118 ENDIF
70119 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70120 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70121 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70122 IF(PM2INV.LT.PM2MIN) THEN
70123 IRNEW=I2
70124 PM2MIN=PM2INV
70125 ENDIF
70126 190 CONTINUE
70127 IF(IRNEW.EQ.0) THEN
70128 NEVOL=NEVOL-1
70129 GOTO 230
70130 ENDIF
70131
70132C...Begin search for charge recoiler when MODE = 2.
70133 ELSE
70134 IROLD=I
70135C...Pick sister by history; step up if parton already branched.
70136 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70137 IROLD=K(IROLD,3)
70138 GOTO 200
70139 ENDIF
70140 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70141 IRNEW=IROLD-1
70142 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70143 IRNEW=IROLD+1
70144C...Last resort: pick at random among other primaries.
70145 ELSE
70146 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70147 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70148 ENDIF
70149C...Trace down if sister branched.
70150 210 IF(K(IRNEW,1).GT.10) THEN
70151 DO 220 IR=IRNEW+1,N
70152 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70153 IRNEW=IR
70154 GOTO 210
70155 ENDIF
70156 220 CONTINUE
70157 ENDIF
70158 ENDIF
70159 IREC(NEVOL)=IRNEW
70160 ENDIF
70161
70162C...End loop to set up showering partons. System invariant mass.
70163 230 CONTINUE
70164 IF(NEVOL.LE.0) RETURN
70165 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70166 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70167
70168C...Check if 3-jet matrix elements to be used.
70169 M3JC=0
70170 ALPHA=0.5D0
70171 NMESYS=0
70172 IF(MSTJ(47).GE.1) THEN
70173
70174C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70175 KFSRCE=0
70176 IPART1=K(IPART(1),3)
70177 IPART2=K(IPART(2),3)
70178 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70179 KFSRCE=IABS(K(IPART1,2))
70180 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70181 IPART1=K(IPART1,3)
70182 GOTO 240
70183 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70184 IPART2=K(IPART2,3)
70185 GOTO 240
70186 ENDIF
70187 ITYPES=0
70188 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70189 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70190 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70191 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70192 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70193 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70194 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70195 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70196
70197C...Identify two primary showerers.
70198 KFLA1=IABS(K(IPART(1),2))
70199 ITYPE1=0
70200 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70201 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70202 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70203 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70204 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70205 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70206 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70207 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70208 KFLA2=IABS(K(IPART(2),2))
70209 ITYPE2=0
70210 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70211 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70212 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70213 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70214 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70215 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70216 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70217 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70218
70219C...Order of showerers. Presence of gluino.
70220 ITYPMN=MIN(ITYPE1,ITYPE2)
70221 ITYPMX=MAX(ITYPE1,ITYPE2)
70222 IORD=1
70223 IF(ITYPE1.GT.ITYPE2) IORD=2
70224 IGLUI=0
70225 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70226
70227C...Require exactly two primary showerers for ME corrections.
70228 NPRIM=0
70229 IF(IPART1.GT.0) THEN
70230 DO 250 I=1,N
70231 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70232 250 CONTINUE
70233 ENDIF
70234 IF(NPRIM.NE.2) THEN
70235
70236C...Predetermined and default matrix element kinds.
70237 ELSEIF(MSTJ(38).NE.0) THEN
70238 M3JC=MSTJ(38)
70239 ALPHA=PARJ(80)
70240 MSTJ(38)=0
70241 ELSEIF(MSTJ(47).GE.6) THEN
70242 M3JC=MSTJ(47)
70243 ELSE
70244 ICLASS=1
70245 ICOMBI=4
70246
70247C...Vector/axial vector -> q + qbar; q -> q + V.
70248 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70249 & ITYPES.EQ.3)) THEN
70250 ICLASS=2
70251 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70252 ICOMBI=1
70253 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70254 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70255C...gamma*/Z0: assume e+e- initial state if unknown.
70256 EI=-1D0
70257 IF(KFSRCE.EQ.23) THEN
70258 IANNFL=IPART1
70259 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70260 IF(IANNFL.GT.0) THEN
70261 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70262 ENDIF
70263 IF(IANNFL.NE.0) THEN
70264 KANNFL=IABS(K(IANNFL,2))
70265 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70266 ENDIF
70267 ENDIF
70268 AI=SIGN(1D0,EI+0.1D0)
70269 VI=AI-4D0*EI*PARU(102)
70270 EF=KCHG(KFLA1,1)/3D0
70271 AF=SIGN(1D0,EF+0.1D0)
70272 VF=AF-4D0*EF*PARU(102)
70273 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70274 SH=PSUM(5)**2
70275 SQMZ=PMAS(23,1)**2
70276 SQWZ=PSUM(5)*PMAS(23,2)
70277 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70278 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70279 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70280 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70281 ICOMBI=3
70282 ALPHA=VECT/(VECT+AXIV)
70283 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70284 ICOMBI=4
70285 ENDIF
70286C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70287 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70288 ICLASS=2
70289 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70290 & ITYPES.EQ.1)) THEN
70291 ICLASS=3
70292
70293C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70294 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70295 ICLASS=4
70296 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70297 ICOMBI=1
70298 ELSEIF(KFSRCE.EQ.36) THEN
70299 ICOMBI=2
70300 ENDIF
70301 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70302 & ITYPES.EQ.1)) THEN
70303 ICLASS=5
70304
70305C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70306 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70307 & ITYPES.EQ.3)) THEN
70308 ICLASS=6
70309 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70310 & ITYPES.EQ.2)) THEN
70311 ICLASS=7
70312 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70313 ICLASS=8
70314 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70315 & ITYPES.EQ.2)) THEN
70316 ICLASS=9
70317
70318C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70319 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70320 & ITYPES.EQ.5)) THEN
70321 ICLASS=10
70322 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70323 & ITYPES.EQ.2)) THEN
70324 ICLASS=11
70325 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70326 & ITYPES.EQ.1)) THEN
70327 ICLASS=12
70328
70329C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70330 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70331 ICLASS=13
70332 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70333 & ITYPES.EQ.2)) THEN
70334 ICLASS=14
70335 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70336 & ITYPES.EQ.1)) THEN
70337 ICLASS=15
70338
70339C...g -> ~g + ~g (eikonal approximation).
70340 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70341 ICLASS=16
70342 ENDIF
70343 M3JC=5*ICLASS+ICOMBI
70344 ENDIF
70345
70346C...Store pair that together define matrix element treatment.
70347 IF(M3JC.NE.0) THEN
70348 NMESYS=1
70349 MESYS(NMESYS,0)=M3JC
70350 MESYS(NMESYS,1)=IPART(1)
70351 MESYS(NMESYS,2)=IPART(2)
70352 ENDIF
70353
70354C...Store qqbar or l+l- pairs for QED radiation.
70355 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70356 NMESYS=NMESYS+1
70357 MESYS(NMESYS,0)=101
70358 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70359 MESYS(NMESYS,1)=IPART(1)
70360 MESYS(NMESYS,2)=IPART(2)
70361 ENDIF
70362
70363C...Store other qqbar/l+l- pairs from g/gamma branchings.
70364 DO 290 I1=1,N
70365 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70366 I1M=K(I1,3)
70367 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70368 I1M=K(I1M,3)
70369 GOTO 260
70370 ENDIF
70371C...Move up this check to avoid out-of-bounds.
70372 IF(I1M.EQ.0) GOTO 290
70373 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70374 DO 280 I2=I1+1,N
70375 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70376 I2M=K(I2,3)
70377 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70378 I2M=K(I2M,3)
70379 GOTO 270
70380 ENDIF
70381 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70382 NMESYS=NMESYS+1
70383 MESYS(NMESYS,0)=66
70384 MESYS(NMESYS,1)=I1
70385 MESYS(NMESYS,2)=I2
70386 NMESYS=NMESYS+1
70387 MESYS(NMESYS,0)=102
70388 MESYS(NMESYS,1)=I1
70389 MESYS(NMESYS,2)=I2
70390 ENDIF
70391 280 CONTINUE
70392 290 CONTINUE
70393 ENDIF
70394
70395C..Loopback point for counting number of emissions.
70396 NGEN=0
70397 300 NGEN=NGEN+1
70398
70399C...Begin loop to evolve all existing partons, if required.
70400 310 IMX=0
70401 PT2MX=0D0
70402 DO 380 IEVOL=1,NEVOL
70403 IF(IFLG(IEVOL).EQ.0) THEN
70404
70405C...Basic info on radiator and recoil.
70406 I=IPOS(IEVOL)
70407 IR=IREC(IEVOL)
70408 SHT=SHAT(I,IR)
70409 PM2I=P(I,5)**2
70410 PM2R=P(IR,5)**2
70411
70412C...Invariant mass of "dipole".Starting value for pT evolution.
70413 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70414 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70415
70416C...Case of evolution by QCD branching.
70417 IF(ISCOL(IEVOL).NE.0) THEN
70418
70419C...Parton-by-parton maximum scale from initial conditions.
70420 IF(MSTP(72).EQ.0) THEN
70421 DO 320 IPRT=1,NPARTS
70422 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70423 320 CONTINUE
70424 ENDIF
70425
70426C...If kinematically impossible then do not evolve.
70427 IF(PT2.LT.PT2CMN) THEN
70428 IFLG(IEVOL)=-1
70429 GOTO 380
70430 ENDIF
70431
70432C...Check if part of system for which ME corrections should be applied.
70433 IMESYS=0
70434 DO 330 IME=1,NMESYS
70435 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70436 & MESYS(IME,0).LT.100) IMESYS=IME
70437 330 CONTINUE
70438
70439C...Special flag for colour octet states.
70440C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70441 MOCT=0
70442 IF(K(I,2).EQ.21) MOCT=1
70443C...SUSY gluino
70444 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70445C...UED KK gluon
70446 IF(K(I,2).EQ.5100021) MOCT=2
70447C...QUARKONIA++
70448 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70449 & IABS(K(I,2)).LE.9910555) MOCT=2
70450C...QUARKONIA--
70451
70452
70453C...Upper estimate for matrix element weighting and colour factor.
70454C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70455 WTPSGL=2D0
70456 COLFAC=4D0/3D0
70457 IF(MOCT.GE.1) COLFAC=3D0/2D0
70458 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70459 WTPSQQ=0.5D0*0.5D0*NFLAV
70460
70461C...Determine overestimated z range: switch at c and b masses.
70462 340 IZRG=1
70463 PT2MNE=PT2CMN
70464 B0=27D0/6D0
70465 ALAMS=ALAM3S
70466 IF(PT2.GT.1.01D0*PMCS) THEN
70467 IZRG=2
70468 PT2MNE=PMCS
70469 B0=25D0/6D0
70470 ALAMS=ALAM4S
70471 ENDIF
70472 IF(PT2.GT.1.01D0*PMBS) THEN
70473 IZRG=3
70474 PT2MNE=PMBS
70475 B0=23D0/6D0
70476 ALAMS=ALAM5S
70477 ENDIF
70478 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70479 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70480
70481C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70482 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70483 EVCOEF=EVEMGL
70484 IF(MOCT.EQ.1) THEN
70485 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70486 EVCOEF=EVCOEF+EVEMQQ
70487 ENDIF
70488
70489C...Pick pT2 (in overestimated z range).
70490 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70491
70492C...Loopback if crossed c/b mass thresholds.
70493 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70494 PT2=PMBS
70495 GOTO 340
70496 ENDIF
70497 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70498 PT2=PMCS
70499 GOTO 340
70500 ENDIF
70501
70502C...Finish if below lower cutoff.
70503 IF(PT2.LT.PT2CMN) THEN
70504 IFLG(IEVOL)=-1
70505 GOTO 380
70506 ENDIF
70507
70508C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70509C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70510 IFLAG=1
70511 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70512
70513C...Pick z: dz/(1-z) or dz.
70514 IF(IFLAG.EQ.1) THEN
70515 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70516 ELSE
70517 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70518 ENDIF
70519
70520C...Loopback if outside allowed range for given pT2.
70521 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70522 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70523 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70524 PM2=PM2I+PT2/(Z*(1D0-Z))
70525 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70526
70527C...No weighting for primary partons; to be done later on.
70528 IF(IMESYS.GT.0) THEN
70529
70530C...Weighting of q->qg/X->Xg branching.
70531 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70532 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70533
70534C...Weighting of g->gg branching.
70535 ELSEIF(IFLAG.EQ.1) THEN
70536 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70537
70538C...Flavour choice and weighting of g->qqbar branching.
70539 ELSE
70540 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70541 PMQ=PMAS(KFQ,1)
70542 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70543 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70544 IF(WTME.LT.PYR(0)) GOTO 350
70545 IFLAG=10+KFQ
70546 ENDIF
70547
70548C...Case of evolution by QED branching.
70549 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70550
70551C...If kinematically impossible then do not evolve.
70552 PT2EMN=PT0EQ**2
70553 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70554 IF(PT2.LT.PT2EMN) THEN
70555 IFLG(IEVOL)=-1
70556 GOTO 380
70557 ENDIF
70558
70559C...Check if part of system for which ME corrections should be applied.
70560 IMESYS=0
70561 DO 360 IME=1,NMESYS
70562 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70563 & MESYS(IME,0).GT.100) IMESYS=IME
70564 360 CONTINUE
70565
70566C...Charge. Matrix element weighting factor.
70567 CHG=ISCHG(IEVOL)/3D0
70568 WTPSGA=2D0
70569
70570C...Determine overestimated z range. Find evolution coefficient.
70571 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70572 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70573 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70574
70575C...Pick pT2 (in overestimated z range).
70576 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70577
70578C...Finish if below lower cutoff.
70579 IF(PT2.LT.PT2EMN) THEN
70580 IFLG(IEVOL)=-1
70581 GOTO 380
70582 ENDIF
70583
70584C...Pick z: dz/(1-z).
70585 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70586
70587C...Loopback if outside allowed range for given pT2.
70588 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70589 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70590 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70591 PM2=PM2I+PT2/(Z*(1D0-Z))
70592 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70593
70594C...Weighting by branching kernel, except if ME weighting later.
70595 IF(IMESYS.EQ.0) THEN
70596 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70597 ENDIF
70598 IFLAG=3
70599 ENDIF
70600
70601C...Save acceptable branching.
70602 IFLG(IEVOL)=IFLAG
70603 IMESAV(IEVOL)=IMESYS
70604 PT2SAV(IEVOL)=PT2
70605 ZSAV(IEVOL)=Z
70606 SHTSAV(IEVOL)=SHT
70607 ENDIF
70608
70609C...Check if branching has highest pT.
70610 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70611 IMX=IEVOL
70612 PT2MX=PT2SAV(IEVOL)
70613 ENDIF
70614 380 CONTINUE
70615
70616C...Finished if no more branchings to be done.
70617 IF(IMX.EQ.0) GOTO 500
70618
70619C...Restore info on hardest branching to be processed.
70620 I=IPOS(IMX)
70621 IR=IREC(IMX)
70622 KCOL=ISCOL(IMX)
70623 KCHA=ISCHG(IMX)
70624 IMESYS=IMESAV(IMX)
70625 PT2=PT2SAV(IMX)
70626 Z=ZSAV(IMX)
70627 SHT=SHTSAV(IMX)
70628 PM2I=P(I,5)**2
70629 PM2R=P(IR,5)**2
70630 PM2=PM2I+PT2/(Z*(1D0-Z))
70631
70632C...Special flag for colour octet states.
70633 MOCT=0
70634 IF(K(I,2).EQ.21) MOCT=1
70635 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70636 IF(K(I,2).EQ.5100021) MOCT=2
70637C...QUARKONIA++
70638 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70639 & IABS(K(I,2)).LE.9910555) MOCT=2
70640C...QUARKONIA--
70641
70642C...Restore further info for g->qqbar branching.
70643 KFQ=0
70644 IF(IFLG(IMX).GT.10) THEN
70645 KFQ=IFLG(IMX)-10
70646 PMQ=PMAS(KFQ,1)
70647 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70648 ENDIF
70649
70650C...For branching g include azimuthal asymmetries from polarization.
70651 ASYPOL=0D0
70652 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70653C...Trace grandmother via intermediate recoil copies.
70654 KFGM=0
70655 IM=I
70656 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70657 & K(IM,3).GT.0) THEN
70658 IM=K(IM,3)
70659 IF(IM.GT.MINT(84)) GOTO 390
70660 ENDIF
70661 IGM=K(IM,3)
70662 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70663 & KFGM=IABS(K(IGM,2))
70664C...Define approximate energy sharing by identifying aunt.
70665 IAU=IM+1
70666 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70667 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70668 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70669C...Coefficient from gluon production.
70670 IF(KFGM.LE.6) THEN
70671 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70672 ELSE
70673 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70674 ENDIF
70675C...Coefficient from gluon decay.
70676 IF(KFQ.EQ.0) THEN
70677 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70678 ELSE
70679 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70680 ENDIF
70681 ENDIF
70682 ENDIF
70683
70684C...Create new slots for branching products and recoil.
70685 INEW=N+1
70686 IGNEW=N+2
70687 IRNEW=N+3
70688 N=N+3
70689
70690C...Set status, flavour and mother of new ones.
70691 K(INEW,1)=K(I,1)
70692 K(IGNEW,1)=3
70693 IF(KCHA.NE.0) K(IGNEW,1)=1
70694 K(IRNEW,1)=K(IR,1)
70695 IF(KFQ.EQ.0) THEN
70696 K(INEW,2)=K(I,2)
70697 K(IGNEW,2)=21
70698 IF(KCHA.NE.0) K(IGNEW,2)=22
70699 ELSE
70700 K(INEW,2)=-ISIGN(KFQ,KCOL)
70701 K(IGNEW,2)=-K(INEW,2)
70702 ENDIF
70703 K(IRNEW,2)=K(IR,2)
70704 K(INEW,3)=I
70705 K(IGNEW,3)=I
70706 K(IRNEW,3)=IR
70707
70708C...Find rest frame and angles of branching+recoil.
70709 DO 400 J=1,5
70710 P(INEW,J)=P(I,J)
70711 P(IGNEW,J)=0D0
70712 P(IRNEW,J)=P(IR,J)
70713 400 CONTINUE
70714 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70715 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70716 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70717 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70718 PHI=PYANGL(P(INEW,1),P(INEW,2))
70719 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70720
70721C...Derive kinematics of branching: generics (like g->gg).
70722 DO 410 J=1,4
70723 P(INEW,J)=0D0
70724 P(IRNEW,J)=0D0
70725 410 CONTINUE
70726 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70727 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70728 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70729 PTCOR=SQRT(MAX(0D0,PT2COR))
70730 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70731 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70732C...Specific kinematics reduction for q->qg with m_q > 0.
70733 IF(MOCT.NE.1) THEN
70734 PTCOR=(1D0-PM2I/PM2)*PTCOR
70735 PZN=PZN+PM2I*PZG/PM2
70736 PZG=(1D0-PM2I/PM2)*PZG
70737C...Specific kinematics reduction for g->qqbar with m_q > 0.
70738 ELSEIF(KFQ.NE.0) THEN
70739 P(INEW,5)=PMQ
70740 P(IGNEW,5)=PMQ
70741 PTCOR=ROOTQQ*PTCOR
70742 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70743 PZG=PZM-PZN
70744 ENDIF
70745
70746C...Pick phi and construct kinematics of branching.
70747 420 PHIROT=PARU(2)*PYR(0)
70748 P(INEW,1)=PTCOR*COS(PHIROT)
70749 P(INEW,2)=PTCOR*SIN(PHIROT)
70750 P(INEW,3)=PZN
70751 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70752 P(IGNEW,1)=-P(INEW,1)
70753 P(IGNEW,2)=-P(INEW,2)
70754 P(IGNEW,3)=PZG
70755 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70756 P(IRNEW,1)=0D0
70757 P(IRNEW,2)=0D0
70758 P(IRNEW,3)=-PZM
70759 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70760
70761C...Boost branching system to lab frame.
70762 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70763
70764C...Renew choice of phi angle according to polarization asymmetry.
70765 IF(ABS(ASYPOL).GT.1D-3) THEN
70766 DO 430 J=1,3
70767 DPT(1,J)=P(I,J)
70768 DPT(2,J)=P(IAU,J)
70769 DPT(3,J)=P(INEW,J)
70770 430 CONTINUE
70771 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70772 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70773 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70774 DO 440 J=1,3
70775 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70776 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70777 440 CONTINUE
70778 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70779 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70780 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70781 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70782 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70783 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70784 & GOTO 420
70785 ENDIF
70786 ENDIF
70787
70788C...Matrix element corrections for primary partons when requested.
70789 IF(IMESYS.GT.0) THEN
70790 M3JC=MESYS(IMESYS,0)
70791
70792C...Identify recoiling partner and set up three-body kinematics.
70793 IRP=MESYS(IMESYS,1)
70794 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70795 IF(IRP.EQ.IR) IRP=IRNEW
70796 DO 450 J=1,4
70797 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70798 450 CONTINUE
70799 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70800 & PSUM(3)**2))
70801 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70802 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70803 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70804 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70805 X3=2D0-X1-X2
70806 R1ME=P(INEW,5)/PSUM(5)
70807 R2ME=P(IRP,5)/PSUM(5)
70808
70809C...Matrix elements for gluon emission.
70810 IF(M3JC.LT.100) THEN
70811
70812C...Call ME, with right order important for two inequivalent showerers.
70813 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70814 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70815 ELSE
70816 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70817 ENDIF
70818
70819C...Split up total ME when two radiating partons.
70820 ISPRAD=1
70821 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70822 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70823 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70824 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70825 & MAX(1D-10,2D0-X1-X2)
70826
70827C...Evaluate shower rate.
70828 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70829 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70830 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70831
70832C...Matrix elements for photon emission: still rather primitive.
70833 ELSE
70834
70835C...For generic charge combination currently only massless expression.
70836 IF(M3JC.EQ.101) THEN
70837 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70838 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70839 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70840 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70841
70842C...For flavour neutral system assume vector source and include masses.
70843 ELSE
70844 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70845 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70846 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70847 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70848 ENDIF
70849 ENDIF
70850
70851C...Perform weighting with W_ME/W_PS.
70852 IF(WME.LT.PYR(0)*WPS) THEN
70853 N=N-3
70854 IFLG(IMX)=0
70855 PT2CMX=PT2
70856 GOTO 310
70857 ENDIF
70858 ENDIF
70859
70860C...Now for sure accepted branching. Save highest pT.
70861 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70862
70863C...Update status for obsolete ones. Bookkkep the moved original parton
70864C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70865C...Do not bookkeep radiated photon, since it cannot radiate further.
70866 K(I,1)=K(I,1)+10
70867 K(IR,1)=K(IR,1)+10
70868 DO 460 IP=1,NPART
70869 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70870 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70871 460 CONTINUE
70872 IF(KCHA.EQ.0) THEN
70873 NPART=NPART+1
70874 IPART(NPART)=IGNEW
70875 ENDIF
70876
70877C...Initialize colour flow of branching.
70878C...Use both old and new style colour tags for flexibility.
70879 K(INEW,4)=0
70880 K(IGNEW,4)=0
70881 K(INEW,5)=0
70882 K(IGNEW,5)=0
70883 JCOLP=4+(1-KCOL)/2
70884 JCOLN=9-JCOLP
70885 MCT(INEW,1)=0
70886 MCT(INEW,2)=0
70887 MCT(IGNEW,1)=0
70888 MCT(IGNEW,2)=0
70889 MCT(IRNEW,1)=0
70890 MCT(IRNEW,2)=0
70891
70892C...Trivial colour flow for l->lgamma and q->qgamma.
70893 IF(IABS(KCHA).EQ.3) THEN
70894 K(I,4)=INEW
70895 K(I,5)=IGNEW
70896 ELSEIF(KCHA.NE.0) THEN
70897 IF(K(I,4).NE.0) THEN
70898 K(I,4)=K(I,4)+INEW
70899 K(INEW,4)=MSTU(5)*I
70900 MCT(INEW,1)=MCT(I,1)
70901 ENDIF
70902 IF(K(I,5).NE.0) THEN
70903 K(I,5)=K(I,5)+INEW
70904 K(INEW,5)=MSTU(5)*I
70905 MCT(INEW,2)=MCT(I,2)
70906 ENDIF
70907
70908C...Set colour flow for q->qg and g->gg.
70909 ELSEIF(KFQ.EQ.0) THEN
70910 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70911 K(IGNEW,JCOLP)=MSTU(5)*I
70912 K(INEW,JCOLP)=MSTU(5)*IGNEW
70913 K(IGNEW,JCOLN)=MSTU(5)*INEW
70914 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70915 NCT=NCT+1
70916 MCT(INEW,JCOLP-3)=NCT
70917 MCT(IGNEW,JCOLN-3)=NCT
70918 IF(MOCT.GE.1) THEN
70919 K(I,JCOLN)=K(I,JCOLN)+INEW
70920 K(INEW,JCOLN)=MSTU(5)*I
70921 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70922 ENDIF
70923
70924C...Set colour flow for g->qqbar.
70925 ELSE
70926 K(I,JCOLN)=K(I,JCOLN)+INEW
70927 K(INEW,JCOLN)=MSTU(5)*I
70928 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70929 K(IGNEW,JCOLP)=MSTU(5)*I
70930 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70931 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70932 ENDIF
70933
70934C...Daughter info for colourless recoiling parton.
70935 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70936 K(IR,4)=IRNEW
70937 K(IR,5)=IRNEW
70938 K(IRNEW,4)=0
70939 K(IRNEW,5)=0
70940
70941C...Colour of recoiling parton sails through unchanged.
70942 ELSE
70943 IF(K(IR,4).NE.0) THEN
70944 K(IR,4)=K(IR,4)+IRNEW
70945 K(IRNEW,4)=MSTU(5)*IR
70946 MCT(IRNEW,1)=MCT(IR,1)
70947 ENDIF
70948 IF(K(IR,5).NE.0) THEN
70949 K(IR,5)=K(IR,5)+IRNEW
70950 K(IRNEW,5)=MSTU(5)*IR
70951 MCT(IRNEW,2)=MCT(IR,2)
70952 ENDIF
70953 ENDIF
70954
70955C...Vertex information trivial.
70956 DO 470 J=1,5
70957 V(INEW,J)=V(I,J)
70958 V(IGNEW,J)=V(I,J)
70959 V(IRNEW,J)=V(IR,J)
70960 470 CONTINUE
70961
70962C...Update list of old radiators.
70963 DO 480 IEVOL=1,NEVOL
70964 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
70965 IPOS(IEVOL)=INEW
70966 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
70967 IREC(IEVOL)=IRNEW
70968 IFLG(IEVOL)=0
70969 ELSEIF(IPOS(IEVOL).EQ.I) THEN
70970 IPOS(IEVOL)=INEW
70971 IFLG(IEVOL)=0
70972 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
70973 IPOS(IEVOL)=IRNEW
70974 IREC(IEVOL)=INEW
70975 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
70976 IFLG(IEVOL)=0
70977 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
70978 IPOS(IEVOL)=IRNEW
70979 IFLG(IEVOL)=0
70980 ENDIF
70981C...Update links of old connected partons.
70982 IF(IREC(IEVOL).EQ.I) THEN
70983 IREC(IEVOL)=INEW
70984 IFLG(IEVOL)=0
70985 ELSEIF(IREC(IEVOL).EQ.IR) THEN
70986 IREC(IEVOL)=IRNEW
70987 IFLG(IEVOL)=0
70988 ENDIF
70989 480 CONTINUE
70990
70991C...q->qg or g->gg: create new gluon radiators.
70992 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
70993 NEVOL=NEVOL+1
70994 IPOS(NEVOL)=INEW
70995 IREC(NEVOL)=IGNEW
70996 IFLG(NEVOL)=0
70997 ISCOL(NEVOL)=KCOL
70998 ISCHG(NEVOL)=0
70999 PTSCA(NEVOL)=SQRT(PT2)
71000 NEVOL=NEVOL+1
71001 IPOS(NEVOL)=IGNEW
71002 IREC(NEVOL)=INEW
71003 IFLG(NEVOL)=0
71004 ISCOL(NEVOL)=-KCOL
71005 ISCHG(NEVOL)=0
71006 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71007 ENDIF
71008
71009C...Update matrix elements parton list and add new for g/gamma->qqbar.
71010 DO 490 IME=1,NMESYS
71011 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71012 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71013 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71014 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71015 490 CONTINUE
71016 IF(KFQ.NE.0) THEN
71017 NMESYS=NMESYS+1
71018 MESYS(NMESYS,0)=66
71019 MESYS(NMESYS,1)=INEW
71020 MESYS(NMESYS,2)=IGNEW
71021 NMESYS=NMESYS+1
71022 MESYS(NMESYS,0)=102
71023 MESYS(NMESYS,1)=INEW
71024 MESYS(NMESYS,2)=IGNEW
71025 ENDIF
71026
71027C...Global statistics.
71028 MINT(353)=MINT(353)+1
71029 VINT(353)=VINT(353)+PTCOR
71030 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71031
71032C...Loopback for more emissions if enough space.
71033 PT2CMX=PT2
71034 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71035 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71036 GOTO 300
71037 ELSE
71038 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71039 ENDIF
71040
71041C...Done.
71042 500 CONTINUE
71043
71044 RETURN
71045 END
71046
71047C*********************************************************************
71048
71049C...PYMAEL
71050C...Auxiliary to PYSHOW and PYPTFS.
71051C...Matrix elements for gluon (or photon) emission from
71052C...a two-body state; to be used by the parton shower routine.
71053C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71054C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71055C... = (alpha-strong/2 pi) * CF * PYMAEL,
71056C...i.e. normalization is such that one recovers the familiar
71057C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71058C...Coupling structure:
71059C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71060C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71061C... = 16-19 : q -> q V
71062C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71063C... = 26-29 : q -> q S
71064C... = 31-34 : V -> ~q ~qbar (~q = squark)
71065C... = 36-39 : ~q -> ~q V
71066C... = 41-44 : S -> ~q ~qbar
71067C... = 46-49 : ~q -> ~q S
71068C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71069C... = 56-59 : ~q -> q chi
71070C... = 61-64 : q -> ~q chi
71071C... = 66-69 : ~g -> q ~qbar
71072C... = 71-74 : ~q -> q ~g
71073C... = 76-79 : q -> ~q ~g
71074C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71075C...Note that the order of the decay products is important.
71076C...In each set of four, the variants are ordered as:
71077C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71078C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71079C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71080C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71081
71082 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71083
71084C...Double precision and integer declarations.
71085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71086 IMPLICIT INTEGER(I-N)
71087
71088C...Check input values. Return zero outside allowed phase space.
71089 PYMAEL=0D0
71090 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71091 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71092 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71093 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71094 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71095 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71096
71097C...Initial values and flags.
71098 ICLASS=NI/5
71099 ICOMBI=NI-5*ICLASS
71100 ISSET1=0
71101 ISSET2=0
71102 ISSET4=0
71103
71104C... Phase space.
71105 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71106
71107C...Eikonal expression; also acts as default.
71108 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71109 RLO=PS
71110 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71111 ANUM=0D0
71112 ELSEIF(ICOMBI.EQ.2) THEN
71113 ANUM=(2D0-X1-X2)**2
71114 ELSEIF(ICOMBI.EQ.3) THEN
71115 ANUM=ALPCOR*(2D0-X1-X2)**2
71116 ELSE
71117 ANUM=0.5D0*(2D0-X1-X2)**2
71118 ENDIF
71119 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71120 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71121 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71122 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71123 ICOMBI=0
71124
71125C...V -> q qbar (V = gamma*/Z0/W+-/...).
71126 ELSEIF(ICLASS.EQ.2) THEN
71127 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71128 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71129 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71130 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71131 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71132 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71133 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71134 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71135 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71136 & (-1+R1**2-R2**2+X2)**2
71137 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71138 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71139 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71140 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71141 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71142 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71143 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71144 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71145 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71146 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71147 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71148 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71149 RFO1=RFO1/2.D0
71150 ISSET1=1
71151 ENDIF
71152 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71153 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71154 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71155 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71156 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71157 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71158 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71159 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71160 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71161 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71162 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71163 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71164 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71165 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71166 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71167 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71168 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71169 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71170 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71171 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71172 & +X2)/(-1-R1**2+R2**2+X1)**2
71173 RFO2=RFO2/2.D0
71174 ISSET2=1
71175 ENDIF
71176 IF(ICOMBI.EQ.4) THEN
71177 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71178 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71179 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71180 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71181 & (-1-R1**2+R2**2+X1)**2
71182 RFO4=RFO4
71183 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71184 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71185 & -R1**2*X2**2+X1*X2**2)/
71186 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71187 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71188 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71189 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71190 & (-1+R1**2-R2**2+X2)**2
71191 RFO4=RFO4/2.D0
71192 ISSET4=1
71193 ENDIF
71194
71195C...q -> q V.
71196 ELSEIF(ICLASS.EQ.3) THEN
71197 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71198 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71199 & +R1**2*R2**2-2D0*R2**4)
71200 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71201 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71202 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71203 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71204 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71205 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71206 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71207 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71208 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71209 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71210 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71211 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71212 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71213 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71214 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71215 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71216 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71217 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71218 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71219 ISSET1=1
71220 ENDIF
71221 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71222 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71223 & +R1**2*R2**2-2D0*R2**4)
71224 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71225 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71226 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71227 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71228 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71229 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71230 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71231 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71232 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71233 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71234 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71235 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71236 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71237 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71238 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71239 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71240 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71241 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71242 & +X1*X2**2)/(-2+X1+X2)**2
71243 ISSET2=1
71244 ENDIF
71245 IF(ICOMBI.EQ.4) THEN
71246 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71247 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71248 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71249 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71250 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71251 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71252 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71253 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71254 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71255 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71256 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71257 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71258 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71259 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71260 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71261 & +X1*X2**2)/(2-X1-X2)**2
71262 ISSET4=1
71263 ENDIF
71264
71265C...S -> q qbar (S = h0/H0/A0/H+-/...).
71266 ELSEIF(ICLASS.EQ.4) THEN
71267 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71268 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71269 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71270 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71271 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71272 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71273 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71274 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71275 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71276 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71277 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71278 ISSET1=1
71279 ENDIF
71280 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71281 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71282 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71283 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71284 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71285 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71286 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71287 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71288 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71289 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71290 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71291 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71292 ISSET2=1
71293 ENDIF
71294 IF(ICOMBI.EQ.4) THEN
71295 RLO4=PS*(1D0-R1**2-R2**2)
71296 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71297 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71298 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71299 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71300 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71301 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71302 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71303 ISSET4=1
71304 ENDIF
71305
71306C...q -> q S.
71307 ELSEIF(ICLASS.EQ.5) THEN
71308 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71309 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71310 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71311 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71312 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71313 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71314 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71315 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71316 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71317 & (-1+R1**2-R2**2+X2)**2
71318 ISSET1=1
71319 ENDIF
71320 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71321 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71322 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71323 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71324 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71325 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71326 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71327 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71328 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71329 & (-1+R1**2-R2**2+X2)**2
71330 ISSET2=1
71331 ENDIF
71332 IF(ICOMBI.EQ.4) THEN
71333 RLO4=PS*(1D0+R1**2-R2**2)
71334 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71335 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71336 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71337 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71338 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71339 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71340 ISSET4=1
71341 ENDIF
71342
71343C...V -> ~q ~qbar (~q = squark).
71344 ELSEIF(ICLASS.EQ.6) THEN
71345 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71346 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71347 & (-1-R1**2+R2**2+X1)**2
71348 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71349 & (-1-R1**2+R2**2+X1)
71350 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71351 & /(-1+R1**2-R2**2+X2)**2
71352 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71353 & (-1+R1**2-R2**2+X2)
71354 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71355 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71356 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71357 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71358 ISSET1=1
71359
71360C...~q -> ~q V.
71361 ELSEIF(ICLASS.EQ.7) THEN
71362 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71363 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71364 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71365 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71366 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71367 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71368 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71369 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71370 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71371 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71372 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71373 & (3*(-2+X1+X2))
71374 RFO1=3D0*RFO1/8D0
71375 ISSET1=1
71376
71377C...S -> ~q ~qbar.
71378 ELSEIF(ICLASS.EQ.8) THEN
71379 RLO1=PS
71380 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71381 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71382 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71383 & -R1**2*X2**2+X1*X2**2)/
71384 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71385 RFO1=2D0*RFO1
71386 ISSET1=1
71387
71388C...~q -> ~q S.
71389 ELSEIF(ICLASS.EQ.9) THEN
71390 RLO1=PS
71391 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71392 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71393 & -(X1+X2)/(-2+X1+X2)**2
71394 ISSET1=1
71395
71396C...chi -> q ~qbar (chi = neutralino/chargino).
71397 ELSEIF(ICLASS.EQ.10) THEN
71398 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71399 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71400 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71401 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71402 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71403 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71404 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71405 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71406 & (-1+R1**2-R2**2+X2)**2
71407 ISSET1=1
71408 ENDIF
71409 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71410 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71411 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71412 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71413 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71414 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71415 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71416 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71417 & (-1+R1**2-R2**2+X2)**2
71418 ISSET2=1
71419 ENDIF
71420 IF(ICOMBI.EQ.4) THEN
71421 RLO4=PS*(1+R1**2-R2**2)
71422 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71423 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71424 & +X2+R1**2*X2-X1*X2/2)/
71425 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71426 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71427 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71428 ISSET4=1
71429 ENDIF
71430
71431C...~q -> q chi.
71432 ELSEIF(ICLASS.EQ.11) THEN
71433 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71434 RLO1=PS*(1D0-(R1+R2)**2)
71435 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71436 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71437 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71438 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71439 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71440 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71441 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71442 ISSET1=1
71443 ENDIF
71444 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71445 RLO2=PS*(1D0-(R1-R2)**2)
71446 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71447 & (-2+X1+X2)**2
71448 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71449 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71450 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71451 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71452 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71453 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71454 ISSET2=1
71455 ENDIF
71456 IF(ICOMBI.EQ.4) THEN
71457 RLO4=PS*(1D0-R1**2-R2**2)
71458 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71459 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71460 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71461 & (-1+R1**2-R2**2+X2)**2
71462 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71463 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71464 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71465 ISSET4=1
71466 ENDIF
71467
71468C...q -> ~q chi.
71469 ELSEIF(ICLASS.EQ.12) THEN
71470 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71471 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71472 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71473 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71474 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71475 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71476 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71477 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71478 ISSET1=1
71479 END IF
71480 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71481 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71482 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71483 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71484 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71485 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71486 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71487 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71488 ISSET2=1
71489 END IF
71490 IF(ICOMBI.EQ.4) THEN
71491 RLO4=PS*(1D0-R1**2+R2**2)
71492 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71493 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71494 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71495 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71496 & +R1**2*X2-X1*X2/2-X2**2/2)/
71497 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71498 ISSET4=1
71499 END IF
71500
71501C...~g -> q ~qbar.
71502 ELSEIF(ICLASS.EQ.13) THEN
71503 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71504 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71505 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71506 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71507 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71508 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71509 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71510 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71511 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71512 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71513 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71514 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71515 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71516 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71517 & (3*(-1+R1**2-R2**2+X2)**2)
71518 RFO1=3D0*RFO1/4D0
71519 ISSET1=1
71520 ENDIF
71521 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71522 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71523 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71524 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71525 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71526 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71527 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71528 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71529 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71530 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71531 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71532 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71533 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71534 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71535 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71536 & (3*(-1+R1**2-R2**2+X2)**2)
71537 RFO2=3D0*RFO2/4D0
71538 ISSET2=1
71539 ENDIF
71540 IF(ICOMBI.EQ.4) THEN
71541 RLO4=PS*(1D0+R1**2-R2**2)
71542 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71543 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71544 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71545 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71546 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71547 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71548 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71549 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71550 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71551 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71552 & (3*(-1+R1**2-R2**2+X2)**2)
71553 RFO4=3D0*RFO4/8D0
71554 ISSET4=1
71555 ENDIF
71556
71557C...~q -> q ~g.
71558 ELSEIF(ICLASS.EQ.14) THEN
71559 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71560 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71561 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71562 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71563 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71564 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71565 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71566 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71567 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71568 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71569 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71570 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71571 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71572 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71573 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71574 RFO1=RFO1
71575 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71576 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71577 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71578 RFO1=9D0*RFO1/64D0
71579 ISSET1=1
71580 ENDIF
71581 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71582 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71583 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71584 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71585 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71586 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71587 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71588 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71589 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71590 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71591 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71592 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71593 RFO2=RFO2
71594 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71595 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71596 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71597 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71598 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71599 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71600 RFO2=9D0*RFO2/64D0
71601 ISSET2=1
71602 ENDIF
71603 IF(ICOMBI.EQ.4) THEN
71604 RLO4=PS*(1-R1**2-R2**2)
71605 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71606 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71607 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71608 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71609 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71610 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71611 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71612 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71613 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71614 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71615 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71616 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71617 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71618 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71619 RFO4=9D0*RFO4/128D0
71620 ISSET4=1
71621 ENDIF
71622
71623C...q -> ~q ~g.
71624 ELSEIF(ICLASS.EQ.15) THEN
71625 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71626 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71627 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71628 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71629 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71630 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71631 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71632 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71633 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71634 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71635 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71636 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71637 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71638 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71639 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71640 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71641 RFO1=9D0*RFO1/32D0
71642 ISSET1=1
71643 END IF
71644 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71645 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71646 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71647 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71648 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71649 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71650 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71651 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71652 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71653 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71654 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71655 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71656 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71657 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71658 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71659 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71660 RFO2=9D0*RFO2/32D0
71661 ISSET2=1
71662 END IF
71663 IF(ICOMBI.EQ.4) THEN
71664 RLO4=PS*(1D0-R1**2+R2**2)
71665 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71666 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71667 & -R2**2*X2/2-X1*X2/2)/
71668 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71669 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71670 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71671 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71672 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71673 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71674 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71675 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71676 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71677 RFO4=9D0*RFO4/64D0
71678 ISSET4=1
71679 END IF
71680
71681C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71682 ELSEIF(ICLASS.EQ.16) THEN
71683 RLO=PS
71684 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71685 ANUM=0D0
71686 ELSEIF(ICOMBI.EQ.2) THEN
71687 ANUM=(2D0-X1-X2)**2
71688 ELSEIF(ICOMBI.EQ.3) THEN
71689 ANUM=ALPCOR*(2D0-X1-X2)**2
71690 ELSE
71691 ANUM=0.5D0*(2D0-X1-X2)**2
71692 ENDIF
71693 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71694 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71695 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71696 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71697 RFO=9D0*RFO/4D0
71698 ICOMBI=0
71699 ENDIF
71700
71701C...Find relevant LO and FO expression.
71702 IF(ICOMBI.EQ.0) THEN
71703 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71704 RLO=RLO1
71705 RFO=RFO1
71706 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71707 RLO=RLO2
71708 RFO=RFO2
71709 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71710 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71711 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71712 ELSEIF(ISSET4.EQ.1) THEN
71713 RLO=RLO4
71714 RFO=RFO4
71715 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71716 RLO=0.5D0*(RLO1+RLO2)
71717 RFO=0.5D0*(RFO1+RFO2)
71718 ELSEIF(ISSET1.EQ.1) THEN
71719 RLO=RLO1
71720 RFO=RFO1
71721 ELSE
71722 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71723 RLO=1D0
71724 RFO=0D0
71725 ENDIF
71726
71727C...Output.
71728 PYMAEL=RFO/RLO
71729
71730 RETURN
71731 END
71732
71733C*********************************************************************
71734
71735C...PYBOEI
71736C...Modifies an event so as to approximately take into account
71737C...Bose-Einstein effects according to a simple phenomenological
71738C...parametrization.
71739
71740 SUBROUTINE PYBOEI(NSAV)
71741
71742C...Double precision and integer declarations.
71743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71744 IMPLICIT INTEGER(I-N)
71745 INTEGER PYK,PYCHGE,PYCOMP
71746C...Parameter statement to help give large particle numbers.
71747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71748 &KEXCIT=4000000,KDIMEN=5000000)
71749C...Commonblocks.
71750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71751 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71752 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71753 COMMON/PYINT1/MINT(400),VINT(400)
71754 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71755C...Local arrays and data.
71756 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71757 &BEIW(100),BEI3W(100)
71758 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71759C...Statement function: squared invariant mass.
71760 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71761 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71762
71763C...Boost event to overall CM frame. Calculate CM energy.
71764 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71765 DO 100 J=1,4
71766 DPS(J)=0D0
71767 100 CONTINUE
71768 DO 120 I=1,N
71769 KFA=IABS(K(I,2))
71770 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71771 & .AND.K(I,3).GT.0) THEN
71772 KFMA=IABS(K(K(I,3),2))
71773 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71774 ENDIF
71775 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71776 DO 110 J=1,4
71777 DPS(J)=DPS(J)+P(I,J)
71778 110 CONTINUE
71779 120 CONTINUE
71780 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71781 &-DPS(3)/DPS(4))
71782 PECM=0D0
71783 DO 130 I=1,N
71784 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71785 130 CONTINUE
71786
71787C...Check if we have separated strings
71788
71789C...Reserve copy of particles by species at end of record.
71790 IWP=0
71791 IWN=0
71792 NBE(0)=N+MSTU(3)
71793 NMAX=NBE(0)
71794 SMMIN=PECM
71795 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71796 NBE(IBE)=NBE(IBE-1)
71797 DO 180 I=NSAV+1,N
71798 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71799 DO 140 IIBE=1,IBE-1
71800 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71801 140 CONTINUE
71802 ELSE
71803 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71804 ENDIF
71805 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71806 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71807 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71808 RETURN
71809 ENDIF
71810 NBE(IBE)=NBE(IBE)+1
71811 NMAX=NBE(IBE)
71812 K(NBE(IBE),1)=I
71813 K(NBE(IBE),2)=0
71814 K(NBE(IBE),3)=0
71815 K(NBE(IBE),4)=0
71816 K(NBE(IBE),5)=0
71817 P(NBE(IBE),1)=0.0D0
71818 P(NBE(IBE),2)=0.0D0
71819 P(NBE(IBE),3)=0.0D0
71820 P(NBE(IBE),4)=0.0D0
71821 P(NBE(IBE),5)=0.0D0
71822 SMMIN=MIN(SMMIN,P(I,5))
71823C...Check if particles comes from different W's or Z's
71824 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71825 IM=I
71826 150 IF(K(IM,3).GT.0) THEN
71827 IM=K(IM,3)
71828 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71829 K(NBE(IBE),5)=IM
71830 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71831 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71832 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71833 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71834 ENDIF
71835 ENDIF
71836C...Check if particles comes from different strings.
71837 IF(PARJ(94).GT.0.0D0) THEN
71838 IM=I
71839 160 IF(K(IM,3).GT.0) THEN
71840 IM=K(IM,3)
71841 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71842 K(NBE(IBE),5)=IM
71843 ENDIF
71844 ENDIF
71845 DO 170 J=1,3
71846 P(NBE(IBE),J)=0D0
71847 V(NBE(IBE),J)=0D0
71848 170 CONTINUE
71849 P(NBE(IBE),5)=-1.0D0
71850 180 CONTINUE
71851 190 CONTINUE
71852 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71853
71854C...Calculate separation between W+ and W- or between two Z0's.
71855C...No separation if there has been re-connections.
71856 SIGW=PARJ(93)
71857 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71858 IF(K(IWP,2).EQ.23) THEN
71859 DMW=PMAS(23,1)
71860 DGW=PMAS(23,2)
71861 ELSE
71862 DMW=PMAS(24,1)
71863 DGW=PMAS(24,2)
71864 ENDIF
71865 DMP=P(IWP,5)
71866 DMN=P(IWN,5)
71867 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71868 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71869 TAUP=-TAUPD*LOG(PYR(IDUM))
71870 TAUN=-TAUND*LOG(PYR(IDUM))
71871 DXP=TAUP*PYP(IWP,8)/DMP
71872 DXN=TAUN*PYP(IWN,8)/DMN
71873 DX=DXP+DXN
71874 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71875 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71876 ENDIF
71877
71878C...Add separation between strings.
71879 IF(PARJ(94).GT.0.0D0) THEN
71880 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71881 IWP=-1
71882 IWN=-1
71883 ENDIF
71884
71885 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71886 DO 220 IBE=1,MIN(9,MSTJ(52))
71887 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71888 Q2MIN=PECM**2
71889 I1=K(I1M,1)
71890 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71891 IF(I2M.EQ.I1M) GOTO 200
71892 I2=K(I2M,1)
71893 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71894 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71895 & (P(I1,5)+P(I2,5))**2
71896 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71897 Q2MIN=Q2
71898 ENDIF
71899 200 CONTINUE
71900 P(I1M,5)=Q2MIN
71901 210 CONTINUE
71902 220 CONTINUE
71903 ENDIF
71904
71905C...Tabulate integral for subsequent momentum shift.
71906 DO 400 IBE=1,MIN(9,MSTJ(52))
71907 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71908 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71909 & .LE.1) GOTO 270
71910 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71911 & NBE(7)-NBE(6)).LE.1) GOTO 270
71912 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71913 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71914 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71915 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71916 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71917 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71918 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71919 QDELW=0.1D0*MIN(PMHQ,SIGW)
71920 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71921 IF(MSTJ(51).EQ.1) THEN
71922 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71923 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71924 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71925 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71926 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71927 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71928 BEEXW=EXP(0.5D0*QDELW/SIGW)
71929 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71930 BERT=EXP(-QDEL/PARJ(93))
71931 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71932 BERTW=EXP(-QDELW/SIGW)
71933 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71934 ELSE
71935 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71936 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71937 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71938 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71939 ENDIF
71940 DO 230 IBIN=1,NBIN
71941 QBIN=QDEL*(IBIN-0.5D0)
71942 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71943 IF(MSTJ(51).EQ.1) THEN
71944 BEEX=BEEX*BERT
71945 BEI(IBIN)=BEI(IBIN)*BEEX
71946 ELSE
71947 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
71948 ENDIF
71949 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
71950 230 CONTINUE
71951 DO 240 IBIN=1,NBIN3
71952 QBIN=QDEL3*(IBIN-0.5D0)
71953 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71954 IF(MSTJ(51).EQ.1) THEN
71955 BEEX3=BEEX3*BERT3
71956 BEI3(IBIN)=BEI3(IBIN)*BEEX3
71957 ELSE
71958 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
71959 ENDIF
71960 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
71961 240 CONTINUE
71962 DO 250 IBIN=1,NBINW
71963 QBIN=QDELW*(IBIN-0.5D0)
71964 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71965 IF(MSTJ(51).EQ.1) THEN
71966 BEEXW=BEEXW*BERTW
71967 BEIW(IBIN)=BEIW(IBIN)*BEEXW
71968 ELSE
71969 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
71970 ENDIF
71971 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
71972 250 CONTINUE
71973 DO 260 IBIN=1,NBIN3W
71974 QBIN=QDEL3W*(IBIN-0.5D0)
71975 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
71976 & SQRT(QBIN**2+PMHQ**2)
71977 IF(MSTJ(51).EQ.1) THEN
71978 BEEX3W=BEEX3W*BERT3W
71979 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
71980 ELSE
71981 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
71982 ENDIF
71983 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
71984 260 CONTINUE
71985
71986C...Loop through particle pairs and find old relative momentum.
71987 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
71988 I1=K(I1M,1)
71989 DO 380 I2M=I1M+1,NBE(IBE)
71990 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
71991 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
71992 I2=K(I2M,1)
71993 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
71994 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
71995 IF(Q2OLD.LE.0.0D0) GOTO 380
71996 QOLD=SQRT(Q2OLD)
71997
71998C...Calculate new relative momentum.
71999 QMOV=0.0D0
72000 QMOV3=0.0D0
72001 QMOVW=0.0D0
72002 QMOV3W=0.0D0
72003 IF(QOLD.LT.1D-3*QDEL) THEN
72004 GOTO 280
72005 ELSEIF(QOLD.LE.QDEL) THEN
72006 QMOV=QOLD/3D0
72007 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72008 RBIN=QOLD/QDEL
72009 IBIN=RBIN
72010 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72011 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72012 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72013 ELSE
72014 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72015 ENDIF
72016 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72017 IF(QOLD.LT.1D-3*QDEL3) THEN
72018 GOTO 290
72019 ELSEIF(QOLD.LE.QDEL3) THEN
72020 QMOV3=QOLD/3D0
72021 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72022 RBIN3=QOLD/QDEL3
72023 IBIN3=RBIN3
72024 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72025 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72026 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72027 ELSE
72028 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72029 ENDIF
72030 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72031 RSCALE=1.0D0
72032 IF(MSTJ(54).EQ.2)
72033 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72034 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72035 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72036
72037 IF(QOLD.LT.1D-3*QDELW) THEN
72038 GOTO 300
72039 ELSEIF(QOLD.LE.QDELW) THEN
72040 QMOVW=QOLD/3D0
72041 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72042 RBINW=QOLD/QDELW
72043 IBINW=RBINW
72044 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72045 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72046 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72047 ELSE
72048 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72049 ENDIF
72050 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72051 IF(QOLD.LT.1D-3*QDEL3W) THEN
72052 GOTO 310
72053 ELSEIF(QOLD.LE.QDEL3W) THEN
72054 QMOV3W=QOLD/3D0
72055 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72056 RBIN3W=QOLD/QDEL3W
72057 IBIN3W=RBIN3W
72058 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72059 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72060 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72061 ELSE
72062 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72063 ENDIF
72064 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72065 IF(MSTJ(54).EQ.2)
72066 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72067
72068 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72069 DO 330 J=1,3
72070 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72071 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72072 330 CONTINUE
72073 IF(MSTJ(54).GE.1) THEN
72074 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72075 DO 340 J=1,3
72076 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72077 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72078 340 CONTINUE
72079 ELSEIF(MSTJ(54).LE.-1) THEN
72080 EDEL=P(I1,4)+P(I2,4)-
72081 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72082 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72083 & (P(I1,3)-P(I2,3))**2
72084 WMAX=-1.0D20
72085 MI3=0
72086 MI4=0
72087 S12=SDIP(I1,I2)
72088 SM1=(P(I1,5)+SMMIN)**2
72089 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72090 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72091 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72092 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72093 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72094 I3=K(I3M,1)
72095 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72096 S13=SDIP(I1,I3)
72097 S23=SDIP(I2,I3)
72098 SM3=(P(I3,5)+SMMIN)**2
72099 IF(MSTJ(54).EQ.-2) THEN
72100 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72101 & S23*MIN(SM1,SM3))*SM1)
72102 ELSE
72103 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72104 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72105 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72106 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72107 ENDIF
72108 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72109 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72110 & GOTO 360
72111 ELSE
72112 IF(WMAX*WI.GE.1.0) GOTO 360
72113 ENDIF
72114 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72115 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72116 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72117 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72118 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72119 I4=K(I4M,1)
72120 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72121 & GOTO 350
72122 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72123 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72124 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72125 & GOTO 350
72126 IF(MSTJ(54).EQ.-2) THEN
72127 S14=SDIP(I1,I4)
72128 S24=SDIP(I2,I4)
72129 S34=SDIP(I3,I4)
72130 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72131 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72132 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72133 W=MIN(W,MIN(S23,S24)*S13*S14)
72134 W=1.0D0/W
72135 ELSE
72136C...weight=1-cos(theta)/mtot2
72137 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72138 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72139 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72140 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72141 W=1.0D0/S1234
72142 IF(W.LE.WMAX) GOTO 350
72143 ENDIF
72144 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72145 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72146 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72147 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72148 IF(W.LE.WMAX) GOTO 350
72149 MI3=I3M
72150 MI4=I4M
72151 WMAX=W
72152 350 CONTINUE
72153 360 CONTINUE
72154 IF(MI4.EQ.0) GOTO 380
72155 I3=K(MI3,1)
72156 I4=K(MI4,1)
72157 EOLD=P(I3,4)+P(I4,4)
72158 ENEW=EOLD+EDEL
72159 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72160 & (P(I3,3)+P(I4,3))**2
72161 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72162 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72163 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72164 DO 370 J=1,3
72165 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72166 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72167 370 CONTINUE
72168 ENDIF
72169 380 CONTINUE
72170 390 CONTINUE
72171 400 CONTINUE
72172
72173C...Shift momenta and recalculate energies.
72174 ESUMP=0.0D0
72175 ESUM=0.0D0
72176 PROD=0.0D0
72177 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72178 I=K(IM,1)
72179 ESUMP=ESUMP+P(I,4)
72180 DO 410 J=1,3
72181 P(I,J)=P(I,J)+P(IM,J)
72182 410 CONTINUE
72183 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72184 ESUM=ESUM+P(I,4)
72185 DO 420 J=1,3
72186 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72187 420 CONTINUE
72188 430 CONTINUE
72189
72190 PARJ(96)=0.0D0
72191 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72192 440 ALPHA=(ESUMP-ESUM)/PROD
72193 PARJ(96)=PARJ(96)+ALPHA
72194 PROD=0.0D0
72195 ESUM=0.0D0
72196 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72197 I=K(IM,1)
72198 DO 450 J=1,3
72199 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72200 450 CONTINUE
72201 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72202 ESUM=ESUM+P(I,4)
72203 DO 460 J=1,3
72204 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72205 460 CONTINUE
72206 470 CONTINUE
72207 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72208 & GOTO 440
72209 ENDIF
72210
72211C...Rescale all momenta for energy conservation.
72212 PES=0D0
72213 PQS=0D0
72214 DO 480 I=1,N
72215 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72216 PES=PES+P(I,4)
72217 PQS=PQS+P(I,5)**2/P(I,4)
72218 480 CONTINUE
72219 PARJ(95)=PES-PECM
72220 FAC=(PECM-PQS)/(PES-PQS)
72221 DO 500 I=1,N
72222 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72223 DO 490 J=1,3
72224 P(I,J)=FAC*P(I,J)
72225 490 CONTINUE
72226 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72227 500 CONTINUE
72228
72229C...Boost back to correct reference frame.
72230 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72231 DO 520 I=1,N
72232 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72233 520 CONTINUE
72234
72235 RETURN
72236 END
72237
72238C*********************************************************************
72239
72240C...PYBESQ
72241C...Calculates the momentum shift in a system of two particles assuming
72242C...the relative momentum squared should be shifted to Q2NEW. NI is the
72243C...last position occupied in /PYJETS/.
72244
72245 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72246
72247C...Double precision and integer declarations.
72248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72249 IMPLICIT INTEGER(I-N)
72250 INTEGER PYK,PYCHGE,PYCOMP
72251C...Parameter statement to help give large particle numbers.
72252 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72253 &KEXCIT=4000000,KDIMEN=5000000)
72254C...Commonblocks.
72255 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72256 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72257 SAVE /PYJETS/,/PYDAT1/
72258C...Local arrays and data.
72259 DIMENSION DP(5)
72260 SAVE HC1
72261
72262 IF(MSTJ(55).EQ.0) THEN
72263 DQ2=Q2NEW-Q2OLD
72264 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72265 & (P(I1,3)-P(I2,3))**2
72266 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72267 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72268 SE=P(I1,4)+P(I2,4)
72269 DE=P(I1,4)-P(I2,4)
72270 DQ2SE=DQ2+SE**2
72271 DA=SE*DE*DP12-DP2*DQ2SE
72272 DB=DP2*DQ2SE-DP12**2
72273 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72274 DO 100 J=1,3
72275 PD=HA*(P(I1,J)-P(I2,J))
72276 P(NI+1,J)=PD
72277 P(NI+2,J)=-PD
72278 100 CONTINUE
72279 RETURN
72280 ENDIF
72281
72282 K(NI+1,1)=1
72283 K(NI+2,1)=1
72284 DO 110 J=1,5
72285 P(NI+1,J)=P(I1,J)
72286 P(NI+2,J)=P(I2,J)
72287 DP(J)=P(I1,J)+P(I2,J)
72288 110 CONTINUE
72289
72290C...Boost to cms and rotate first particle to z-axis
72291 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72292 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72293 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72294 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72295 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72296 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72297 P(NI+1,1)=0.0D0
72298 P(NI+1,2)=0.0D0
72299 P(NI+1,3)=PZ
72300 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72301 P(NI+2,1)=0.0D0
72302 P(NI+2,2)=0.0D0
72303 P(NI+2,3)=-PZ
72304 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72305 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72306 CALL PYROBO(NI+1,NI+2,THE,PHI,
72307 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72308
72309 DO 120 J=1,3
72310 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72311 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72312 120 CONTINUE
72313
72314 RETURN
72315 END
72316
72317C*********************************************************************
72318
72319C...PYMASS
72320C...Gives the mass of a particle/parton.
72321
72322 FUNCTION PYMASS(KF)
72323
72324C...Double precision and integer declarations.
72325 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72326 IMPLICIT INTEGER(I-N)
72327 INTEGER PYK,PYCHGE,PYCOMP
72328C...Commonblocks.
72329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72331 SAVE /PYDAT1/,/PYDAT2/
72332
72333C...Reset variables. Compressed code. Special case for popcorn diquarks.
72334 PYMASS=0D0
72335 KFA=IABS(KF)
72336 KC=PYCOMP(KF)
72337 IF(KC.EQ.0) THEN
72338 MSTJ(93)=0
72339 RETURN
72340 ENDIF
72341
72342C...Guarantee use of constituent masses for internal checks.
72343 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72344 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72345 IF(KFA.LE.5) THEN
72346 PYMASS=PARF(100+KFA)
72347 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72348 ELSEIF(KFA.LE.10) THEN
72349 PYMASS=PMAS(KFA,1)
72350 ELSEIF(MSTJ(93).EQ.1) THEN
72351 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72352 ELSE
72353 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72354 ENDIF
72355
72356C...Other masses can be read directly off table.
72357 ELSE
72358 PYMASS=PMAS(KC,1)
72359 ENDIF
72360
72361C...Optional mass broadening according to truncated Breit-Wigner
72362C...(either in m or in m^2).
72363 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72364 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72365 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72366 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72367 ELSE
72368 PM0=PYMASS
72369 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72370 & (PM0*PMAS(KC,2)))
72371 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72372 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72373 & (PMUPP-PMLOW)*PYR(0))))
72374 ENDIF
72375 ENDIF
72376 MSTJ(93)=0
72377
72378 RETURN
72379 END
72380
72381C*********************************************************************
72382
72383C...PYMRUN
72384C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72385C...for Higgs couplings. Everything else sent on to PYMASS.
72386
72387 FUNCTION PYMRUN(KF,Q2)
72388
72389C...Double precision and integer declarations.
72390 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72391 IMPLICIT INTEGER(I-N)
72392 INTEGER PYK,PYCHGE,PYCOMP
72393C...Commonblocks.
72394 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72395 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72396 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72397 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72398
72399C...Most masses not handled here.
72400 KFA=IABS(KF)
72401 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72402 PYMRUN=PYMASS(KF)
72403
72404C...Current-algebra masses, but no Q2 dependence.
72405 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72406 PYMRUN=PARF(90+KFA)
72407
72408C...Running current-algebra masses.
72409 ELSE
72410 AS=PYALPS(Q2)
72411 PYMRUN=PARF(90+KFA)*
72412 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72413 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72414 ENDIF
72415
72416 RETURN
72417 END
72418
72419C*********************************************************************
72420
72421C...PYNAME
72422C...Gives the particle/parton name as a character string.
72423
72424 SUBROUTINE PYNAME(KF,CHAU)
72425
72426C...Double precision and integer declarations.
72427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72428 IMPLICIT INTEGER(I-N)
72429 INTEGER PYK,PYCHGE,PYCOMP
72430C...Commonblocks.
72431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72432 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72433 COMMON/PYDAT4/CHAF(500,2)
72434 CHARACTER CHAF*16
72435 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72436C...Local character variable.
72437 CHARACTER CHAU*16
72438
72439C...Read out code with distinction particle/antiparticle.
72440 CHAU=' '
72441 KC=PYCOMP(KF)
72442 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72443
72444
72445 RETURN
72446 END
72447
72448C*********************************************************************
72449
72450C...PYCHGE
72451C...Gives three times the charge for a particle/parton.
72452
72453 FUNCTION PYCHGE(KF)
72454
72455C...Double precision and integer declarations.
72456 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72457 IMPLICIT INTEGER(I-N)
72458 INTEGER PYK,PYCHGE,PYCOMP
72459C...Commonblocks.
72460 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72461 SAVE /PYDAT2/
72462
72463C...Read out charge and change sign for antiparticle.
72464 PYCHGE=0
72465 KC=PYCOMP(KF)
72466 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72467
72468 RETURN
72469 END
72470
72471C*********************************************************************
72472
72473C...PYCOMP
72474C...Compress the standard KF codes for use in mass and decay arrays;
72475C...also checks whether a given code actually is defined.
72476
72477 FUNCTION PYCOMP(KF)
72478
72479C...Double precision and integer declarations.
72480 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72481 IMPLICIT INTEGER(I-N)
72482 INTEGER PYK,PYCHGE,PYCOMP
72483C...Commonblocks.
72484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72486 SAVE /PYDAT1/,/PYDAT2/
72487C...Local arrays and saved data.
72488 DIMENSION KFORD(100:500),KCORD(101:500)
72489 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72490
72491C...Whenever necessary reorder codes for faster search.
72492 IF(MSTU(20).EQ.0) THEN
72493 NFORD=100
72494 KFORD(100)=0
72495 DO 120 I=101,500
72496 KFA=KCHG(I,4)
72497 IF(KFA.LE.100) GOTO 120
72498 NFORD=NFORD+1
72499 DO 100 I1=NFORD-1,0,-1
72500 IF(KFA.GE.KFORD(I1)) GOTO 110
72501 KFORD(I1+1)=KFORD(I1)
72502 KCORD(I1+1)=KCORD(I1)
72503 100 CONTINUE
72504 110 KFORD(I1+1)=KFA
72505 KCORD(I1+1)=I
72506 120 CONTINUE
72507 MSTU(20)=1
72508 KFLAST=0
72509 KCLAST=0
72510 ENDIF
72511
72512C...Fast action if same code as in latest call.
72513 IF(KF.EQ.KFLAST) THEN
72514 PYCOMP=KCLAST
72515 RETURN
72516 ENDIF
72517
72518C...Starting values. Remove internal diquark flags.
72519 PYCOMP=0
72520 KFA=IABS(KF)
72521 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72522 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72523
72524C...Simple cases: direct translation.
72525 IF(KFA.GT.KFORD(NFORD)) THEN
72526 ELSEIF(KFA.LE.100) THEN
72527 PYCOMP=KFA
72528
72529C...Else binary search.
72530 ELSE
72531 IMIN=100
72532 IMAX=NFORD+1
72533 130 IAVG=(IMIN+IMAX)/2
72534 IF(KFORD(IAVG).GT.KFA) THEN
72535 IMAX=IAVG
72536 IF(IMAX.GT.IMIN+1) GOTO 130
72537 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72538 IMIN=IAVG
72539 IF(IMAX.GT.IMIN+1) GOTO 130
72540 ELSE
72541 PYCOMP=KCORD(IAVG)
72542 ENDIF
72543 ENDIF
72544
72545C...Check if antiparticle allowed.
72546 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72547 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72548 ENDIF
72549
72550C...Save codes for possible future fast action.
72551 KFLAST=KF
72552 KCLAST=PYCOMP
72553
72554 RETURN
72555 END
72556
72557C*********************************************************************
72558
72559C...PYERRM
72560C...Informs user of errors in program execution.
72561
72562 SUBROUTINE PYERRM(MERR,CHMESS)
72563
72564C...Double precision and integer declarations.
72565 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72566 IMPLICIT INTEGER(I-N)
72567 INTEGER PYK,PYCHGE,PYCOMP
72568C...Commonblocks.
72569 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72570 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72571 SAVE /PYJETS/,/PYDAT1/
72572C...Local character variable.
72573 CHARACTER CHMESS*(*)
72574
72575C...Write first few warnings, then be silent.
72576 IF(MERR.LE.10) THEN
72577 MSTU(27)=MSTU(27)+1
72578 MSTU(28)=MERR
72579 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72580 & MERR,MSTU(31),CHMESS
72581
72582C...Write first few errors, then be silent or stop program.
72583 ELSEIF(MERR.LE.20) THEN
72584 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72585 MSTU(30)=MSTU(30)+1
72586 MSTU(24)=MERR-10
72587 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72588 & MERR-10,MSTU(31),CHMESS
72589 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72590 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72591 WRITE(MSTU(11),5200)
72592 IF(MERR.NE.17) CALL PYLIST(2)
72593 CALL PYSTOP(3)
72594 ENDIF
72595
72596C...Stop program in case of irreparable error.
72597 ELSE
72598 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72599 CALL PYSTOP(3)
72600 ENDIF
72601
72602C...Formats for output.
72603 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72604 &' PYEXEC calls:'/5X,A)
72605 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72606 &' PYEXEC calls:'/5X,A)
72607 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72608 &'event!')
72609 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72610 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72611
72612 RETURN
72613 END
72614
72615C*********************************************************************
72616
72617C...PYALEM
72618C...Calculates the running alpha_electromagnetic.
72619
72620 FUNCTION PYALEM(Q2)
72621
72622C...Double precision and integer declarations.
72623 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72624 IMPLICIT INTEGER(I-N)
72625 INTEGER PYK,PYCHGE,PYCOMP
72626C...Commonblocks.
72627 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72628 SAVE /PYDAT1/
72629
72630C...Calculate real part of photon vacuum polarization.
72631C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72632C...For hadrons use parametrization of H. Burkhardt et al.
72633C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72634 AEMPI=PARU(101)/(3D0*PARU(1))
72635 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72636 RPIGG=0D0
72637 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72638 RPIGG=0D0
72639 ELSEIF(MSTU(101).EQ.2) THEN
72640 RPIGG=1D0-PARU(101)/PARU(103)
72641 ELSEIF(Q2.LT.0.09D0) THEN
72642 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72643 ELSEIF(Q2.LT.9D0) THEN
72644 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72645 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72646 ELSEIF(Q2.LT.1D4) THEN
72647 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72648 & 0.00299D0*LOG(1D0+Q2)
72649 ELSE
72650 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72651 & 0.00293D0*LOG(1D0+Q2)
72652 ENDIF
72653
72654C...Calculate running alpha_em.
72655 PYALEM=PARU(101)/(1D0-RPIGG)
72656 PARU(108)=PYALEM
72657
72658 RETURN
72659 END
72660
72661C*********************************************************************
72662
72663C...PYALPS
72664C...Gives the value of alpha_strong.
72665
72666 FUNCTION PYALPS(Q2)
72667
72668C...Double precision and integer declarations.
72669 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72670 IMPLICIT INTEGER(I-N)
72671 INTEGER PYK,PYCHGE,PYCOMP
72672C...Commonblocks.
72673 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72674 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72675 SAVE /PYDAT1/,/PYDAT2/
72676C...Coefficients for second-order threshold matching.
72677C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72678 DIMENSION STEPDN(6),STEPUP(6)
72679c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72680c &(2D0*321D0/3703D0),0D0/
72681c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72682c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72683 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72684 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72685
72686C...Constant alpha_strong trivial. Pick artificial Lambda.
72687 IF(MSTU(111).LE.0) THEN
72688 PYALPS=PARU(111)
72689 MSTU(118)=MSTU(112)
72690 PARU(117)=0.2D0
72691 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72692 & ((33D0-2D0*MSTU(112))*PARU(111)))
72693 PARU(118)=PARU(111)
72694 RETURN
72695 ENDIF
72696
72697C...Find effective Q2, number of flavours and Lambda.
72698 Q2EFF=Q2
72699 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72700 NF=MSTU(112)
72701 ALAM2=PARU(112)**2
72702 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72703 Q2THR=PARU(113)*PMAS(NF,1)**2
72704 IF(Q2EFF.LT.Q2THR) THEN
72705 NF=NF-1
72706 Q2RAT=Q2THR/ALAM2
72707 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72708 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72709 GOTO 100
72710 ENDIF
72711 ENDIF
72712 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72713 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72714 IF(Q2EFF.GT.Q2THR) THEN
72715 NF=NF+1
72716 Q2RAT=Q2THR/ALAM2
72717 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72718 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72719 GOTO 110
72720 ENDIF
72721 ENDIF
72722 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72723 PARU(117)=SQRT(ALAM2)
72724
72725C...Evaluate first or second order alpha_strong.
72726 B0=(33D0-2D0*NF)/6D0
72727 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72728 IF(MSTU(111).EQ.1) THEN
72729 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72730 ELSE
72731 B1=(153D0-19D0*NF)/6D0
72732 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72733 & (B0**2*ALGQ)))
72734 ENDIF
72735 MSTU(118)=NF
72736 PARU(118)=PYALPS
72737
72738 RETURN
72739 END
72740
72741C*********************************************************************
72742
72743C...PYANGL
72744C...Reconstructs an angle from given x and y coordinates.
72745
72746 FUNCTION PYANGL(X,Y)
72747
72748C...Double precision and integer declarations.
72749 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72750 IMPLICIT INTEGER(I-N)
72751 INTEGER PYK,PYCHGE,PYCOMP
72752C...Commonblocks.
72753 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72754 SAVE /PYDAT1/
72755
72756 PYANGL=0D0
72757 R=SQRT(X**2+Y**2)
72758 IF(R.LT.1D-20) RETURN
72759 IF(ABS(X)/R.LT.0.8D0) THEN
72760 PYANGL=SIGN(ACOS(X/R),Y)
72761 ELSE
72762 PYANGL=ASIN(Y/R)
72763 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72764 PYANGL=PARU(1)-PYANGL
72765 ELSEIF(X.LT.0D0) THEN
72766 PYANGL=-PARU(1)-PYANGL
72767 ENDIF
72768 ENDIF
72769
72770 RETURN
72771 END
72772
72773C*********************************************************************
72774
72775C...PYROBO
72776C...Performs rotations and boosts.
72777
72778 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72779
72780C...Double precision and integer declarations.
72781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72782 IMPLICIT INTEGER(I-N)
72783 INTEGER PYK,PYCHGE,PYCOMP
72784C...Commonblocks.
72785 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72786 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72787 SAVE /PYJETS/,/PYDAT1/
72788C...Local arrays.
72789 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72790
72791C...Find and check range of rotation/boost.
72792 IMIN=IMI
72793 IF(IMIN.LE.0) IMIN=1
72794 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72795 IMAX=IMA
72796 IF(IMAX.LE.0) IMAX=N
72797 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72798 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72799 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72800 RETURN
72801 ENDIF
72802
72803C...Optional resetting of V (when not set before.)
72804 IF(MSTU(33).NE.0) THEN
72805 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72806 DO 100 J=1,5
72807 V(I,J)=0D0
72808 100 CONTINUE
72809 110 CONTINUE
72810 MSTU(33)=0
72811 ENDIF
72812
72813C...Rotate, typically from z axis to direction (theta,phi).
72814 IF(THE**2+PHI**2.GT.1D-20) THEN
72815 ROT(1,1)=COS(THE)*COS(PHI)
72816 ROT(1,2)=-SIN(PHI)
72817 ROT(1,3)=SIN(THE)*COS(PHI)
72818 ROT(2,1)=COS(THE)*SIN(PHI)
72819 ROT(2,2)=COS(PHI)
72820 ROT(2,3)=SIN(THE)*SIN(PHI)
72821 ROT(3,1)=-SIN(THE)
72822 ROT(3,2)=0D0
72823 ROT(3,3)=COS(THE)
72824 DO 140 I=IMIN,IMAX
72825 IF(K(I,1).LE.0) GOTO 140
72826 DO 120 J=1,3
72827 PR(J)=P(I,J)
72828 VR(J)=V(I,J)
72829 120 CONTINUE
72830 DO 130 J=1,3
72831 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72832 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72833 130 CONTINUE
72834 140 CONTINUE
72835 ENDIF
72836
72837C...Boost, typically from rest to momentum/energy=beta.
72838 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72839 DBX=BEX
72840 DBY=BEY
72841 DBZ=BEZ
72842 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72843 EPS1=1D0-1D-12
72844 IF(DB.GT.EPS1) THEN
72845C...Rescale boost vector if too close to unity.
72846 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72847 DBX=DBX*(EPS1/DB)
72848 DBY=DBY*(EPS1/DB)
72849 DBZ=DBZ*(EPS1/DB)
72850 DB=EPS1
72851 ENDIF
72852 DGA=1D0/SQRT(1D0-DB**2)
72853 DO 160 I=IMIN,IMAX
72854 IF(K(I,1).LE.0) GOTO 160
72855 DO 150 J=1,4
72856 DP(J)=P(I,J)
72857 DV(J)=V(I,J)
72858 150 CONTINUE
72859 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72860 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72861 P(I,1)=DP(1)+DGABP*DBX
72862 P(I,2)=DP(2)+DGABP*DBY
72863 P(I,3)=DP(3)+DGABP*DBZ
72864 P(I,4)=DGA*(DP(4)+DBP)
72865 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72866 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72867 V(I,1)=DV(1)+DGABV*DBX
72868 V(I,2)=DV(2)+DGABV*DBY
72869 V(I,3)=DV(3)+DGABV*DBZ
72870 V(I,4)=DGA*(DV(4)+DBV)
72871 160 CONTINUE
72872 ENDIF
72873
72874 RETURN
72875 END
72876
72877C*********************************************************************
72878
72879C...PYEDIT
72880C...Performs global manipulations on the event record, in particular
72881C...to exclude unstable or undetectable partons/particles.
72882
72883 SUBROUTINE PYEDIT(MEDIT)
72884
72885C...Double precision and integer declarations.
72886 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72887 IMPLICIT INTEGER(I-N)
72888 INTEGER PYK,PYCHGE,PYCOMP
72889C...Parameter statement to help give large particle numbers.
72890 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72891 &KEXCIT=4000000,KDIMEN=5000000)
72892C...Commonblocks.
72893 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72894 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72895 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72896 COMMON/PYCTAG/NCT,MCT(4000,2)
72897 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72898C...Local arrays.
72899 DIMENSION NS(2),PTS(2),PLS(2)
72900
72901C...Remove unwanted partons/particles.
72902 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72903 IMAX=N
72904 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72905 I1=MAX(1,MSTU(1))-1
72906 DO 110 I=MAX(1,MSTU(1)),IMAX
72907 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72908 IF(MEDIT.EQ.1) THEN
72909 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72910 ELSEIF(MEDIT.EQ.2) THEN
72911 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72912 KC=PYCOMP(K(I,2))
72913 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72914 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72915 & K(I,2).EQ.KSUSY1+39) GOTO 110
72916 ELSEIF(MEDIT.EQ.3) THEN
72917 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72918 KC=PYCOMP(K(I,2))
72919 IF(KC.EQ.0) GOTO 110
72920 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72921 ELSEIF(MEDIT.EQ.5) THEN
72922 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72923 KC=PYCOMP(K(I,2))
72924 IF(KC.EQ.0) GOTO 110
72925 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72926 & KCHG(KC,2).EQ.0) GOTO 110
72927 ENDIF
72928
72929C...Pack remaining partons/particles. Origin no longer known.
72930 I1=I1+1
72931 DO 100 J=1,5
72932 K(I1,J)=K(I,J)
72933 P(I1,J)=P(I,J)
72934 V(I1,J)=V(I,J)
72935 100 CONTINUE
72936 K(I1,3)=0
72937 110 CONTINUE
72938 IF(I1.LT.N) MSTU(3)=0
72939 IF(I1.LT.N) MSTU(70)=0
72940 N=I1
72941
72942C...Selective removal of class of entries. New position of retained.
72943 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72944 I1=0
72945 DO 120 I=1,N
72946 K(I,3)=MOD(K(I,3),MSTU(5))
72947 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
72948 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
72949 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
72950 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
72951 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
72952 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
72953 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
72954 I1=I1+1
72955 K(I,3)=K(I,3)+MSTU(5)*I1
72956 120 CONTINUE
72957
72958C...Find new event history information and replace old.
72959 DO 140 I=1,N
72960 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
72961 & K(I,3)/MSTU(5).EQ.0) GOTO 140
72962 ID=I
72963 130 IM=MOD(K(ID,3),MSTU(5))
72964 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
72965 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
72966 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
72967 ID=IM
72968 GOTO 130
72969 ENDIF
72970 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
72971 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
72972 & K(IM,2).EQ.94) THEN
72973 ID=IM
72974 GOTO 130
72975 ENDIF
72976 ENDIF
72977 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
72978 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
72979 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
72980 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
72981 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
72982 & K(K(I,4),3)/MSTU(5)
72983 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
72984 & K(K(I,5),3)/MSTU(5)
72985 ELSE
72986 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
72987 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
72988 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
72989 KCD=MOD(K(I,4),MSTU(5))
72990 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72991 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72992 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
72993 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
72994 KCD=MOD(K(I,5),MSTU(5))
72995 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
72996 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
72997 ENDIF
72998 140 CONTINUE
72999
73000C...Pack remaining entries.
73001 I1=0
73002 MSTU90=MSTU(90)
73003 MSTU(90)=0
73004 DO 170 I=1,N
73005 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73006 I1=I1+1
73007 DO 150 J=1,5
73008 K(I1,J)=K(I,J)
73009 P(I1,J)=P(I,J)
73010 V(I1,J)=V(I,J)
73011 150 CONTINUE
73012C...Also update LHA1 colour tags
73013 MCT(I1,1)=MCT(I,1)
73014 MCT(I1,2)=MCT(I,2)
73015 K(I1,3)=MOD(K(I1,3),MSTU(5))
73016 DO 160 IZ=1,MSTU90
73017 IF(I.EQ.MSTU(90+IZ)) THEN
73018 MSTU(90)=MSTU(90)+1
73019 MSTU(90+MSTU(90))=I1
73020 PARU(90+MSTU(90))=PARU(90+IZ)
73021 ENDIF
73022 160 CONTINUE
73023 170 CONTINUE
73024 IF(I1.LT.N) MSTU(3)=0
73025 IF(I1.LT.N) MSTU(70)=0
73026 N=I1
73027
73028C...Fill in some missing daughter pointers (lost in colour flow).
73029 ELSEIF(MEDIT.EQ.16) THEN
73030 DO 220 I=1,N
73031 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73032 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73033C...Find daughters who point to mother.
73034 DO 180 I1=I+1,N
73035 IF(K(I1,3).NE.I) THEN
73036 ELSEIF(K(I,4).EQ.0) THEN
73037 K(I,4)=I1
73038 ELSE
73039 K(I,5)=I1
73040 ENDIF
73041 180 CONTINUE
73042 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73043 IF(K(I,4).NE.0) GOTO 220
73044C...Find daughters who point to documentation version of mother.
73045 IM=K(I,3)
73046 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73047 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73048 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73049 DO 190 I1=I+1,N
73050 IF(K(I1,3).NE.IM) THEN
73051 ELSEIF(K(I,4).EQ.0) THEN
73052 K(I,4)=I1
73053 ELSE
73054 K(I,5)=I1
73055 ENDIF
73056 190 CONTINUE
73057 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73058 IF(K(I,4).NE.0) GOTO 220
73059C...Find daughters who point to documentation daughters who,
73060C...in their turn, point to documentation mother.
73061 ID1=IM
73062 ID2=IM
73063 DO 200 I1=IM+1,I-1
73064 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73065 ID2=I1
73066 IF(ID1.EQ.IM) ID1=I1
73067 ENDIF
73068 200 CONTINUE
73069 DO 210 I1=I+1,N
73070 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73071 ELSEIF(K(I,4).EQ.0) THEN
73072 K(I,4)=I1
73073 ELSE
73074 K(I,5)=I1
73075 ENDIF
73076 210 CONTINUE
73077 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73078 220 CONTINUE
73079
73080C...Save top entries at bottom of PYJETS commonblock.
73081 ELSEIF(MEDIT.EQ.21) THEN
73082 IF(2*N.GE.MSTU(4)) THEN
73083 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73084 RETURN
73085 ENDIF
73086 DO 240 I=1,N
73087 DO 230 J=1,5
73088 K(MSTU(4)-I,J)=K(I,J)
73089 P(MSTU(4)-I,J)=P(I,J)
73090 V(MSTU(4)-I,J)=V(I,J)
73091 230 CONTINUE
73092 240 CONTINUE
73093 MSTU(32)=N
73094
73095C...Restore bottom entries of commonblock PYJETS to top.
73096 ELSEIF(MEDIT.EQ.22) THEN
73097 DO 260 I=1,MSTU(32)
73098 DO 250 J=1,5
73099 K(I,J)=K(MSTU(4)-I,J)
73100 P(I,J)=P(MSTU(4)-I,J)
73101 V(I,J)=V(MSTU(4)-I,J)
73102 250 CONTINUE
73103 260 CONTINUE
73104 N=MSTU(32)
73105
73106C...Mark primary entries at top of commonblock PYJETS as untreated.
73107 ELSEIF(MEDIT.EQ.23) THEN
73108 I1=0
73109 DO 270 I=1,N
73110 KH=K(I,3)
73111 IF(KH.GE.1) THEN
73112 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73113 ENDIF
73114 IF(KH.NE.0) GOTO 280
73115 I1=I1+1
73116 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73117 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73118 270 CONTINUE
73119 280 N=I1
73120
73121C...Place largest axis along z axis and second largest in xy plane.
73122 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73123 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73124 & P(MSTU(61),2)),0D0,0D0,0D0)
73125 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73126 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73127 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73128 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73129 IF(MEDIT.EQ.31) RETURN
73130
73131C...Rotate to put slim jet along +z axis.
73132 DO 290 IS=1,2
73133 NS(IS)=0
73134 PTS(IS)=0D0
73135 PLS(IS)=0D0
73136 290 CONTINUE
73137 DO 300 I=1,N
73138 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73139 IF(MSTU(41).GE.2) THEN
73140 KC=PYCOMP(K(I,2))
73141 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73142 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73143 & K(I,2).EQ.KSUSY1+39) GOTO 300
73144 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73145 & .EQ.0) GOTO 300
73146 ENDIF
73147 IS=2D0-SIGN(0.5D0,P(I,3))
73148 NS(IS)=NS(IS)+1
73149 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73150 300 CONTINUE
73151 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73152 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73153
73154C...Rotate to put second largest jet into -z,+x quadrant.
73155 DO 310 I=1,N
73156 IF(P(I,3).GE.0D0) GOTO 310
73157 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73158 IF(MSTU(41).GE.2) THEN
73159 KC=PYCOMP(K(I,2))
73160 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73161 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73162 & K(I,2).EQ.KSUSY1+39) GOTO 310
73163 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73164 & .EQ.0) GOTO 310
73165 ENDIF
73166 IS=2D0-SIGN(0.5D0,P(I,1))
73167 PLS(IS)=PLS(IS)-P(I,3)
73168 310 CONTINUE
73169 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73170 & 0D0,0D0,0D0)
73171 ENDIF
73172
73173 RETURN
73174 END
73175
73176C*********************************************************************
73177
73178C...PYLIST
73179C...Gives program heading, or lists an event, or particle
73180C...data, or current parameter values.
73181
73182 SUBROUTINE PYLIST(MLIST)
73183
73184C...Double precision and integer declarations.
73185 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73186 IMPLICIT INTEGER(I-N)
73187 INTEGER PYK,PYCHGE,PYCOMP
73188C...Parameter statement to help give large particle numbers.
73189 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73190 &KEXCIT=4000000,KDIMEN=5000000)
73191
73192C...HEPEVT commonblock.
73193 PARAMETER (NMXHEP=4000)
73194 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73195 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73196 DOUBLE PRECISION PHEP,VHEP
73197 SAVE /HEPEVT/
73198
73199C...User process event common block.
73200 INTEGER MAXNUP
73201 PARAMETER (MAXNUP=500)
73202 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73203 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73204 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73205 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73206 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73207 SAVE /HEPEUP/
73208
73209C...Commonblocks.
73210 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73214 COMMON/PYCTAG/NCT,MCT(4000,2)
73215 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73216C...Local arrays, character variables and data.
73217 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73218 DIMENSION PS(6)
73219 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73220
73221C...Initialization printout: version number and date of last change.
73222 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73223 CALL PYLOGO
73224 MSTU(12)=12345
73225 IF(MLIST.EQ.0) RETURN
73226 ENDIF
73227
73228C...List event data, including additional lines after N.
73229 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73230 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73231 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73232 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73233 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73234 LMX=12
73235 IF(MLIST.GE.2) LMX=16
73236 ISTR=0
73237 IMAX=N
73238 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73239 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73240 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73241 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73242 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73243
73244C...Get particle name, pad it and check it is not too long.
73245 CALL PYNAME(K(I,2),CHAP)
73246 LEN=0
73247 DO 100 LEM=1,16
73248 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73249 100 CONTINUE
73250 MDL=(K(I,1)+19)/10
73251 LDL=0
73252 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73253 CHAC=CHAP
73254 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73255 ELSE
73256 LDL=1
73257 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73258 IF(LEN.EQ.0) THEN
73259 CHAC=CHDL(MDL)(1:2*LDL)//' '
73260 ELSE
73261 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73262 & CHDL(MDL)(LDL+1:2*LDL)//' '
73263 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73264 ENDIF
73265 ENDIF
73266
73267C...Add information on string connection.
73268 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73269 & THEN
73270 KC=PYCOMP(K(I,2))
73271 KCC=0
73272 IF(KC.NE.0) KCC=KCHG(KC,2)
73273 IF(IABS(K(I,2)).EQ.39) THEN
73274 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73275 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73276 ISTR=1
73277 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73278 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73279 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73280 ELSEIF(KCC.NE.0) THEN
73281 ISTR=0
73282 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73283 ENDIF
73284 ENDIF
73285 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73286 & CHAC(LMX-1:LMX-1)='I'
73287
73288C...Write data for particle/jet.
73289 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73290 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73291 & (P(I,J2),J2=1,5)
73292 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73293 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73294 & (P(I,J2),J2=1,5)
73295 ELSEIF(MLIST.EQ.1) THEN
73296 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73297 & (P(I,J2),J2=1,5)
73298 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73299 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73300 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73301 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73302 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73303 & (P(I,J2),J2=1,5)
73304 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73305 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73306 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73307 & ,10000),MCT(I,1),MCT(I,2)
73308 ELSE
73309 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73310 & (P(I,J2),J2=1,5)
73311 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73312 & ,MCT(I,1),MCT(I,2)
73313 ENDIF
73314 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73315
73316C...Insert extra separator lines specified by user.
73317 IF(MSTU(70).GE.1) THEN
73318 ISEP=0
73319 DO 110 J=1,MIN(10,MSTU(70))
73320 IF(I.EQ.MSTU(70+J)) ISEP=1
73321 110 CONTINUE
73322 IF(ISEP.EQ.1) THEN
73323 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73324 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73325 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73326 ENDIF
73327 ENDIF
73328 120 CONTINUE
73329
73330C...Sum of charges and momenta.
73331 DO 130 J=1,6
73332 PS(J)=PYP(0,J)
73333 130 CONTINUE
73334 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73335 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73336 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73337 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73338 ELSEIF(MLIST.EQ.1) THEN
73339 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73340 ELSEIF(MLIST.LE.3) THEN
73341 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73342 ELSE
73343 WRITE(MSTU(11),7000) PS(6)
73344 ENDIF
73345
73346C...Simple listing of HEPEVT entries (mainly for test purposes).
73347 ELSEIF(MLIST.EQ.5) THEN
73348 WRITE(MSTU(11),7100)
73349 DO 140 I=1,NHEP
73350 IF(ISTHEP(I).EQ.0) GOTO 140
73351 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73352 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73353 140 CONTINUE
73354
73355
73356C...Simple listing of user-process entries (mainly for test purposes).
73357 ELSEIF(MLIST.EQ.7) THEN
73358 WRITE(MSTU(11),7300)
73359 DO 150 I=1,NUP
73360 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73361 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73362 150 CONTINUE
73363
73364C...Give simple list of KF codes defined in program.
73365 ELSEIF(MLIST.EQ.11) THEN
73366 WRITE(MSTU(11),7500)
73367 DO 160 KF=1,80
73368 CALL PYNAME(KF,CHAP)
73369 CALL PYNAME(-KF,CHAN)
73370 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73371 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73372 160 CONTINUE
73373 DO 190 KFLS=1,3,2
73374 DO 180 KFLA=1,5
73375 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73376 KF=1000*KFLA+100*KFLB+KFLS
73377 CALL PYNAME(KF,CHAP)
73378 CALL PYNAME(-KF,CHAN)
73379 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73380 170 CONTINUE
73381 180 CONTINUE
73382 190 CONTINUE
73383 DO 220 KMUL=0,5
73384 KFLS=3
73385 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73386 IF(KMUL.EQ.5) KFLS=5
73387 KFLR=0
73388 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73389 IF(KMUL.EQ.4) KFLR=2
73390 DO 210 KFLB=1,5
73391 DO 200 KFLC=1,KFLB-1
73392 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73393 CALL PYNAME(KF,CHAP)
73394 CALL PYNAME(-KF,CHAN)
73395 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73396 IF(KF.EQ.311) THEN
73397 KFK=130
73398 CALL PYNAME(KFK,CHAP)
73399 WRITE(MSTU(11),7600) KFK,CHAP
73400 KFK=310
73401 CALL PYNAME(KFK,CHAP)
73402 WRITE(MSTU(11),7600) KFK,CHAP
73403 ENDIF
73404 200 CONTINUE
73405 KF=10000*KFLR+110*KFLB+KFLS
73406 CALL PYNAME(KF,CHAP)
73407 WRITE(MSTU(11),7600) KF,CHAP
73408 210 CONTINUE
73409 220 CONTINUE
73410 KF=100443
73411 CALL PYNAME(KF,CHAP)
73412 WRITE(MSTU(11),7600) KF,CHAP
73413 KF=100553
73414 CALL PYNAME(KF,CHAP)
73415 WRITE(MSTU(11),7600) KF,CHAP
73416 DO 260 KFLSP=1,3
73417 KFLS=2+2*(KFLSP/3)
73418 DO 250 KFLA=1,5
73419 DO 240 KFLB=1,KFLA
73420 DO 230 KFLC=1,KFLB
73421 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73422 & GOTO 230
73423 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73424 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73425 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73426 CALL PYNAME(KF,CHAP)
73427 CALL PYNAME(-KF,CHAN)
73428 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73429 230 CONTINUE
73430 240 CONTINUE
73431 250 CONTINUE
73432 260 CONTINUE
73433 DO 270 KC=1,500
73434 KF=KCHG(KC,4)
73435 IF(KF.LT.1000000) GOTO 270
73436 CALL PYNAME(KF,CHAP)
73437 CALL PYNAME(-KF,CHAN)
73438 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73439 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73440 270 CONTINUE
73441
73442C...List parton/particle data table. Check whether to be listed.
73443 ELSEIF(MLIST.EQ.12) THEN
73444 WRITE(MSTU(11),7700)
73445 DO 300 KC=1,MSTU(6)
73446 KF=KCHG(KC,4)
73447 IF(KF.EQ.0) GOTO 300
73448 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73449 & GOTO 300
73450
73451C...Find particle name and mass. Print information.
73452 CALL PYNAME(KF,CHAP)
73453 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73454 CALL PYNAME(-KF,CHAN)
73455 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73456 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73457
73458C...Particle decay: channel number, branching ratios, matrix element,
73459C...decay products.
73460 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73461 DO 280 J=1,5
73462 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73463 280 CONTINUE
73464 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73465 & (CHAD(J),J=1,5)
73466 290 CONTINUE
73467 300 CONTINUE
73468
73469C...List parameter value table.
73470 ELSEIF(MLIST.EQ.13) THEN
73471 WRITE(MSTU(11),8000)
73472 DO 310 I=1,200
73473 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73474 310 CONTINUE
73475 ENDIF
73476
73477C...Format statements for output on unit MSTU(11) (by default 6).
73478 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73479 &5X,'KF orig p_x p_y p_z E m'/)
73480 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73481 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73482 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73483 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73484 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73485 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73486 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73487 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73488 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73489 & ,' C tag AC tag'/)
73490 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73491 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73492 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73493 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73494 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73495 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73496 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73497 6200 FORMAT(66X,5(1X,F12.3))
73498 6300 FORMAT(1X,78('='))
73499 6400 FORMAT(1X,130('='))
73500 6500 FORMAT(1X,65('='))
73501 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73502 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73503 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73504 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73505 &5F13.5)
73506 7000 FORMAT(19X,'sum charge:',F6.2)
73507 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73508 &//' I IST ID Mothers Daughters p_x p_y p_z',
73509 &' E m')
73510 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73511 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73512 &//' I IST ID Mothers Colours p_x p_y p_z',
73513 &' E m')
73514 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73515 7500 FORMAT(///20X,'List of KF codes in program'/)
73516 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73517 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73518 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73519 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73520 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73521 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73522 &1X,1P,E13.5,3X,I2)
73523 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73524 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73525 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73526 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73527
73528 RETURN
73529 END
73530
73531C*********************************************************************
73532
73533C...PYLOGO
73534C...Writes a logo for the program.
73535
73536 SUBROUTINE PYLOGO
73537
73538C...Double precision and integer declarations.
73539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73540 IMPLICIT INTEGER(I-N)
73541 INTEGER PYK,PYCHGE,PYCOMP
73542C...Parameter for length of information block.
73543 PARAMETER (IREFER=21)
73544C...Commonblocks.
73545 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73546 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73547 SAVE /PYDAT1/,/PYPARS/
73548C...Local arrays and character variables.
73549 INTEGER IDATI(6)
73550 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73551 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73552
73553C...Data on months, logo, titles, and references.
73554 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73555 &'Oct','Nov','Dec'/
73556 DATA (LOGO(J),J=1,19)/
73557 &' *......* ',
73558 &' *:::!!:::::::::::* ',
73559 &' *::::::!!::::::::::::::* ',
73560 &' *::::::::!!::::::::::::::::* ',
73561 &' *:::::::::!!:::::::::::::::::* ',
73562 &' *:::::::::!!:::::::::::::::::* ',
73563 &' *::::::::!!::::::::::::::::*! ',
73564 &' *::::::!!::::::::::::::* !! ',
73565 &' !! *:::!!:::::::::::* !! ',
73566 &' !! !* -><- * !! ',
73567 &' !! !! !! ',
73568 &' !! !! !! ',
73569 &' !! !! ',
73570 &' !! lh !! ',
73571 &' !! !! ',
73572 &' !! hh !! ',
73573 &' !! ll !! ',
73574 &' !! !! ',
73575 &' !! '/
73576 DATA (LOGO(J),J=20,38)/
73577 &'Welcome to the Lund Monte Carlo!',
73578 &' ',
73579 &'PPP Y Y TTTTT H H III A ',
73580 &'P P Y Y T H H I A A ',
73581 &'PPP Y T HHHHH I AAAAA',
73582 &'P Y T H H I A A',
73583 &'P Y T H H III A A',
73584 &' ',
73585 &'This is PYTHIA version x.xxx ',
73586 &'Last date of change: xx xxx 200x',
73587 &' ',
73588 &'Now is xx xxx 200x at xx:xx:xx ',
73589 &' ',
73590 &'Disclaimer: this program comes ',
73591 &'without any guarantees. Beware ',
73592 &'of errors and use common sense ',
73593 &'when interpreting results. ',
73594 &' ',
73595 &'Copyright T. Sjostrand (2008) '/
73596 DATA (REFER(J),J=1,14)/
73597 &'An archive of program versions and d',
73598 &'ocumentation is found on the web: ',
73599 &'http://www.thep.lu.se/~torbjorn/Pyth',
73600 &'ia.html ',
73601 &' ',
73602 &' ',
73603 &'When you cite this program, the offi',
73604 &'cial reference is to the 6.4 manual:',
73605 &'T. Sjostrand, S. Mrenna and P. Skand',
73606 &'s, JHEP05 (2006) 026 ',
73607 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73608 &'-T) [hep-ph/0603175]. ',
73609 &' ',
73610 &' '/
73611 DATA (REFER(J),J=15,32)/
73612 &'Also remember that the program, to a',
73613 &' large extent, represents original ',
73614 &'physics research. Other publications',
73615 &' of special relevance to your ',
73616 &'studies may therefore deserve separa',
73617 &'te mention. ',
73618 &' ',
73619 &' ',
73620 &'Main author: Torbjorn Sjostrand; Dep',
73621 &'artment of Theoretical Physics, ',
73622 &' Lund University, Solvegatan 14A, S',
73623 &'-223 62 Lund, Sweden; ',
73624 &' phone: + 46 - 46 - 222 48 16; e-ma',
73625 &'il: torbjorn@thep.lu.se ',
73626 &'Author: Stephen Mrenna; Computing Di',
73627 &'vision, GDS Group, ',
73628 &' Fermi National Accelerator Laborat',
73629 &'ory, MS 234, Batavia, IL 60510, USA;'/
73630 DATA (REFER(J),J=33,2*IREFER)/
73631 &' phone: + 1 - 630 - 840 - 2556; e-m',
73632 &'ail: mrenna@fnal.gov ',
73633 &'Author: Peter Skands; Theoretical Ph',
73634 &'ysics Department, ',
73635 &' Fermi National Accelerator Laborat',
73636 &'ory, MS 106, Batavia, IL 60510, USA;',
73637 &' and CERN/PH, CH-1211 Geneva, Switz',
73638 &'erland; ',
73639 &' phone: + 41 - 22 - 767 24 59; e-ma',
73640 &'il: skands@fnal.gov '/
73641
73642C...Check that PYDATA linked.
73643 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73644 WRITE(*,'(1X,A)')
73645 & 'Error: PYDATA has not been linked.'
73646 WRITE(*,'(1X,A)') 'Execution stopped!'
73647 CALL PYSTOP(8)
73648
73649C...Write current version number and current date+time.
73650 ELSE
73651 WRITE(VERS,'(I1)') MSTP(181)
73652 LOGO(28)(24:24)=VERS
73653 WRITE(SUBV,'(I3)') MSTP(182)
73654 LOGO(28)(26:28)=SUBV
73655 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73656 WRITE(DATE,'(I2)') MSTP(185)
73657 LOGO(29)(22:23)=DATE
73658 LOGO(29)(25:27)=MONTH(MSTP(184))
73659 WRITE(YEAR,'(I4)') MSTP(183)
73660 LOGO(29)(29:32)=YEAR
73661 CALL PYTIME(IDATI)
73662 IF(IDATI(1).LE.0) THEN
73663 LOGO(31)=' '
73664 ELSE
73665 WRITE(DATE,'(I2)') IDATI(3)
73666 LOGO(31)(8:9)=DATE
73667 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73668 WRITE(YEAR,'(I4)') IDATI(1)
73669 LOGO(31)(15:18)=YEAR
73670 WRITE(HOUR,'(I2)') IDATI(4)
73671 LOGO(31)(23:24)=HOUR
73672 WRITE(MINU,'(I2)') IDATI(5)
73673 LOGO(31)(26:27)=MINU
73674 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73675 WRITE(SECO,'(I2)') IDATI(6)
73676 LOGO(31)(29:30)=SECO
73677 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73678 ENDIF
73679 ENDIF
73680
73681C...Loop over lines in header. Define page feed and side borders.
73682 DO 100 ILIN=1,29+IREFER
73683 LINE=' '
73684 IF(ILIN.EQ.1) THEN
73685 LINE(1:1)='1'
73686 ELSE
73687 LINE(2:3)='**'
73688 LINE(78:79)='**'
73689 ENDIF
73690
73691C...Separator lines and logos.
73692 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73693 LINE(4:77)='***********************************************'//
73694 & '***************************'
73695 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73696 LINE(6:37)=LOGO(ILIN-5)
73697 LINE(44:75)=LOGO(ILIN+14)
73698 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73699 LINE(5:40)=REFER(2*ILIN-51)
73700 LINE(41:76)=REFER(2*ILIN-50)
73701 ENDIF
73702
73703C...Write lines to appropriate unit.
73704 WRITE(MSTU(11),'(A79)') LINE
73705 100 CONTINUE
73706
73707 RETURN
73708 END
73709
73710C*********************************************************************
73711
73712C...PYUPDA
73713C...Facilitates the updating of particle and decay data
73714C...by allowing it to be done in an external file.
73715
73716 SUBROUTINE PYUPDA(MUPDA,LFN)
73717
73718C...Double precision and integer declarations.
73719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73720 IMPLICIT INTEGER(I-N)
73721 INTEGER PYK,PYCHGE,PYCOMP
73722C...Commonblocks.
73723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73725 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73726 COMMON/PYDAT4/CHAF(500,2)
73727 CHARACTER CHAF*16
73728 COMMON/PYINT4/MWID(500),WIDS(500,5)
73729 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73730C...Local arrays, character variables and data.
73731 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73732 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73733 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73734 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73735 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73736 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73737 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73738
73739C...Write header if not yet done.
73740 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73741
73742C...Write information on file for editing.
73743 IF(MUPDA.EQ.1) THEN
73744 DO 110 KC=1,500
73745 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73746 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73747 & MWID(KC),MDCY(KC,1)
73748 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73749 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73750 & (KFDP(IDC,J),J=1,5)
73751 100 CONTINUE
73752 110 CONTINUE
73753
73754C...Read complete set of information from edited file or
73755C...read partial set of new or updated information from edited file.
73756 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73757
73758C...Reset counters.
73759 KCC=100
73760 NDC=0
73761 CHKF=' '
73762 IF(MUPDA.EQ.2) THEN
73763 DO 120 I=1,MSTU(6)
73764 KCHG(I,4)=0
73765 120 CONTINUE
73766 ELSE
73767 DO 130 KC=1,MSTU(6)
73768 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73769 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73770 130 CONTINUE
73771 ENDIF
73772
73773C...Begin of loop: read new line; unknown whether particle or
73774C...decay data.
73775 140 READ(LFN,5200,END=190) CHINL
73776
73777C...Identify particle code and whether already defined (for MUPDA=3).
73778 IF(CHINL(2:10).NE.' ') THEN
73779 CHKF=CHINL(2:10)
73780 READ(CHKF,5300) KF
73781 IF(MUPDA.EQ.2) THEN
73782 IF(KF.LE.100) THEN
73783 KC=KF
73784 ELSE
73785 KCC=KCC+1
73786 KC=KCC
73787 ENDIF
73788 ELSE
73789 KCREP=0
73790 IF(KF.LE.100) THEN
73791 KCREP=KF
73792 ELSE
73793 DO 150 KCR=101,KCC
73794 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73795 150 CONTINUE
73796 ENDIF
73797C...Remove duplicate old decay data.
73798 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73799 IDCREP=MDCY(KCREP,2)
73800 NDCREP=MDCY(KCREP,3)
73801 DO 160 I=1,KCC
73802 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73803 160 CONTINUE
73804 DO 180 I=IDCREP,NDC-NDCREP
73805 MDME(I,1)=MDME(I+NDCREP,1)
73806 MDME(I,2)=MDME(I+NDCREP,2)
73807 BRAT(I)=BRAT(I+NDCREP)
73808 DO 170 J=1,5
73809 KFDP(I,J)=KFDP(I+NDCREP,J)
73810 170 CONTINUE
73811 180 CONTINUE
73812 NDC=NDC-NDCREP
73813 KC=KCREP
73814 ELSEIF(KCREP.NE.0) THEN
73815 KC=KCREP
73816 ELSE
73817 KCC=KCC+1
73818 KC=KCC
73819 ENDIF
73820 ENDIF
73821
73822C...Study line with particle data.
73823 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73824 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73825 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73826 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73827 & MWID(KC),MDCY(KC,1)
73828 MDCY(KC,2)=0
73829 MDCY(KC,3)=0
73830
73831C...Study line with decay data.
73832 ELSE
73833 NDC=NDC+1
73834 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73835 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73836 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73837 MDCY(KC,3)=MDCY(KC,3)+1
73838 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73839 & (KFDP(NDC,J),J=1,5)
73840 ENDIF
73841
73842C...End of loop; ensure that PYCOMP tables are updated.
73843 GOTO 140
73844 190 CONTINUE
73845 MSTU(20)=0
73846
73847C...Perform possible tests that new information is consistent.
73848 DO 220 KC=1,MSTU(6)
73849 KF=KCHG(KC,4)
73850 IF(KF.EQ.0) GOTO 220
73851 WRITE(CHKF,5300) KF
73852 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73853 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73854 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73855 BRSUM=0D0
73856 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73857 IF(MDME(IDC,2).GT.80) GOTO 210
73858 KQ=KCHG(KC,1)
73859 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73860 MERR=0
73861 DO 200 J=1,5
73862 KP=KFDP(IDC,J)
73863 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73864 IF(KP.EQ.81) KQ=0
73865 ELSEIF(PYCOMP(KP).EQ.0) THEN
73866 MERR=3
73867 ELSE
73868 KQ=KQ-PYCHGE(KP)
73869 KPC=PYCOMP(KP)
73870 PMS=PMS-PMAS(KPC,1)
73871 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73872 & PMAS(KPC,3))
73873 ENDIF
73874 200 CONTINUE
73875 IF(KQ.NE.0) MERR=MAX(2,MERR)
73876 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73877 & MERR=MAX(1,MERR)
73878 IF(MERR.EQ.3) CALL PYERRM(17,
73879 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73880 IF(MERR.EQ.2) CALL PYERRM(17,
73881 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73882 IF(MERR.EQ.1) CALL PYERRM(7,
73883 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73884 BRSUM=BRSUM+BRAT(IDC)
73885 210 CONTINUE
73886 WRITE(CHTMP,5500) BRSUM
73887 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73888 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73889 & CHTMP(9:16)//' for KF ='//CHKF)
73890 220 CONTINUE
73891
73892C...Write DATA statements for inclusion in program.
73893 ELSEIF(MUPDA.EQ.4) THEN
73894
73895C...Find out how many codes and decay channels are actually used.
73896 KCC=0
73897 NDC=0
73898 DO 230 I=1,MSTU(6)
73899 IF(KCHG(I,4).NE.0) THEN
73900 KCC=I
73901 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73902 ENDIF
73903 230 CONTINUE
73904
73905C...Initialize writing of DATA statements for inclusion in program.
73906 DO 300 IVAR=1,22
73907 NDIM=MSTU(6)
73908 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73909 NLIN=1
73910 CHLIN=' '
73911 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73912 LLIN=35
73913 CHOLD='START'
73914
73915C...Loop through variables for conversion to characters.
73916 DO 280 IDIM=1,NDIM
73917 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73918 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73919 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73920 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73921 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73922 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73923 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73924 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73925 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73926 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73927 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73928 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73929 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73930 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73931 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73932 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73933 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73934 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73935 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73936 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73937 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73938 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73939
73940C...Replace variables beyond what is properly defined.
73941 IF(IVAR.LE.4) THEN
73942 IF(IDIM.GT.KCC) CHTMP=' 0'
73943 ELSEIF(IVAR.LE.8) THEN
73944 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73945 ELSEIF(IVAR.LE.11) THEN
73946 IF(IDIM.GT.KCC) CHTMP=' 0'
73947 ELSEIF(IVAR.LE.13) THEN
73948 IF(IDIM.GT.NDC) CHTMP=' 0'
73949 ELSEIF(IVAR.LE.14) THEN
73950 IF(IDIM.GT.NDC) CHTMP=' 0.0'
73951 ELSEIF(IVAR.LE.19) THEN
73952 IF(IDIM.GT.NDC) CHTMP=' 0'
73953 ELSEIF(IVAR.LE.21) THEN
73954 IF(IDIM.GT.KCC) CHTMP=' '
73955 ELSE
73956 IF(IDIM.GT.KCC) CHTMP=' 0'
73957 ENDIF
73958
73959C...Length of variable, trailing decimal zeros, quotation marks.
73960 LLOW=1
73961 LHIG=1
73962 DO 240 LL=1,16
73963 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
73964 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
73965 240 CONTINUE
73966 CHNEW=CHTMP(LLOW:LHIG)//' '
73967 LNEW=1+LHIG-LLOW
73968 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
73969 LNEW=LNEW+1
73970 250 LNEW=LNEW-1
73971 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
73972 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
73973 IF(LNEW.EQ.0) THEN
73974 CHNEW(1:3)='0D0'
73975 LNEW=3
73976 ELSE
73977 CHNEW(LNEW+1:LNEW+2)='D0'
73978 LNEW=LNEW+2
73979 ENDIF
73980 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
73981 DO 260 LL=LNEW,1,-1
73982 IF(CHNEW(LL:LL).EQ.'''') THEN
73983 CHTMP=CHNEW
73984 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
73985 LNEW=LNEW+1
73986 ENDIF
73987 260 CONTINUE
73988 LNEW=MIN(14,LNEW)
73989 CHTMP=CHNEW
73990 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
73991 LNEW=LNEW+2
73992 ENDIF
73993
73994C...Form composite character string, often including repetition counter.
73995 IF(CHNEW.NE.CHOLD) THEN
73996 NRPT=1
73997 CHOLD=CHNEW
73998 CHCOM=CHNEW
73999 LCOM=LNEW
74000 ELSE
74001 LRPT=LNEW+1
74002 IF(NRPT.GE.2) LRPT=LNEW+3
74003 IF(NRPT.GE.10) LRPT=LNEW+4
74004 IF(NRPT.GE.100) LRPT=LNEW+5
74005 IF(NRPT.GE.1000) LRPT=LNEW+6
74006 LLIN=LLIN-LRPT
74007 NRPT=NRPT+1
74008 WRITE(CHTMP,5400) NRPT
74009 LRPT=1
74010 IF(NRPT.GE.10) LRPT=2
74011 IF(NRPT.GE.100) LRPT=3
74012 IF(NRPT.GE.1000) LRPT=4
74013 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74014 LCOM=LRPT+1+LNEW
74015 ENDIF
74016
74017C...Add characters to end of line, to new line (after storing old line),
74018C...or to new block of lines (after writing old block).
74019 IF(LLIN+LCOM.LE.70) THEN
74020 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74021 LLIN=LLIN+LCOM+1
74022 ELSEIF(NLIN.LE.19) THEN
74023 CHLIN(LLIN+1:72)=' '
74024 CHBLK(NLIN)=CHLIN
74025 NLIN=NLIN+1
74026 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74027 LLIN=6+LCOM+1
74028 ELSE
74029 CHLIN(LLIN:72)='/'//' '
74030 CHBLK(NLIN)=CHLIN
74031 WRITE(CHTMP,5400) IDIM-NRPT
74032 CHBLK(1)(30:33)=CHTMP(13:16)
74033 DO 270 ILIN=1,NLIN
74034 WRITE(LFN,5700) CHBLK(ILIN)
74035 270 CONTINUE
74036 NLIN=1
74037 CHLIN=' '
74038 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74039 & ',I= , )/'//CHCOM(1:LCOM)//','
74040 WRITE(CHTMP,5400) IDIM-NRPT+1
74041 CHLIN(25:28)=CHTMP(13:16)
74042 LLIN=35+LCOM+1
74043 ENDIF
74044 280 CONTINUE
74045
74046C...Write final block of lines.
74047 CHLIN(LLIN:72)='/'//' '
74048 CHBLK(NLIN)=CHLIN
74049 WRITE(CHTMP,5400) NDIM
74050 CHBLK(1)(30:33)=CHTMP(13:16)
74051 DO 290 ILIN=1,NLIN
74052 WRITE(LFN,5700) CHBLK(ILIN)
74053 290 CONTINUE
74054 300 CONTINUE
74055 ENDIF
74056
74057C...Formats for reading and writing particle data.
74058 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74059 5100 FORMAT(10X,2I5,F12.6,5I10)
74060 5200 FORMAT(A120)
74061 5300 FORMAT(I9)
74062 5400 FORMAT(I16)
74063 5500 FORMAT(F16.5)
74064 5600 FORMAT(F16.6)
74065 5700 FORMAT(A72)
74066
74067 RETURN
74068 END
74069
74070C*********************************************************************
74071
74072C...PYK
74073C...Provides various integer-valued event related data.
74074
74075 FUNCTION PYK(I,J)
74076
74077C...Double precision and integer declarations.
74078 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74079 IMPLICIT INTEGER(I-N)
74080 INTEGER PYK,PYCHGE,PYCOMP
74081C...Commonblocks.
74082 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74083 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74084 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74085 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74086
74087C...Default value. For I=0 number of entries, number of stable entries
74088C...or 3 times total charge.
74089 PYK=0
74090 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74091 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74092 PYK=N
74093 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74094 DO 100 I1=1,N
74095 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74096 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74097 & PYCHGE(K(I1,2))
74098 100 CONTINUE
74099 ELSEIF(I.EQ.0) THEN
74100
74101C...For I > 0 direct readout of K matrix or charge.
74102 ELSEIF(J.LE.5) THEN
74103 PYK=K(I,J)
74104 ELSEIF(J.EQ.6) THEN
74105 PYK=PYCHGE(K(I,2))
74106
74107C...Status (existing/fragmented/decayed), parton/hadron separation.
74108 ELSEIF(J.LE.8) THEN
74109 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74110 IF(J.EQ.8) PYK=PYK*K(I,2)
74111 ELSEIF(J.LE.12) THEN
74112 KFA=IABS(K(I,2))
74113 KC=PYCOMP(KFA)
74114 KQ=0
74115 IF(KC.NE.0) KQ=KCHG(KC,2)
74116 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74117 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74118 IF(J.EQ.11) PYK=KC
74119 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74120
74121C...Heaviest flavour in hadron/diquark.
74122 ELSEIF(J.EQ.13) THEN
74123 KFA=IABS(K(I,2))
74124 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74125 IF(KFA.LT.10) PYK=KFA
74126 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74127 PYK=PYK*ISIGN(1,K(I,2))
74128
74129C...Particle history: generation, ancestor, rank.
74130 ELSEIF(J.LE.15) THEN
74131 I2=I
74132 I1=I
74133 110 PYK=PYK+1
74134 I2=I1
74135 I1=K(I1,3)
74136 IF(I1.GT.0) THEN
74137 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74138 ENDIF
74139 IF(J.EQ.15) PYK=I2
74140 ELSEIF(J.EQ.16) THEN
74141 KFA=IABS(K(I,2))
74142 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74143 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74144 I1=I
74145 120 I2=I1
74146 I1=K(I1,3)
74147 IF(I1.GT.0) THEN
74148 KFAM=IABS(K(I1,2))
74149 ILP=1
74150 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74151 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74152 & ILP=0
74153 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74154 IF(ILP.EQ.1) GOTO 120
74155 ENDIF
74156 IF(K(I1,1).EQ.12) THEN
74157 DO 130 I3=I1+1,I2
74158 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74159 & .AND.K(I3,2).NE.93) PYK=PYK+1
74160 130 CONTINUE
74161 ELSE
74162 I3=I2
74163 140 PYK=PYK+1
74164 I3=I3+1
74165 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74166 ENDIF
74167 ENDIF
74168
74169C...Particle coming from collapsing jet system or not.
74170 ELSEIF(J.EQ.17) THEN
74171 I1=I
74172 150 PYK=PYK+1
74173 I3=I1
74174 I1=K(I1,3)
74175 I0=MAX(1,I1)
74176 KC=PYCOMP(K(I0,2))
74177 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74178 IF(PYK.EQ.1) PYK=-1
74179 IF(PYK.GT.1) PYK=0
74180 RETURN
74181 ENDIF
74182 IF(KCHG(KC,2).EQ.0) GOTO 150
74183 IF(K(I1,1).NE.12) PYK=0
74184 IF(K(I1,1).NE.12) RETURN
74185 I2=I1
74186 160 I2=I2+1
74187 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74188 K3M=K(I3-1,3)
74189 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74190 K3P=K(I3+1,3)
74191 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74192
74193C...Number of decay products. Colour flow.
74194 ELSEIF(J.EQ.18) THEN
74195 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74196 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74197 ELSEIF(J.LE.22) THEN
74198 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74199 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74200 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74201 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74202 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74203 ELSE
74204 ENDIF
74205
74206 RETURN
74207 END
74208
74209C*********************************************************************
74210
74211C...PYP
74212C...Provides various real-valued event related data.
74213
74214 FUNCTION PYP(I,J)
74215
74216C...Double precision and integer declarations.
74217 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74218 IMPLICIT INTEGER(I-N)
74219 INTEGER PYK,PYCHGE,PYCOMP
74220C...Commonblocks.
74221 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74224 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74225C...Local array.
74226 DIMENSION PSUM(4)
74227
74228C...Set default value. For I = 0 sum of momenta or charges,
74229C...or invariant mass of system.
74230 PYP=0D0
74231 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74232 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74233 DO 100 I1=1,N
74234 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74235 100 CONTINUE
74236 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74237 DO 120 J1=1,4
74238 PSUM(J1)=0D0
74239 DO 110 I1=1,N
74240 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74241 & P(I1,J1)
74242 110 CONTINUE
74243 120 CONTINUE
74244 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74245 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74246 DO 130 I1=1,N
74247 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74248 130 CONTINUE
74249 ELSEIF(I.EQ.0) THEN
74250
74251C...Direct readout of P matrix.
74252 ELSEIF(J.LE.5) THEN
74253 PYP=P(I,J)
74254
74255C...Charge, total momentum, transverse momentum, transverse mass.
74256 ELSEIF(J.LE.12) THEN
74257 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74258 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74259 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74260 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74261 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74262
74263C...Theta and phi angle in radians or degrees.
74264 ELSEIF(J.LE.16) THEN
74265 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74266 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74267 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74268
74269C...True rapidity, rapidity with pion mass, pseudorapidity.
74270 ELSEIF(J.LE.19) THEN
74271 PMR=0D0
74272 IF(J.EQ.17) PMR=P(I,5)
74273 IF(J.EQ.18) PMR=PYMASS(211)
74274 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74275 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74276 & 1D20)),P(I,3))
74277
74278C...Energy and momentum fractions (only to be used in CM frame).
74279 ELSEIF(J.LE.25) THEN
74280 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74281 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74282 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74283 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74284 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74285 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74286 ENDIF
74287
74288 RETURN
74289 END
74290
74291C*********************************************************************
74292
74293C...PYSPHE
74294C...Performs sphericity tensor analysis to give sphericity,
74295C...aplanarity and the related event axes.
74296
74297 SUBROUTINE PYSPHE(SPH,APL)
74298
74299C...Double precision and integer declarations.
74300 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74301 IMPLICIT INTEGER(I-N)
74302 INTEGER PYK,PYCHGE,PYCOMP
74303C...Parameter statement to help give large particle numbers.
74304 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74305 &KEXCIT=4000000,KDIMEN=5000000)
74306C...Commonblocks.
74307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74309 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74310 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74311C...Local arrays.
74312 DIMENSION SM(3,3),SV(3,3)
74313
74314C...Calculate matrix to be diagonalized.
74315 NP=0
74316 DO 110 J1=1,3
74317 DO 100 J2=J1,3
74318 SM(J1,J2)=0D0
74319 100 CONTINUE
74320 110 CONTINUE
74321 PS=0D0
74322 DO 140 I=1,N
74323 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74324 IF(MSTU(41).GE.2) THEN
74325 KC=PYCOMP(K(I,2))
74326 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74327 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74328 & K(I,2).EQ.KSUSY1+39) GOTO 140
74329 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74330 & GOTO 140
74331 ENDIF
74332 NP=NP+1
74333 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74334 PWT=1D0
74335 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74336 & MAX(1D-10,PA)**(PARU(41)-2D0)
74337 DO 130 J1=1,3
74338 DO 120 J2=J1,3
74339 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74340 120 CONTINUE
74341 130 CONTINUE
74342 PS=PS+PWT*PA**2
74343 140 CONTINUE
74344
74345C...Very low multiplicities (0 or 1) not considered.
74346 IF(NP.LE.1) THEN
74347 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74348 SPH=-1D0
74349 APL=-1D0
74350 RETURN
74351 ENDIF
74352 DO 160 J1=1,3
74353 DO 150 J2=J1,3
74354 SM(J1,J2)=SM(J1,J2)/PS
74355 150 CONTINUE
74356 160 CONTINUE
74357
74358C...Find eigenvalues to matrix (third degree equation).
74359 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74360 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74361 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74362 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74363 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74364 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74365 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74366 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74367 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74368 IF(P(N+2,4).LT.1D-5) THEN
74369 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74370 SPH=-1D0
74371 APL=-1D0
74372 RETURN
74373 ENDIF
74374
74375C...Find first and last eigenvector by solving equation system.
74376 DO 240 I=1,3,2
74377 DO 180 J1=1,3
74378 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74379 DO 170 J2=J1+1,3
74380 SV(J1,J2)=SM(J1,J2)
74381 SV(J2,J1)=SM(J1,J2)
74382 170 CONTINUE
74383 180 CONTINUE
74384 SMAX=0D0
74385 DO 200 J1=1,3
74386 DO 190 J2=1,3
74387 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74388 JA=J1
74389 JB=J2
74390 SMAX=ABS(SV(J1,J2))
74391 190 CONTINUE
74392 200 CONTINUE
74393 SMAX=0D0
74394 DO 220 J3=JA+1,JA+2
74395 J1=J3-3*((J3-1)/3)
74396 RL=SV(J1,JB)/SV(JA,JB)
74397 DO 210 J2=1,3
74398 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74399 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74400 JC=J1
74401 SMAX=ABS(SV(J1,J2))
74402 210 CONTINUE
74403 220 CONTINUE
74404 JB1=JB+1-3*(JB/3)
74405 JB2=JB+2-3*((JB+1)/3)
74406 P(N+I,JB1)=-SV(JC,JB2)
74407 P(N+I,JB2)=SV(JC,JB1)
74408 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74409 & SV(JA,JB)
74410 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74411 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74412 DO 230 J=1,3
74413 P(N+I,J)=SGN*P(N+I,J)/PA
74414 230 CONTINUE
74415 240 CONTINUE
74416
74417C...Middle axis orthogonal to other two. Fill other codes.
74418 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74419 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74420 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74421 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74422 DO 260 I=1,3
74423 K(N+I,1)=31
74424 K(N+I,2)=95
74425 K(N+I,3)=I
74426 K(N+I,4)=0
74427 K(N+I,5)=0
74428 P(N+I,5)=0D0
74429 DO 250 J=1,5
74430 V(I,J)=0D0
74431 250 CONTINUE
74432 260 CONTINUE
74433
74434C...Calculate sphericity and aplanarity. Select storing option.
74435 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74436 APL=1.5D0*P(N+3,4)
74437 MSTU(61)=N+1
74438 MSTU(62)=NP
74439 IF(MSTU(43).LE.1) MSTU(3)=3
74440 IF(MSTU(43).GE.2) N=N+3
74441
74442 RETURN
74443 END
74444
74445C*********************************************************************
74446
74447C...PYTHRU
74448C...Performs thrust analysis to give thrust, oblateness
74449C...and the related event axes.
74450
74451 SUBROUTINE PYTHRU(THR,OBL)
74452
74453C...Double precision and integer declarations.
74454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74455 IMPLICIT INTEGER(I-N)
74456 INTEGER PYK,PYCHGE,PYCOMP
74457C...Parameter statement to help give large particle numbers.
74458 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74459 &KEXCIT=4000000,KDIMEN=5000000)
74460C...Commonblocks.
74461 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74462 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74463 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74464 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74465C...Local arrays.
74466 DIMENSION TDI(3),TPR(3)
74467
74468C...Take copy of particles that are to be considered in thrust analysis.
74469 NP=0
74470 PS=0D0
74471 DO 100 I=1,N
74472 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74473 IF(MSTU(41).GE.2) THEN
74474 KC=PYCOMP(K(I,2))
74475 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74476 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74477 & K(I,2).EQ.KSUSY1+39) GOTO 100
74478 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74479 & GOTO 100
74480 ENDIF
74481 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74482 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74483 THR=-2D0
74484 OBL=-2D0
74485 RETURN
74486 ENDIF
74487 NP=NP+1
74488 K(N+NP,1)=23
74489 P(N+NP,1)=P(I,1)
74490 P(N+NP,2)=P(I,2)
74491 P(N+NP,3)=P(I,3)
74492 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74493 P(N+NP,5)=1D0
74494 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74495 & P(N+NP,4)**(PARU(42)-1D0)
74496 PS=PS+P(N+NP,4)*P(N+NP,5)
74497 100 CONTINUE
74498
74499C...Very low multiplicities (0 or 1) not considered.
74500 IF(NP.LE.1) THEN
74501 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74502 THR=-1D0
74503 OBL=-1D0
74504 RETURN
74505 ENDIF
74506
74507C...Loop over thrust and major. T axis along z direction in latter case.
74508 DO 320 ILD=1,2
74509 IF(ILD.EQ.2) THEN
74510 K(N+NP+1,1)=31
74511 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74512 MSTU(33)=1
74513 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74514 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74515 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74516 ENDIF
74517
74518C...Find and order particles with highest p (pT for major).
74519 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74520 P(ILF,4)=0D0
74521 110 CONTINUE
74522 DO 160 I=N+1,N+NP
74523 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74524 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74525 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74526 DO 120 J=1,5
74527 P(ILF+1,J)=P(ILF,J)
74528 120 CONTINUE
74529 130 CONTINUE
74530 ILF=N+NP+3
74531 140 DO 150 J=1,5
74532 P(ILF+1,J)=P(I,J)
74533 150 CONTINUE
74534 160 CONTINUE
74535
74536C...Find and order initial axes with highest thrust (major).
74537 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74538 P(ILG,4)=0D0
74539 170 CONTINUE
74540 NC=2**(MIN(MSTU(44),NP)-1)
74541 DO 250 ILC=1,NC
74542 DO 180 J=1,3
74543 TDI(J)=0D0
74544 180 CONTINUE
74545 DO 200 ILF=1,MIN(MSTU(44),NP)
74546 SGN=P(N+NP+ILF+3,5)
74547 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74548 DO 190 J=1,4-ILD
74549 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74550 190 CONTINUE
74551 200 CONTINUE
74552 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74553 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74554 IF(TDS.LE.P(ILG,4)) GOTO 230
74555 DO 210 J=1,4
74556 P(ILG+1,J)=P(ILG,J)
74557 210 CONTINUE
74558 220 CONTINUE
74559 ILG=N+NP+MSTU(44)+4
74560 230 DO 240 J=1,3
74561 P(ILG+1,J)=TDI(J)
74562 240 CONTINUE
74563 P(ILG+1,4)=TDS
74564 250 CONTINUE
74565
74566C...Iterate direction of axis until stable maximum.
74567 P(N+NP+ILD,4)=0D0
74568 ILG=0
74569 260 ILG=ILG+1
74570 THP=0D0
74571 270 THPS=THP
74572 DO 280 J=1,3
74573 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74574 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74575 TPR(J)=0D0
74576 280 CONTINUE
74577 DO 300 I=N+1,N+NP
74578 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74579 DO 290 J=1,4-ILD
74580 TPR(J)=TPR(J)+SGN*P(I,J)
74581 290 CONTINUE
74582 300 CONTINUE
74583 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74584 IF(THP.GE.THPS+PARU(48)) GOTO 270
74585
74586C...Save good axis. Try new initial axis until a number of tries agree.
74587 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74588 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74589 IAGR=0
74590 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74591 DO 310 J=1,3
74592 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74593 310 CONTINUE
74594 P(N+NP+ILD,4)=THP
74595 P(N+NP+ILD,5)=0D0
74596 ENDIF
74597 IAGR=IAGR+1
74598 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74599 320 CONTINUE
74600
74601C...Find minor axis and value by orthogonality.
74602 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74603 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74604 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74605 P(N+NP+3,3)=0D0
74606 THP=0D0
74607 DO 330 I=N+1,N+NP
74608 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74609 330 CONTINUE
74610 P(N+NP+3,4)=THP/PS
74611 P(N+NP+3,5)=0D0
74612
74613C...Fill axis information. Rotate back to original coordinate system.
74614 DO 350 ILD=1,3
74615 K(N+ILD,1)=31
74616 K(N+ILD,2)=96
74617 K(N+ILD,3)=ILD
74618 K(N+ILD,4)=0
74619 K(N+ILD,5)=0
74620 DO 340 J=1,5
74621 P(N+ILD,J)=P(N+NP+ILD,J)
74622 V(N+ILD,J)=0D0
74623 340 CONTINUE
74624 350 CONTINUE
74625 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74626
74627C...Calculate thrust and oblateness. Select storing option.
74628 THR=P(N+1,4)
74629 OBL=P(N+2,4)-P(N+3,4)
74630 MSTU(61)=N+1
74631 MSTU(62)=NP
74632 IF(MSTU(43).LE.1) MSTU(3)=3
74633 IF(MSTU(43).GE.2) N=N+3
74634
74635 RETURN
74636 END
74637
74638C*********************************************************************
74639
74640C...PYCLUS
74641C...Subdivides the particle content of an event into jets/clusters.
74642
74643 SUBROUTINE PYCLUS(NJET)
74644
74645C...Double precision and integer declarations.
74646 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74647 IMPLICIT INTEGER(I-N)
74648 INTEGER PYK,PYCHGE,PYCOMP
74649C...Parameter statement to help give large particle numbers.
74650 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74651 &KEXCIT=4000000,KDIMEN=5000000)
74652C...Commonblocks.
74653 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74654 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74655 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74656 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74657C...Local arrays and saved variables.
74658 DIMENSION PS(5)
74659 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74660
74661C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74662 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74663 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74664 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74665 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74666 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74667 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74668
74669C...If first time, reset. If reentering, skip preliminaries.
74670 IF(MSTU(48).LE.0) THEN
74671 NP=0
74672 DO 100 J=1,5
74673 PS(J)=0D0
74674 100 CONTINUE
74675 PSS=0D0
74676 PIMASS=PMAS(PYCOMP(211),1)
74677 ELSE
74678 NJET=NSAV
74679 IF(MSTU(43).GE.2) N=N-NJET
74680 DO 110 I=N+1,N+NJET
74681 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74682 110 CONTINUE
74683 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74684 R2ACC=PARU(44)**2
74685 ELSE
74686 R2ACC=PARU(45)*PS(5)**2
74687 ENDIF
74688 NLOOP=0
74689 GOTO 300
74690 ENDIF
74691
74692C...Find which particles are to be considered in cluster search.
74693 DO 140 I=1,N
74694 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74695 IF(MSTU(41).GE.2) THEN
74696 KC=PYCOMP(K(I,2))
74697 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74698 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74699 & K(I,2).EQ.KSUSY1+39) GOTO 140
74700 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74701 & GOTO 140
74702 ENDIF
74703 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74704 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74705 NJET=-1
74706 RETURN
74707 ENDIF
74708
74709C...Take copy of these particles, with space left for jets later on.
74710 NP=NP+1
74711 K(N+NP,3)=I
74712 DO 120 J=1,5
74713 P(N+NP,J)=P(I,J)
74714 120 CONTINUE
74715 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74716 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74717 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74718 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74719 DO 130 J=1,4
74720 PS(J)=PS(J)+P(N+NP,J)
74721 130 CONTINUE
74722 PSS=PSS+P(N+NP,5)
74723 140 CONTINUE
74724 DO 160 I=N+1,N+NP
74725 K(I+NP,3)=K(I,3)
74726 DO 150 J=1,5
74727 P(I+NP,J)=P(I,J)
74728 150 CONTINUE
74729 160 CONTINUE
74730 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74731
74732C...Very low multiplicities not considered.
74733 IF(NP.LT.MSTU(47)) THEN
74734 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74735 NJET=-1
74736 RETURN
74737 ENDIF
74738
74739C...Find precluster configuration. If too few jets, make harder cuts.
74740 NLOOP=0
74741 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74742 R2ACC=PARU(44)**2
74743 ELSE
74744 R2ACC=PARU(45)*PS(5)**2
74745 ENDIF
74746 RINIT=1.25D0*PARU(43)
74747 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74748 170 RINIT=0.8D0*RINIT
74749 NPRE=0
74750 NREM=NP
74751 DO 180 I=N+NP+1,N+2*NP
74752 K(I,4)=0
74753 180 CONTINUE
74754
74755C...Sum up small momentum region. Jet if enough absolute momentum.
74756 IF(MSTU(46).LE.2) THEN
74757 DO 190 J=1,4
74758 P(N+1,J)=0D0
74759 190 CONTINUE
74760 DO 210 I=N+NP+1,N+2*NP
74761 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74762 NREM=NREM-1
74763 K(I,4)=1
74764 DO 200 J=1,4
74765 P(N+1,J)=P(N+1,J)+P(I,J)
74766 200 CONTINUE
74767 210 CONTINUE
74768 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74769 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74770 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74771 IF(NREM.EQ.0) GOTO 170
74772 ENDIF
74773
74774C...Find fastest remaining particle.
74775 220 NPRE=NPRE+1
74776 PMAX=0D0
74777 DO 230 I=N+NP+1,N+2*NP
74778 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74779 IMAX=I
74780 PMAX=P(I,5)
74781 230 CONTINUE
74782 DO 240 J=1,5
74783 P(N+NPRE,J)=P(IMAX,J)
74784 240 CONTINUE
74785 NREM=NREM-1
74786 K(IMAX,4)=NPRE
74787
74788C...Sum up precluster around it according to pT separation.
74789 IF(MSTU(46).LE.2) THEN
74790 DO 260 I=N+NP+1,N+2*NP
74791 IF(K(I,4).NE.0) GOTO 260
74792 R2=R2T(I,IMAX)
74793 IF(R2.GT.RINIT**2) GOTO 260
74794 NREM=NREM-1
74795 K(I,4)=NPRE
74796 DO 250 J=1,4
74797 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74798 250 CONTINUE
74799 260 CONTINUE
74800 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74801
74802C...Sum up precluster around it according to mass or
74803C...Durham pT separation.
74804 ELSE
74805 270 IMIN=0
74806 R2MIN=RINIT**2
74807 DO 280 I=N+NP+1,N+2*NP
74808 IF(K(I,4).NE.0) GOTO 280
74809 IF(MSTU(46).LE.4) THEN
74810 R2=R2M(I,N+NPRE)
74811 ELSE
74812 R2=R2D(I,N+NPRE)
74813 ENDIF
74814 IF(R2.GE.R2MIN) GOTO 280
74815 IMIN=I
74816 R2MIN=R2
74817 280 CONTINUE
74818 IF(IMIN.NE.0) THEN
74819 DO 290 J=1,4
74820 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74821 290 CONTINUE
74822 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74823 NREM=NREM-1
74824 K(IMIN,4)=NPRE
74825 GOTO 270
74826 ENDIF
74827 ENDIF
74828
74829C...Check if more preclusters to be found. Start over if too few.
74830 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74831 IF(NREM.GT.0) GOTO 220
74832 NJET=NPRE
74833
74834C...Reassign all particles to nearest jet. Sum up new jet momenta.
74835 300 TSAV=0D0
74836 PSJT=0D0
74837 310 IF(MSTU(46).LE.1) THEN
74838 DO 330 I=N+1,N+NJET
74839 DO 320 J=1,4
74840 V(I,J)=0D0
74841 320 CONTINUE
74842 330 CONTINUE
74843 DO 360 I=N+NP+1,N+2*NP
74844 R2MIN=PSS**2
74845 DO 340 IJET=N+1,N+NJET
74846 IF(P(IJET,5).LT.RINIT) GOTO 340
74847 R2=R2T(I,IJET)
74848 IF(R2.GE.R2MIN) GOTO 340
74849 IMIN=IJET
74850 R2MIN=R2
74851 340 CONTINUE
74852 K(I,4)=IMIN-N
74853 DO 350 J=1,4
74854 V(IMIN,J)=V(IMIN,J)+P(I,J)
74855 350 CONTINUE
74856 360 CONTINUE
74857 PSJT=0D0
74858 DO 380 I=N+1,N+NJET
74859 DO 370 J=1,4
74860 P(I,J)=V(I,J)
74861 370 CONTINUE
74862 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74863 PSJT=PSJT+P(I,5)
74864 380 CONTINUE
74865 ENDIF
74866
74867C...Find two closest jets.
74868 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74869 DO 400 ITRY1=N+1,N+NJET-1
74870 DO 390 ITRY2=ITRY1+1,N+NJET
74871 IF(MSTU(46).LE.2) THEN
74872 R2=R2T(ITRY1,ITRY2)
74873 ELSEIF(MSTU(46).LE.4) THEN
74874 R2=R2M(ITRY1,ITRY2)
74875 ELSE
74876 R2=R2D(ITRY1,ITRY2)
74877 ENDIF
74878 IF(R2.GE.R2MIN) GOTO 390
74879 IMIN1=ITRY1
74880 IMIN2=ITRY2
74881 R2MIN=R2
74882 390 CONTINUE
74883 400 CONTINUE
74884
74885C...If allowed, join two closest jets and start over.
74886 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74887 IREC=MIN(IMIN1,IMIN2)
74888 IDEL=MAX(IMIN1,IMIN2)
74889 DO 410 J=1,4
74890 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74891 410 CONTINUE
74892 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74893 DO 430 I=IDEL+1,N+NJET
74894 DO 420 J=1,5
74895 P(I-1,J)=P(I,J)
74896 420 CONTINUE
74897 430 CONTINUE
74898 IF(MSTU(46).GE.2) THEN
74899 DO 440 I=N+NP+1,N+2*NP
74900 IORI=N+K(I,4)
74901 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74902 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74903 440 CONTINUE
74904 ENDIF
74905 NJET=NJET-1
74906 GOTO 300
74907
74908C...Divide up broad jet if empty cluster in list of final ones.
74909 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74910 DO 450 I=N+1,N+NJET
74911 K(I,5)=0
74912 450 CONTINUE
74913 DO 460 I=N+NP+1,N+2*NP
74914 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74915 460 CONTINUE
74916 IEMP=0
74917 DO 470 I=N+1,N+NJET
74918 IF(K(I,5).EQ.0) IEMP=I
74919 470 CONTINUE
74920 IF(IEMP.NE.0) THEN
74921 NLOOP=NLOOP+1
74922 ISPL=0
74923 R2MAX=0D0
74924 DO 480 I=N+NP+1,N+2*NP
74925 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74926 IJET=N+K(I,4)
74927 R2=R2T(I,IJET)
74928 IF(R2.LE.R2MAX) GOTO 480
74929 ISPL=I
74930 R2MAX=R2
74931 480 CONTINUE
74932 IF(ISPL.NE.0) THEN
74933 IJET=N+K(ISPL,4)
74934 DO 490 J=1,4
74935 P(IEMP,J)=P(ISPL,J)
74936 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74937 490 CONTINUE
74938 P(IEMP,5)=P(ISPL,5)
74939 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74940 IF(NLOOP.LE.2) GOTO 300
74941 ENDIF
74942 ENDIF
74943 ENDIF
74944
74945C...If generalized thrust has not yet converged, continue iteration.
74946 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
74947 &THEN
74948 TSAV=PSJT/PSS
74949 GOTO 310
74950 ENDIF
74951
74952C...Reorder jets according to energy.
74953 DO 510 I=N+1,N+NJET
74954 DO 500 J=1,5
74955 V(I,J)=P(I,J)
74956 500 CONTINUE
74957 510 CONTINUE
74958 DO 540 INEW=N+1,N+NJET
74959 PEMAX=0D0
74960 DO 520 ITRY=N+1,N+NJET
74961 IF(V(ITRY,4).LE.PEMAX) GOTO 520
74962 IMAX=ITRY
74963 PEMAX=V(ITRY,4)
74964 520 CONTINUE
74965 K(INEW,1)=31
74966 K(INEW,2)=97
74967 K(INEW,3)=INEW-N
74968 K(INEW,4)=0
74969 DO 530 J=1,5
74970 P(INEW,J)=V(IMAX,J)
74971 530 CONTINUE
74972 V(IMAX,4)=-1D0
74973 K(IMAX,5)=INEW
74974 540 CONTINUE
74975
74976C...Clean up particle-jet assignments and jet information.
74977 DO 550 I=N+NP+1,N+2*NP
74978 IORI=K(N+K(I,4),5)
74979 K(I,4)=IORI-N
74980 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
74981 K(IORI,4)=K(IORI,4)+1
74982 550 CONTINUE
74983 IEMP=0
74984 PSJT=0D0
74985 DO 570 I=N+1,N+NJET
74986 K(I,5)=0
74987 PSJT=PSJT+P(I,5)
74988 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
74989 DO 560 J=1,5
74990 V(I,J)=0D0
74991 560 CONTINUE
74992 IF(K(I,4).EQ.0) IEMP=I
74993 570 CONTINUE
74994
74995C...Select storing option. Output variables. Check for failure.
74996 MSTU(61)=N+1
74997 MSTU(62)=NP
74998 MSTU(63)=NPRE
74999 PARU(61)=PS(5)
75000 PARU(62)=PSJT/PSS
75001 PARU(63)=SQRT(R2MIN)
75002 IF(NJET.LE.1) PARU(63)=0D0
75003 IF(IEMP.NE.0) THEN
75004 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75005 NJET=-1
75006 RETURN
75007 ENDIF
75008 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75009 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75010 NSAV=NJET
75011
75012 RETURN
75013 END
75014
75015C*********************************************************************
75016
75017C...PYCELL
75018C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75019C...as used for calorimeters at hadron colliders.
75020
75021 SUBROUTINE PYCELL(NJET)
75022
75023C...Double precision and integer declarations.
75024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75025 IMPLICIT INTEGER(I-N)
75026 INTEGER PYK,PYCHGE,PYCOMP
75027C...Parameter statement to help give large particle numbers.
75028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75029 &KEXCIT=4000000,KDIMEN=5000000)
75030C...Commonblocks.
75031 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75032 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75033 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75034 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75035
75036C...Loop over all particles. Find cell that was hit by given particle.
75037 PTLRAT=1D0/SINH(PARU(51))**2
75038 NP=0
75039 NC=N
75040 DO 110 I=1,N
75041 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75042 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75043 IF(MSTU(41).GE.2) THEN
75044 KC=PYCOMP(K(I,2))
75045 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75046 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75047 & K(I,2).EQ.KSUSY1+39) GOTO 110
75048 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75049 & GOTO 110
75050 ENDIF
75051 NP=NP+1
75052 PT=SQRT(P(I,1)**2+P(I,2)**2)
75053 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75054 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75055 & (ETA/PARU(51)+1D0))))
75056 PHI=PYANGL(P(I,1),P(I,2))
75057 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75058 & (PHI/PARU(1)+1D0))))
75059 IETPH=MSTU(52)*IETA+IPHI
75060
75061C...Add to cell already hit, or book new cell.
75062 DO 100 IC=N+1,NC
75063 IF(IETPH.EQ.K(IC,3)) THEN
75064 K(IC,4)=K(IC,4)+1
75065 P(IC,5)=P(IC,5)+PT
75066 GOTO 110
75067 ENDIF
75068 100 CONTINUE
75069 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75070 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75071 NJET=-2
75072 RETURN
75073 ENDIF
75074 NC=NC+1
75075 K(NC,3)=IETPH
75076 K(NC,4)=1
75077 K(NC,5)=2
75078 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75079 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75080 P(NC,5)=PT
75081 110 CONTINUE
75082
75083C...Smear true bin content by calorimeter resolution.
75084 IF(MSTU(53).GE.1) THEN
75085 DO 130 IC=N+1,NC
75086 PEI=P(IC,5)
75087 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75088 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75089 & COS(PARU(2)*PYR(0))
75090 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75091 P(IC,5)=PEF
75092 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75093 130 CONTINUE
75094 ENDIF
75095
75096C...Remove cells below threshold.
75097 IF(PARU(58).GT.0D0) THEN
75098 NCC=NC
75099 NC=N
75100 DO 140 IC=N+1,NCC
75101 IF(P(IC,5).GT.PARU(58)) THEN
75102 NC=NC+1
75103 K(NC,3)=K(IC,3)
75104 K(NC,4)=K(IC,4)
75105 K(NC,5)=K(IC,5)
75106 P(NC,1)=P(IC,1)
75107 P(NC,2)=P(IC,2)
75108 P(NC,5)=P(IC,5)
75109 ENDIF
75110 140 CONTINUE
75111 ENDIF
75112
75113C...Find initiator cell: the one with highest pT of not yet used ones.
75114 NJ=NC
75115 150 ETMAX=0D0
75116 DO 160 IC=N+1,NC
75117 IF(K(IC,5).NE.2) GOTO 160
75118 IF(P(IC,5).LE.ETMAX) GOTO 160
75119 ICMAX=IC
75120 ETA=P(IC,1)
75121 PHI=P(IC,2)
75122 ETMAX=P(IC,5)
75123 160 CONTINUE
75124 IF(ETMAX.LT.PARU(52)) GOTO 220
75125 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75126 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75127 NJET=-2
75128 RETURN
75129 ENDIF
75130 K(ICMAX,5)=1
75131 NJ=NJ+1
75132 K(NJ,4)=0
75133 K(NJ,5)=1
75134 P(NJ,1)=ETA
75135 P(NJ,2)=PHI
75136 P(NJ,3)=0D0
75137 P(NJ,4)=0D0
75138 P(NJ,5)=0D0
75139
75140C...Sum up unused cells within required distance of initiator.
75141 DO 170 IC=N+1,NC
75142 IF(K(IC,5).EQ.0) GOTO 170
75143 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75144 DPHIA=ABS(P(IC,2)-PHI)
75145 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75146 PHIC=P(IC,2)
75147 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75148 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75149 K(IC,5)=-K(IC,5)
75150 K(NJ,4)=K(NJ,4)+K(IC,4)
75151 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75152 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75153 P(NJ,5)=P(NJ,5)+P(IC,5)
75154 170 CONTINUE
75155
75156C...Reject cluster below minimum ET, else accept.
75157 IF(P(NJ,5).LT.PARU(53)) THEN
75158 NJ=NJ-1
75159 DO 180 IC=N+1,NC
75160 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75161 180 CONTINUE
75162 ELSEIF(MSTU(54).LE.2) THEN
75163 P(NJ,3)=P(NJ,3)/P(NJ,5)
75164 P(NJ,4)=P(NJ,4)/P(NJ,5)
75165 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75166 & P(NJ,4))
75167 DO 190 IC=N+1,NC
75168 IF(K(IC,5).LT.0) K(IC,5)=0
75169 190 CONTINUE
75170 ELSE
75171 DO 200 J=1,4
75172 P(NJ,J)=0D0
75173 200 CONTINUE
75174 DO 210 IC=N+1,NC
75175 IF(K(IC,5).GE.0) GOTO 210
75176 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75177 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75178 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75179 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75180 K(IC,5)=0
75181 210 CONTINUE
75182 ENDIF
75183 GOTO 150
75184
75185C...Arrange clusters in falling ET sequence.
75186 220 DO 250 I=1,NJ-NC
75187 ETMAX=0D0
75188 DO 230 IJ=NC+1,NJ
75189 IF(K(IJ,5).EQ.0) GOTO 230
75190 IF(P(IJ,5).LT.ETMAX) GOTO 230
75191 IJMAX=IJ
75192 ETMAX=P(IJ,5)
75193 230 CONTINUE
75194 K(IJMAX,5)=0
75195 K(N+I,1)=31
75196 K(N+I,2)=98
75197 K(N+I,3)=I
75198 K(N+I,4)=K(IJMAX,4)
75199 K(N+I,5)=0
75200 DO 240 J=1,5
75201 P(N+I,J)=P(IJMAX,J)
75202 V(N+I,J)=0D0
75203 240 CONTINUE
75204 250 CONTINUE
75205 NJET=NJ-NC
75206
75207C...Convert to massless or massive four-vectors.
75208 IF(MSTU(54).EQ.2) THEN
75209 DO 260 I=N+1,N+NJET
75210 ETA=P(I,3)
75211 P(I,1)=P(I,5)*COS(P(I,4))
75212 P(I,2)=P(I,5)*SIN(P(I,4))
75213 P(I,3)=P(I,5)*SINH(ETA)
75214 P(I,4)=P(I,5)*COSH(ETA)
75215 P(I,5)=0D0
75216 260 CONTINUE
75217 ELSEIF(MSTU(54).GE.3) THEN
75218 DO 270 I=N+1,N+NJET
75219 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75220 270 CONTINUE
75221 ENDIF
75222
75223C...Information about storage.
75224 MSTU(61)=N+1
75225 MSTU(62)=NP
75226 MSTU(63)=NC-N
75227 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75228 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75229
75230 RETURN
75231 END
75232
75233C*********************************************************************
75234
75235C...PYJMAS
75236C...Determines, approximately, the two jet masses that minimize
75237C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75238
75239 SUBROUTINE PYJMAS(PMH,PML)
75240
75241C...Double precision and integer declarations.
75242 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75243 IMPLICIT INTEGER(I-N)
75244 INTEGER PYK,PYCHGE,PYCOMP
75245C...Parameter statement to help give large particle numbers.
75246 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75247 &KEXCIT=4000000,KDIMEN=5000000)
75248C...Commonblocks.
75249 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75250 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75251 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75252 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75253C...Local arrays.
75254 DIMENSION SM(3,3),SAX(3),PS(3,5)
75255
75256C...Reset.
75257 NP=0
75258 DO 120 J1=1,3
75259 DO 100 J2=J1,3
75260 SM(J1,J2)=0D0
75261 100 CONTINUE
75262 DO 110 J2=1,4
75263 PS(J1,J2)=0D0
75264 110 CONTINUE
75265 120 CONTINUE
75266 PSS=0D0
75267 PIMASS=PMAS(PYCOMP(211),1)
75268
75269C...Take copy of particles that are to be considered in mass analysis.
75270 DO 170 I=1,N
75271 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75272 IF(MSTU(41).GE.2) THEN
75273 KC=PYCOMP(K(I,2))
75274 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75275 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75276 & K(I,2).EQ.KSUSY1+39) GOTO 170
75277 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75278 & GOTO 170
75279 ENDIF
75280 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75281 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75282 PMH=-2D0
75283 PML=-2D0
75284 RETURN
75285 ENDIF
75286 NP=NP+1
75287 DO 130 J=1,5
75288 P(N+NP,J)=P(I,J)
75289 130 CONTINUE
75290 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75291 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75292 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75293
75294C...Fill information in sphericity tensor and total momentum vector.
75295 DO 150 J1=1,3
75296 DO 140 J2=J1,3
75297 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75298 140 CONTINUE
75299 150 CONTINUE
75300 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75301 DO 160 J=1,4
75302 PS(3,J)=PS(3,J)+P(N+NP,J)
75303 160 CONTINUE
75304 170 CONTINUE
75305
75306C...Very low multiplicities (0 or 1) not considered.
75307 IF(NP.LE.1) THEN
75308 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75309 PMH=-1D0
75310 PML=-1D0
75311 RETURN
75312 ENDIF
75313 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75314 &PS(3,3)**2))
75315
75316C...Find largest eigenvalue to matrix (third degree equation).
75317 DO 190 J1=1,3
75318 DO 180 J2=J1,3
75319 SM(J1,J2)=SM(J1,J2)/PSS
75320 180 CONTINUE
75321 190 CONTINUE
75322 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75323 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75324 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75325 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75326 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75327 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75328 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75329
75330C...Find largest eigenvector by solving equation system.
75331 DO 210 J1=1,3
75332 SM(J1,J1)=SM(J1,J1)-SMA
75333 DO 200 J2=J1+1,3
75334 SM(J2,J1)=SM(J1,J2)
75335 200 CONTINUE
75336 210 CONTINUE
75337 SMAX=0D0
75338 DO 230 J1=1,3
75339 DO 220 J2=1,3
75340 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75341 JA=J1
75342 JB=J2
75343 SMAX=ABS(SM(J1,J2))
75344 220 CONTINUE
75345 230 CONTINUE
75346 SMAX=0D0
75347 DO 250 J3=JA+1,JA+2
75348 J1=J3-3*((J3-1)/3)
75349 RL=SM(J1,JB)/SM(JA,JB)
75350 DO 240 J2=1,3
75351 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75352 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75353 JC=J1
75354 SMAX=ABS(SM(J1,J2))
75355 240 CONTINUE
75356 250 CONTINUE
75357 JB1=JB+1-3*(JB/3)
75358 JB2=JB+2-3*((JB+1)/3)
75359 SAX(JB1)=-SM(JC,JB2)
75360 SAX(JB2)=SM(JC,JB1)
75361 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75362
75363C...Divide particles into two initial clusters by hemisphere.
75364 DO 270 I=N+1,N+NP
75365 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75366 IS=1
75367 IF(PSAX.LT.0D0) IS=2
75368 K(I,3)=IS
75369 DO 260 J=1,4
75370 PS(IS,J)=PS(IS,J)+P(I,J)
75371 260 CONTINUE
75372 270 CONTINUE
75373 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75374 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75375
75376C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75377 280 PMD=0D0
75378 IM=0
75379 DO 290 J=1,4
75380 PS(3,J)=PS(1,J)-PS(2,J)
75381 290 CONTINUE
75382 DO 300 I=N+1,N+NP
75383 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)
75384 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75385 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75386 IF(PMDI.LT.PMD) THEN
75387 PMD=PMDI
75388 IM=I
75389 ENDIF
75390 300 CONTINUE
75391
75392C...Loop back if significant reduction in sum of m^2.
75393 IF(PMD.LT.-PARU(48)*PMS) THEN
75394 PMS=PMS+PMD
75395 IS=K(IM,3)
75396 DO 310 J=1,4
75397 PS(IS,J)=PS(IS,J)-P(IM,J)
75398 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75399 310 CONTINUE
75400 K(IM,3)=3-IS
75401 GOTO 280
75402 ENDIF
75403
75404C...Final masses and output.
75405 MSTU(61)=N+1
75406 MSTU(62)=NP
75407 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75408 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75409 PMH=MAX(PS(1,5),PS(2,5))
75410 PML=MIN(PS(1,5),PS(2,5))
75411
75412 RETURN
75413 END
75414
75415C*********************************************************************
75416
75417C...PYFOWO
75418C...Calculates the first few Fox-Wolfram moments.
75419
75420 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75421
75422C...Double precision and integer declarations.
75423 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75424 IMPLICIT INTEGER(I-N)
75425 INTEGER PYK,PYCHGE,PYCOMP
75426C...Parameter statement to help give large particle numbers.
75427 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75428 &KEXCIT=4000000,KDIMEN=5000000)
75429C...Commonblocks.
75430 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75431 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75432 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75434
75435C...Copy momenta for particles and calculate H0.
75436 NP=0
75437 H0=0D0
75438 HD=0D0
75439 DO 110 I=1,N
75440 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75441 IF(MSTU(41).GE.2) THEN
75442 KC=PYCOMP(K(I,2))
75443 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75444 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75445 & K(I,2).EQ.KSUSY1+39) GOTO 110
75446 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75447 & GOTO 110
75448 ENDIF
75449 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75450 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75451 H10=-1D0
75452 H20=-1D0
75453 H30=-1D0
75454 H40=-1D0
75455 RETURN
75456 ENDIF
75457 NP=NP+1
75458 DO 100 J=1,3
75459 P(N+NP,J)=P(I,J)
75460 100 CONTINUE
75461 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75462 H0=H0+P(N+NP,4)
75463 HD=HD+P(N+NP,4)**2
75464 110 CONTINUE
75465 H0=H0**2
75466
75467C...Very low multiplicities (0 or 1) not considered.
75468 IF(NP.LE.1) THEN
75469 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75470 H10=-1D0
75471 H20=-1D0
75472 H30=-1D0
75473 H40=-1D0
75474 RETURN
75475 ENDIF
75476
75477C...Calculate H1 - H4.
75478 H10=0D0
75479 H20=0D0
75480 H30=0D0
75481 H40=0D0
75482 DO 130 I1=N+1,N+NP
75483 DO 120 I2=I1+1,N+NP
75484 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75485 & (P(I1,4)*P(I2,4))
75486 H10=H10+P(I1,4)*P(I2,4)*CTHE
75487 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75488 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75489 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75490 & 0.375D0)
75491 120 CONTINUE
75492 130 CONTINUE
75493
75494C...Calculate H1/H0 - H4/H0. Output.
75495 MSTU(61)=N+1
75496 MSTU(62)=NP
75497 H10=(HD+2D0*H10)/H0
75498 H20=(HD+2D0*H20)/H0
75499 H30=(HD+2D0*H30)/H0
75500 H40=(HD+2D0*H40)/H0
75501
75502 RETURN
75503 END
75504
75505C*********************************************************************
75506
75507C...PYTABU
75508C...Evaluates various properties of an event, with statistics
75509C...accumulated during the course of the run and
75510C...printed at the end.
75511
75512 SUBROUTINE PYTABU(MTABU)
75513
75514C...Double precision and integer declarations.
75515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75516 IMPLICIT INTEGER(I-N)
75517 INTEGER PYK,PYCHGE,PYCOMP
75518C...Parameter statement to help give large particle numbers.
75519 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75520 &KEXCIT=4000000,KDIMEN=5000000)
75521C...Commonblocks.
75522 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75523 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75524 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75525 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75526 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75527C...Local arrays, character variables, saved variables and data.
75528 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75529 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75530 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75531 &KFDM(8),KFDC(200,0:8),NPDC(200)
75532 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75533 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75534 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75535 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75536 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75537 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75538 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75539 &NEVDC/0/,NKFDC/0/,NREDC/0/
75540
75541C...Reset statistics on initial parton state.
75542 IF(MTABU.EQ.10) THEN
75543 NEVIS=0
75544 NKFIS=0
75545
75546C...Identify and order flavour content of initial state.
75547 ELSEIF(MTABU.EQ.11) THEN
75548 NEVIS=NEVIS+1
75549 KFM1=2*IABS(MSTU(161))
75550 IF(MSTU(161).GT.0) KFM1=KFM1-1
75551 KFM2=2*IABS(MSTU(162))
75552 IF(MSTU(162).GT.0) KFM2=KFM2-1
75553 KFMN=MIN(KFM1,KFM2)
75554 KFMX=MAX(KFM1,KFM2)
75555 DO 100 I=1,NKFIS
75556 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75557 IKFIS=-I
75558 GOTO 110
75559 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75560 & KFMX.LT.KFIS(I,2))) THEN
75561 IKFIS=I
75562 GOTO 110
75563 ENDIF
75564 100 CONTINUE
75565 IKFIS=NKFIS+1
75566 110 IF(IKFIS.LT.0) THEN
75567 IKFIS=-IKFIS
75568 ELSE
75569 IF(NKFIS.GE.100) RETURN
75570 DO 130 I=NKFIS,IKFIS,-1
75571 KFIS(I+1,1)=KFIS(I,1)
75572 KFIS(I+1,2)=KFIS(I,2)
75573 DO 120 J=0,10
75574 NPIS(I+1,J)=NPIS(I,J)
75575 120 CONTINUE
75576 130 CONTINUE
75577 NKFIS=NKFIS+1
75578 KFIS(IKFIS,1)=KFMN
75579 KFIS(IKFIS,2)=KFMX
75580 DO 140 J=0,10
75581 NPIS(IKFIS,J)=0
75582 140 CONTINUE
75583 ENDIF
75584 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75585
75586C...Count number of partons in initial state.
75587 NP=0
75588 DO 160 I=1,N
75589 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75590 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75591 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75592 & THEN
75593 ELSE
75594 IM=I
75595 150 IM=K(IM,3)
75596 IF(IM.LE.0.OR.IM.GT.N) THEN
75597 NP=NP+1
75598 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75599 NP=NP+1
75600 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75601 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75602 & .NE.0) THEN
75603 ELSE
75604 GOTO 150
75605 ENDIF
75606 ENDIF
75607 160 CONTINUE
75608 NPCO=MAX(NP,1)
75609 IF(NP.GE.6) NPCO=6
75610 IF(NP.GE.8) NPCO=7
75611 IF(NP.GE.11) NPCO=8
75612 IF(NP.GE.16) NPCO=9
75613 IF(NP.GE.26) NPCO=10
75614 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75615 MSTU(62)=NP
75616
75617C...Write statistics on initial parton state.
75618 ELSEIF(MTABU.EQ.12) THEN
75619 FAC=1D0/MAX(1,NEVIS)
75620 WRITE(MSTU(11),5000) NEVIS
75621 DO 170 I=1,NKFIS
75622 KFMN=KFIS(I,1)
75623 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75624 KFM1=(KFMN+1)/2
75625 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75626 CALL PYNAME(KFM1,CHAU)
75627 CHIS(1)=CHAU(1:12)
75628 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75629 KFMX=KFIS(I,2)
75630 IF(KFIS(I,1).EQ.0) KFMX=0
75631 KFM2=(KFMX+1)/2
75632 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75633 CALL PYNAME(KFM2,CHAU)
75634 CHIS(2)=CHAU(1:12)
75635 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75636 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75637 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75638 170 CONTINUE
75639
75640C...Copy statistics on initial parton state into /PYJETS/.
75641 ELSEIF(MTABU.EQ.13) THEN
75642 FAC=1D0/MAX(1,NEVIS)
75643 DO 190 I=1,NKFIS
75644 KFMN=KFIS(I,1)
75645 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75646 KFM1=(KFMN+1)/2
75647 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75648 KFMX=KFIS(I,2)
75649 IF(KFIS(I,1).EQ.0) KFMX=0
75650 KFM2=(KFMX+1)/2
75651 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75652 K(I,1)=32
75653 K(I,2)=99
75654 K(I,3)=KFM1
75655 K(I,4)=KFM2
75656 K(I,5)=NPIS(I,0)
75657 DO 180 J=1,5
75658 P(I,J)=FAC*NPIS(I,J)
75659 V(I,J)=FAC*NPIS(I,J+5)
75660 180 CONTINUE
75661 190 CONTINUE
75662 N=NKFIS
75663 DO 200 J=1,5
75664 K(N+1,J)=0
75665 P(N+1,J)=0D0
75666 V(N+1,J)=0D0
75667 200 CONTINUE
75668 K(N+1,1)=32
75669 K(N+1,2)=99
75670 K(N+1,5)=NEVIS
75671 MSTU(3)=1
75672
75673C...Reset statistics on number of particles/partons.
75674 ELSEIF(MTABU.EQ.20) THEN
75675 NEVFS=0
75676 NPRFS=0
75677 NFIFS=0
75678 NCHFS=0
75679 NKFFS=0
75680
75681C...Identify whether particle/parton is primary or not.
75682 ELSEIF(MTABU.EQ.21) THEN
75683 NEVFS=NEVFS+1
75684 MSTU(62)=0
75685 DO 260 I=1,N
75686 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75687 MSTU(62)=MSTU(62)+1
75688 KC=PYCOMP(K(I,2))
75689 MPRI=0
75690 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75691 MPRI=1
75692 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75693 MPRI=1
75694 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75695 MPRI=1
75696 ELSEIF(KC.EQ.0) THEN
75697 ELSEIF(K(K(I,3),1).EQ.13) THEN
75698 IM=K(K(I,3),3)
75699 IF(IM.LE.0.OR.IM.GT.N) THEN
75700 MPRI=1
75701 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75702 MPRI=1
75703 ENDIF
75704 ELSEIF(KCHG(KC,2).EQ.0) THEN
75705 KCM=PYCOMP(K(K(I,3),2))
75706 IF(KCM.NE.0) THEN
75707 IF(KCHG(KCM,2).NE.0) MPRI=1
75708 ENDIF
75709 ENDIF
75710 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75711 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75712 ENDIF
75713 IF(K(I,1).LE.10) THEN
75714 NFIFS=NFIFS+1
75715 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75716 ENDIF
75717
75718C...Fill statistics on number of particles/partons in event.
75719 KFA=IABS(K(I,2))
75720 KFS=3-ISIGN(1,K(I,2))-MPRI
75721 DO 210 IP=1,NKFFS
75722 IF(KFA.EQ.KFFS(IP)) THEN
75723 IKFFS=-IP
75724 GOTO 220
75725 ELSEIF(KFA.LT.KFFS(IP)) THEN
75726 IKFFS=IP
75727 GOTO 220
75728 ENDIF
75729 210 CONTINUE
75730 IKFFS=NKFFS+1
75731 220 IF(IKFFS.LT.0) THEN
75732 IKFFS=-IKFFS
75733 ELSE
75734 IF(NKFFS.GE.400) RETURN
75735 DO 240 IP=NKFFS,IKFFS,-1
75736 KFFS(IP+1)=KFFS(IP)
75737 DO 230 J=1,4
75738 NPFS(IP+1,J)=NPFS(IP,J)
75739 230 CONTINUE
75740 240 CONTINUE
75741 NKFFS=NKFFS+1
75742 KFFS(IKFFS)=KFA
75743 DO 250 J=1,4
75744 NPFS(IKFFS,J)=0
75745 250 CONTINUE
75746 ENDIF
75747 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75748 260 CONTINUE
75749
75750C...Write statistics on particle/parton composition of events.
75751 ELSEIF(MTABU.EQ.22) THEN
75752 FAC=1D0/MAX(1,NEVFS)
75753 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75754 DO 270 I=1,NKFFS
75755 CALL PYNAME(KFFS(I),CHAU)
75756 KC=PYCOMP(KFFS(I))
75757 MDCYF=0
75758 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75759 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75760 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75761 270 CONTINUE
75762
75763C...Copy particle/parton composition information into /PYJETS/.
75764 ELSEIF(MTABU.EQ.23) THEN
75765 FAC=1D0/MAX(1,NEVFS)
75766 DO 290 I=1,NKFFS
75767 K(I,1)=32
75768 K(I,2)=99
75769 K(I,3)=KFFS(I)
75770 K(I,4)=0
75771 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75772 DO 280 J=1,4
75773 P(I,J)=FAC*NPFS(I,J)
75774 V(I,J)=0D0
75775 280 CONTINUE
75776 P(I,5)=FAC*K(I,5)
75777 V(I,5)=0D0
75778 290 CONTINUE
75779 N=NKFFS
75780 DO 300 J=1,5
75781 K(N+1,J)=0
75782 P(N+1,J)=0D0
75783 V(N+1,J)=0D0
75784 300 CONTINUE
75785 K(N+1,1)=32
75786 K(N+1,2)=99
75787 K(N+1,5)=NEVFS
75788 P(N+1,1)=FAC*NPRFS
75789 P(N+1,2)=FAC*NFIFS
75790 P(N+1,3)=FAC*NCHFS
75791 MSTU(3)=1
75792
75793C...Reset factorial moments statistics.
75794 ELSEIF(MTABU.EQ.30) THEN
75795 NEVFM=0
75796 NMUFM=0
75797 DO 330 IM=1,3
75798 DO 320 IB=1,10
75799 DO 310 IP=1,4
75800 FM1FM(IM,IB,IP)=0D0
75801 FM2FM(IM,IB,IP)=0D0
75802 310 CONTINUE
75803 320 CONTINUE
75804 330 CONTINUE
75805
75806C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75807 ELSEIF(MTABU.EQ.31) THEN
75808 NEVFM=NEVFM+1
75809 NLOW=N+MSTU(3)
75810 NUPP=NLOW
75811 DO 410 I=1,N
75812 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75813 IF(MSTU(41).GE.2) THEN
75814 KC=PYCOMP(K(I,2))
75815 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75816 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75817 & K(I,2).EQ.KSUSY1+39) GOTO 410
75818 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75819 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75820 ENDIF
75821 PMR=0D0
75822 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75823 IF(MSTU(42).GE.2) PMR=P(I,5)
75824 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75825 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75826 & 1D20)),P(I,3))
75827 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75828 PHI=PYANGL(P(I,1),P(I,2))
75829 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75830 IYETA=MAX(0,MIN(511,IYETA))
75831 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75832 IPHI=MAX(0,MIN(511,IPHI))
75833 IYEP=0
75834 DO 340 IB=0,9
75835 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75836 340 CONTINUE
75837
75838C...Order particles in (pseudo)rapidity and/or azimuth.
75839 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75840 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75841 RETURN
75842 ENDIF
75843 NUPP=NUPP+1
75844 IF(NUPP.EQ.NLOW+1) THEN
75845 K(NUPP,1)=IYETA
75846 K(NUPP,2)=IPHI
75847 K(NUPP,3)=IYEP
75848 ELSE
75849 DO 350 I1=NUPP-1,NLOW+1,-1
75850 IF(IYETA.GE.K(I1,1)) GOTO 360
75851 K(I1+1,1)=K(I1,1)
75852 350 CONTINUE
75853 360 K(I1+1,1)=IYETA
75854 DO 370 I1=NUPP-1,NLOW+1,-1
75855 IF(IPHI.GE.K(I1,2)) GOTO 380
75856 K(I1+1,2)=K(I1,2)
75857 370 CONTINUE
75858 380 K(I1+1,2)=IPHI
75859 DO 390 I1=NUPP-1,NLOW+1,-1
75860 IF(IYEP.GE.K(I1,3)) GOTO 400
75861 K(I1+1,3)=K(I1,3)
75862 390 CONTINUE
75863 400 K(I1+1,3)=IYEP
75864 ENDIF
75865 410 CONTINUE
75866 K(NUPP+1,1)=2**10
75867 K(NUPP+1,2)=2**10
75868 K(NUPP+1,3)=4**10
75869
75870C...Calculate sum of factorial moments in event.
75871 DO 480 IM=1,3
75872 DO 430 IB=1,10
75873 DO 420 IP=1,4
75874 FEVFM(IB,IP)=0D0
75875 420 CONTINUE
75876 430 CONTINUE
75877 DO 450 IB=1,10
75878 IF(IM.LE.2) IBIN=2**(10-IB)
75879 IF(IM.EQ.3) IBIN=4**(10-IB)
75880 IAGR=K(NLOW+1,IM)/IBIN
75881 NAGR=1
75882 DO 440 I=NLOW+2,NUPP+1
75883 ICUT=K(I,IM)/IBIN
75884 IF(ICUT.EQ.IAGR) THEN
75885 NAGR=NAGR+1
75886 ELSE
75887 IF(NAGR.EQ.1) THEN
75888 ELSEIF(NAGR.EQ.2) THEN
75889 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75890 ELSEIF(NAGR.EQ.3) THEN
75891 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75892 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75893 ELSEIF(NAGR.EQ.4) THEN
75894 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75895 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75896 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75897 ELSE
75898 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75899 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75900 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75901 & (NAGR-3D0)
75902 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75903 & (NAGR-3D0)*(NAGR-4D0)
75904 ENDIF
75905 IAGR=ICUT
75906 NAGR=1
75907 ENDIF
75908 440 CONTINUE
75909 450 CONTINUE
75910
75911C...Add results to total statistics.
75912 DO 470 IB=10,1,-1
75913 DO 460 IP=1,4
75914 IF(FEVFM(1,IP).LT.0.5D0) THEN
75915 FEVFM(IB,IP)=0D0
75916 ELSEIF(IM.LE.2) THEN
75917 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75918 ELSE
75919 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75920 ENDIF
75921 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75922 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75923 460 CONTINUE
75924 470 CONTINUE
75925 480 CONTINUE
75926 NMUFM=NMUFM+(NUPP-NLOW)
75927 MSTU(62)=NUPP-NLOW
75928
75929C...Write accumulated statistics on factorial moments.
75930 ELSEIF(MTABU.EQ.32) THEN
75931 FAC=1D0/MAX(1,NEVFM)
75932 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75933 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75934 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75935 DO 510 IM=1,3
75936 WRITE(MSTU(11),5500)
75937 DO 500 IB=1,10
75938 BYETA=2D0*PARU(57)
75939 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75940 BPHI=PARU(2)
75941 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75942 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75943 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75944 DO 490 IP=1,4
75945 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75946 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75947 & FMOMA(IP)**2)))
75948 490 CONTINUE
75949 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
75950 & IP=1,4)
75951 500 CONTINUE
75952 510 CONTINUE
75953
75954C...Copy statistics on factorial moments into /PYJETS/.
75955 ELSEIF(MTABU.EQ.33) THEN
75956 FAC=1D0/MAX(1,NEVFM)
75957 DO 540 IM=1,3
75958 DO 530 IB=1,10
75959 I=10*(IM-1)+IB
75960 K(I,1)=32
75961 K(I,2)=99
75962 K(I,3)=1
75963 IF(IM.NE.2) K(I,3)=2**(IB-1)
75964 K(I,4)=1
75965 IF(IM.NE.1) K(I,4)=2**(IB-1)
75966 K(I,5)=0
75967 P(I,1)=2D0*PARU(57)/K(I,3)
75968 V(I,1)=PARU(2)/K(I,4)
75969 DO 520 IP=1,4
75970 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
75971 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
75972 & P(I,IP+1)**2)))
75973 520 CONTINUE
75974 530 CONTINUE
75975 540 CONTINUE
75976 N=30
75977 DO 550 J=1,5
75978 K(N+1,J)=0
75979 P(N+1,J)=0D0
75980 V(N+1,J)=0D0
75981 550 CONTINUE
75982 K(N+1,1)=32
75983 K(N+1,2)=99
75984 K(N+1,5)=NEVFM
75985 MSTU(3)=1
75986
75987C...Reset statistics on Energy-Energy Correlation.
75988 ELSEIF(MTABU.EQ.40) THEN
75989 NEVEE=0
75990 DO 560 J=1,25
75991 FE1EC(J)=0D0
75992 FE2EC(J)=0D0
75993 FE1EC(51-J)=0D0
75994 FE2EC(51-J)=0D0
75995 FE1EA(J)=0D0
75996 FE2EA(J)=0D0
75997 560 CONTINUE
75998
75999C...Find particles to include, with proper assumed mass.
76000 ELSEIF(MTABU.EQ.41) THEN
76001 NEVEE=NEVEE+1
76002 NLOW=N+MSTU(3)
76003 NUPP=NLOW
76004 ECM=0D0
76005 DO 570 I=1,N
76006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76007 IF(MSTU(41).GE.2) THEN
76008 KC=PYCOMP(K(I,2))
76009 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76010 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76011 & K(I,2).EQ.KSUSY1+39) GOTO 570
76012 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76013 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76014 ENDIF
76015 PMR=0D0
76016 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76017 IF(MSTU(42).GE.2) PMR=P(I,5)
76018 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76019 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76020 RETURN
76021 ENDIF
76022 NUPP=NUPP+1
76023 P(NUPP,1)=P(I,1)
76024 P(NUPP,2)=P(I,2)
76025 P(NUPP,3)=P(I,3)
76026 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76027 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76028 ECM=ECM+P(NUPP,4)
76029 570 CONTINUE
76030 IF(NUPP.EQ.NLOW) RETURN
76031
76032C...Analyze Energy-Energy Correlation in event.
76033 FAC=(2D0/ECM**2)*50D0/PARU(1)
76034 DO 580 J=1,50
76035 FEVEE(J)=0D0
76036 580 CONTINUE
76037 DO 600 I1=NLOW+2,NUPP
76038 DO 590 I2=NLOW+1,I1-1
76039 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76040 & (P(I1,5)*P(I2,5))
76041 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76042 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76043 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76044 590 CONTINUE
76045 600 CONTINUE
76046 DO 610 J=1,25
76047 FE1EC(J)=FE1EC(J)+FEVEE(J)
76048 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76049 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76050 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76051 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76052 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76053 610 CONTINUE
76054 MSTU(62)=NUPP-NLOW
76055
76056C...Write statistics on Energy-Energy Correlation.
76057 ELSEIF(MTABU.EQ.42) THEN
76058 FAC=1D0/MAX(1,NEVEE)
76059 WRITE(MSTU(11),5700) NEVEE
76060 DO 620 J=1,25
76061 FEEC1=FAC*FE1EC(J)
76062 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76063 FEEC2=FAC*FE1EC(51-J)
76064 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76065 FEECA=FAC*FE1EA(J)
76066 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76067 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76068 & FEEC2,FEES2,FEECA,FEESA
76069 620 CONTINUE
76070
76071C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76072 ELSEIF(MTABU.EQ.43) THEN
76073 FAC=1D0/MAX(1,NEVEE)
76074 DO 630 I=1,25
76075 K(I,1)=32
76076 K(I,2)=99
76077 K(I,3)=0
76078 K(I,4)=0
76079 K(I,5)=0
76080 P(I,1)=FAC*FE1EC(I)
76081 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76082 P(I,2)=FAC*FE1EC(51-I)
76083 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76084 P(I,3)=FAC*FE1EA(I)
76085 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76086 P(I,4)=PARU(1)*(I-1)/50D0
76087 P(I,5)=PARU(1)*I/50D0
76088 V(I,4)=3.6D0*(I-1)
76089 V(I,5)=3.6D0*I
76090 630 CONTINUE
76091 N=25
76092 DO 640 J=1,5
76093 K(N+1,J)=0
76094 P(N+1,J)=0D0
76095 V(N+1,J)=0D0
76096 640 CONTINUE
76097 K(N+1,1)=32
76098 K(N+1,2)=99
76099 K(N+1,5)=NEVEE
76100 MSTU(3)=1
76101
76102C...Reset statistics on decay channels.
76103 ELSEIF(MTABU.EQ.50) THEN
76104 NEVDC=0
76105 NKFDC=0
76106 NREDC=0
76107
76108C...Identify and order flavour content of final state.
76109 ELSEIF(MTABU.EQ.51) THEN
76110 NEVDC=NEVDC+1
76111 NDS=0
76112 DO 670 I=1,N
76113 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76114 NDS=NDS+1
76115 IF(NDS.GT.8) THEN
76116 NREDC=NREDC+1
76117 RETURN
76118 ENDIF
76119 KFM=2*IABS(K(I,2))
76120 IF(K(I,2).LT.0) KFM=KFM-1
76121 DO 650 IDS=NDS-1,1,-1
76122 IIN=IDS+1
76123 IF(KFM.LT.KFDM(IDS)) GOTO 660
76124 KFDM(IDS+1)=KFDM(IDS)
76125 650 CONTINUE
76126 IIN=1
76127 660 KFDM(IIN)=KFM
76128 670 CONTINUE
76129
76130C...Find whether old or new final state.
76131 DO 690 IDC=1,NKFDC
76132 IF(NDS.LT.KFDC(IDC,0)) THEN
76133 IKFDC=IDC
76134 GOTO 700
76135 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76136 DO 680 I=1,NDS
76137 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76138 IKFDC=IDC
76139 GOTO 700
76140 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76141 GOTO 690
76142 ENDIF
76143 680 CONTINUE
76144 IKFDC=-IDC
76145 GOTO 700
76146 ENDIF
76147 690 CONTINUE
76148 IKFDC=NKFDC+1
76149 700 IF(IKFDC.LT.0) THEN
76150 IKFDC=-IKFDC
76151 ELSEIF(NKFDC.GE.200) THEN
76152 NREDC=NREDC+1
76153 RETURN
76154 ELSE
76155 DO 720 IDC=NKFDC,IKFDC,-1
76156 NPDC(IDC+1)=NPDC(IDC)
76157 DO 710 I=0,8
76158 KFDC(IDC+1,I)=KFDC(IDC,I)
76159 710 CONTINUE
76160 720 CONTINUE
76161 NKFDC=NKFDC+1
76162 KFDC(IKFDC,0)=NDS
76163 DO 730 I=1,NDS
76164 KFDC(IKFDC,I)=KFDM(I)
76165 730 CONTINUE
76166 NPDC(IKFDC)=0
76167 ENDIF
76168 NPDC(IKFDC)=NPDC(IKFDC)+1
76169
76170C...Write statistics on decay channels.
76171 ELSEIF(MTABU.EQ.52) THEN
76172 FAC=1D0/MAX(1,NEVDC)
76173 WRITE(MSTU(11),5900) NEVDC
76174 DO 750 IDC=1,NKFDC
76175 DO 740 I=1,KFDC(IDC,0)
76176 KFM=KFDC(IDC,I)
76177 KF=(KFM+1)/2
76178 IF(2*KF.NE.KFM) KF=-KF
76179 CALL PYNAME(KF,CHAU)
76180 CHDC(I)=CHAU(1:12)
76181 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76182 740 CONTINUE
76183 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76184 750 CONTINUE
76185 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76186
76187C...Copy statistics on decay channels into /PYJETS/.
76188 ELSEIF(MTABU.EQ.53) THEN
76189 FAC=1D0/MAX(1,NEVDC)
76190 DO 780 IDC=1,NKFDC
76191 K(IDC,1)=32
76192 K(IDC,2)=99
76193 K(IDC,3)=0
76194 K(IDC,4)=0
76195 K(IDC,5)=KFDC(IDC,0)
76196 DO 760 J=1,5
76197 P(IDC,J)=0D0
76198 V(IDC,J)=0D0
76199 760 CONTINUE
76200 DO 770 I=1,KFDC(IDC,0)
76201 KFM=KFDC(IDC,I)
76202 KF=(KFM+1)/2
76203 IF(2*KF.NE.KFM) KF=-KF
76204 IF(I.LE.5) P(IDC,I)=KF
76205 IF(I.GE.6) V(IDC,I-5)=KF
76206 770 CONTINUE
76207 V(IDC,5)=FAC*NPDC(IDC)
76208 780 CONTINUE
76209 N=NKFDC
76210 DO 790 J=1,5
76211 K(N+1,J)=0
76212 P(N+1,J)=0D0
76213 V(N+1,J)=0D0
76214 790 CONTINUE
76215 K(N+1,1)=32
76216 K(N+1,2)=99
76217 K(N+1,5)=NEVDC
76218 V(N+1,5)=FAC*NREDC
76219 MSTU(3)=1
76220 ENDIF
76221
76222C...Format statements for output on unit MSTU(11) (default 6).
76223 5000 FORMAT(///20X,'Event statistics - initial state'/
76224 &20X,'based on an analysis of ',I6,' events'//
76225 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76226 &'according to fragmenting system multiplicity'/
76227 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76228 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76229 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76230 5200 FORMAT(///20X,'Event statistics - final state'/
76231 &20X,'based on an analysis of ',I7,' events'//
76232 &5X,'Mean primary multiplicity =',F10.4/
76233 &5X,'Mean final multiplicity =',F10.4/
76234 &5X,'Mean charged multiplicity =',F10.4//
76235 &5X,'Number of particles produced per event (directly and via ',
76236 &'decays/branchings)'/
76237 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76238 &8X,'Total'/35X,'prim seco prim seco'/)
76239 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76240 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76241 &20X,'based on an analysis of ',I6,' events'//
76242 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76243 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76244 5500 FORMAT(10X)
76245 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76246 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76247 &20X,'based on an analysis of ',I6,' events'//
76248 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76249 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76250 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76251 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76252 &20X,'based on an analysis of ',I6,' events'//
76253 &2X,'Probability',10X,'Complete final state'/)
76254 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76255 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76256 &'or table overflow)')
76257
76258 RETURN
76259 END
76260
76261C*********************************************************************
76262
76263C...PYEEVT
76264C...Handles the generation of an e+e- annihilation jet event.
76265
76266 SUBROUTINE PYEEVT(KFL,ECM)
76267
76268C...Double precision and integer declarations.
76269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76270 IMPLICIT INTEGER(I-N)
76271 INTEGER PYK,PYCHGE,PYCOMP
76272C...Commonblocks.
76273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76277
76278C...Check input parameters.
76279 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76280 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76281 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76282 IF(MSTU(21).GE.1) RETURN
76283 ENDIF
76284 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76285 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76286 IF(ECM.LT.ECMMIN) THEN
76287 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76288 IF(MSTU(21).GE.1) RETURN
76289 ENDIF
76290
76291C...Check consistency of MSTJ options set.
76292 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76293 CALL PYERRM(6,
76294 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76295 MSTJ(110)=1
76296 ENDIF
76297 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76298 CALL PYERRM(6,
76299 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76300 MSTJ(111)=0
76301 ENDIF
76302
76303C...Initialize alpha_strong and total cross-section.
76304 MSTU(111)=MSTJ(108)
76305 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76306 &MSTU(111)=1
76307 PARU(112)=PARJ(121)
76308 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76309 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76310 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76311 &XTOT)
76312 IF(MSTJ(116).GE.3) MSTJ(116)=1
76313 PARJ(171)=0D0
76314
76315C...Add initial e+e- to event record (documentation only).
76316 NTRY=0
76317 100 NTRY=NTRY+1
76318 IF(NTRY.GT.100) THEN
76319 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76320 RETURN
76321 ENDIF
76322 MSTU(24)=0
76323 NC=0
76324 IF(MSTJ(115).GE.2) THEN
76325 NC=NC+2
76326 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76327 K(NC-1,1)=21
76328 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76329 K(NC,1)=21
76330 ENDIF
76331
76332C...Radiative photon (in initial state).
76333 MK=0
76334 ECMC=ECM
76335 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76336 &THEK,PHIK,ALPK)
76337 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76338 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76339 NC=NC+1
76340 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76341 K(NC,3)=MIN(MSTJ(115)/2,1)
76342 ENDIF
76343
76344C...Virtual exchange boson (gamma or Z0).
76345 IF(MSTJ(115).GE.3) THEN
76346 NC=NC+1
76347 KF=22
76348 IF(MSTJ(102).EQ.2) KF=23
76349 MSTU10=MSTU(10)
76350 MSTU(10)=1
76351 P(NC,5)=ECMC
76352 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76353 K(NC,1)=21
76354 K(NC,3)=1
76355 MSTU(10)=MSTU10
76356 ENDIF
76357
76358C...Choice of flavour and jet configuration.
76359 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76360 IF(KFLC.EQ.0) GOTO 100
76361 CALL PYXJET(ECMC,NJET,CUT)
76362 KFLN=21
76363 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76364 &X12,X14)
76365 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76366 IF(NJET.EQ.2) MSTJ(120)=1
76367
76368C...Fill jet configuration and origin.
76369 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76370 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76371 &ECMC)
76372 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76373 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76374 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76375 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76376 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76377 IF(MSTU(24).NE.0) GOTO 100
76378 DO 110 IP=NC+1,N
76379 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76380 110 CONTINUE
76381
76382C...Angular orientation according to matrix element.
76383 IF(MSTJ(106).EQ.1) THEN
76384 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76385 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76386 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76387 ENDIF
76388
76389C...Rotation and boost from radiative photon.
76390 IF(MK.EQ.1) THEN
76391 DBEK=-PAK/(ECM-PAK)
76392 NMIN=NC+1-MSTJ(115)/3
76393 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76394 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76395 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76396 ENDIF
76397
76398C...Generate parton shower. Rearrange along strings and check.
76399 IF(MSTJ(101).EQ.5) THEN
76400 CALL PYSHOW(N-1,N,ECMC)
76401 MSTJ14=MSTJ(14)
76402 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76403 IF(MSTJ(105).GE.0) MSTU(28)=0
76404 CALL PYPREP(0)
76405 MSTJ(14)=MSTJ14
76406 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76407 ENDIF
76408
76409C...Fragmentation/decay generation. Information for PYTABU.
76410 IF(MSTJ(105).EQ.1) CALL PYEXEC
76411 MSTU(161)=KFLC
76412 MSTU(162)=-KFLC
76413
76414 RETURN
76415 END
76416
76417C*********************************************************************
76418
76419C...PYXTEE
76420C...Calculates total cross-section, including initial state
76421C...radiation effects.
76422
76423 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76424
76425C...Double precision and integer declarations.
76426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76427 IMPLICIT INTEGER(I-N)
76428 INTEGER PYK,PYCHGE,PYCOMP
76429C...Commonblocks.
76430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76432 SAVE /PYDAT1/,/PYDAT2/
76433
76434C...Status, (optimized) Q^2 scale, alpha_strong.
76435 PARJ(151)=ECM
76436 MSTJ(119)=10*MSTJ(102)+KFL
76437 IF(MSTJ(111).EQ.0) THEN
76438 Q2R=ECM**2
76439 ELSEIF(MSTU(111).EQ.0) THEN
76440 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76441 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76442 Q2R=PARJ(168)*ECM**2
76443 ELSE
76444 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76445 & (2D0*PARU(112)/ECM)**2))
76446 Q2R=PARJ(168)*ECM**2
76447 ENDIF
76448 ALSPI=PYALPS(Q2R)/PARU(1)
76449
76450C...QCD corrections factor in R.
76451 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76452 RQCD=1D0
76453 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76454 RQCD=1D0+ALSPI
76455 ELSEIF(MSTJ(109).EQ.0) THEN
76456 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76457 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76458 & LOG(PARJ(168))*ALSPI**2)
76459 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76460 RQCD=1D0+(3D0/4D0)*ALSPI
76461 ELSE
76462 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76463 ENDIF
76464
76465C...Calculate Z0 width if default value not acceptable.
76466 IF(MSTJ(102).GE.3) THEN
76467 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76468 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76469 DO 100 KFLC=5,6
76470 VQ=1D0
76471 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76472 & (2D0*PYMASS(KFLC)/ ECM)**2))
76473 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76474 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76475 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76476 100 CONTINUE
76477 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76478 & (1D0-PARU(102)))
76479 ENDIF
76480
76481C...Calculate propagator and related constants for QFD case.
76482 POLL=1D0-PARJ(131)*PARJ(132)
76483 IF(MSTJ(102).GE.2) THEN
76484 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76485 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76486 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76487 VE=4D0*PARU(102)-1D0
76488 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76489 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76490 HF1I=SFI*SF1I
76491 HF1W=SFW*SF1W
76492 ENDIF
76493
76494C...Loop over different flavours: charge, velocity.
76495 RTOT=0D0
76496 RQQ=0D0
76497 RQV=0D0
76498 RVA=0D0
76499 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76500 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76501 MSTJ(93)=1
76502 PMQ=PYMASS(KFLC)
76503 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76504 QF=KCHG(KFLC,1)/3D0
76505 VQ=1D0
76506 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76507
76508C...Calculate R and sum of charges for QED or QFD case.
76509 RQQ=RQQ+3D0*QF**2*POLL
76510 IF(MSTJ(102).LE.1) THEN
76511 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76512 ELSE
76513 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76514 RQV=RQV-6D0*QF*VF*SF1I
76515 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76516 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76517 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76518 ENDIF
76519 110 CONTINUE
76520 RSUM=RQQ
76521 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76522
76523C...Calculate cross-section, including QCD corrections.
76524 PARJ(141)=RQQ
76525 PARJ(142)=RTOT
76526 PARJ(143)=RTOT*RQCD
76527 PARJ(144)=PARJ(143)
76528 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76529 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76530 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76531 PARJ(148)=PARJ(147)
76532 PARJ(157)=RSUM*RQCD
76533 PARJ(158)=0D0
76534 PARJ(159)=0D0
76535 XTOT=PARJ(147)
76536 IF(MSTJ(107).LE.0) RETURN
76537
76538C...Virtual cross-section.
76539 XKL=PARJ(135)
76540 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76541 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76542 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76543 &1.526D0*LOG(ECM**2/0.932D0)
76544
76545C...Soft and hard radiative cross-section in QED case.
76546 IF(MSTJ(102).LE.1) THEN
76547 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76548 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76549 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76550
76551C...Soft and hard radiative cross-section in QFD case.
76552 ELSE
76553 SZM=1D0-(PARJ(123)/ECM)**2
76554 SZW=PARJ(123)*PARJ(124)/ECM**2
76555 PARJ(161)=-RQQ/RSUM
76556 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76557 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76558 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76559 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76560 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76561 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76562 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76563 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76564 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76565 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76566 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76567 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76568 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76569 ENDIF
76570
76571C...Total cross-section and fraction of hard photon events.
76572 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76573 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76574 PARJ(144)=PARJ(157)
76575 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76576 XTOT=PARJ(148)
76577
76578 RETURN
76579 END
76580
76581C*********************************************************************
76582
76583C...PYRADK
76584C...Generates initial state photon radiation.
76585
76586 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76587
76588C...Double precision and integer declarations.
76589 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76590 IMPLICIT INTEGER(I-N)
76591 INTEGER PYK,PYCHGE,PYCOMP
76592C...Commonblocks.
76593 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76594 SAVE /PYDAT1/
76595
76596C...Function: cumulative hard photon spectrum in QFD case.
76597 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76598 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76599
76600C...Determine whether radiative photon or not.
76601 MK=0
76602 PAK=0D0
76603 IF(PARJ(160).LT.PYR(0)) RETURN
76604 MK=1
76605
76606C...Photon energy range. Find photon momentum in QED case.
76607 XKL=PARJ(135)
76608 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76609 IF(MSTJ(102).LE.1) THEN
76610 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76611 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76612
76613C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76614 ELSE
76615 SZM=1D0-(PARJ(123)/ECM)**2
76616 SZW=PARJ(123)*PARJ(124)/ECM**2
76617 FXKL=FXK(XKL)
76618 FXKU=FXK(XKU)
76619 FXKD=1D-4*(FXKU-FXKL)
76620 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76621 NXK=0
76622 110 NXK=NXK+1
76623 XK=0.5D0*(XKL+XKU)
76624 FXKV=FXK(XK)
76625 IF(FXKV.GT.FXKR) THEN
76626 XKU=XK
76627 FXKU=FXKV
76628 ELSE
76629 XKL=XK
76630 FXKL=FXKV
76631 ENDIF
76632 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76633 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76634 ENDIF
76635 PAK=0.5D0*ECM*XK
76636
76637C...Photon polar and azimuthal angle.
76638 PME=2D0*(PYMASS(11)/ECM)**2
76639 120 CTHM=PME*(2D0/PME)**PYR(0)
76640 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76641 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76642 CTHE=1D0-CTHM
76643 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76644 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76645 THEK=PYANGL(CTHE,STHE)
76646 PHIK=PARU(2)*PYR(0)
76647
76648C...Rotation angle for hadronic system.
76649 SGN=1D0
76650 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76651 &PYR(0)) SGN=-1D0
76652 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76653 &(2D0-XK*(1D0-SGN*CTHE)))
76654
76655 RETURN
76656 END
76657
76658C*********************************************************************
76659
76660C...PYXKFL
76661C...Selects flavour for produced qqbar pair.
76662
76663 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76664
76665C...Double precision and integer declarations.
76666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76667 IMPLICIT INTEGER(I-N)
76668 INTEGER PYK,PYCHGE,PYCOMP
76669C...Commonblocks.
76670 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76671 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76672 SAVE /PYDAT1/,/PYDAT2/
76673
76674C...Calculate maximum weight in QED or QFD case.
76675 IF(MSTJ(102).LE.1) THEN
76676 RFMAX=4D0/9D0
76677 ELSE
76678 POLL=1D0-PARJ(131)*PARJ(132)
76679 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76680 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76681 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76682 VE=4D0*PARU(102)-1D0
76683 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76684 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76685 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76686 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76687 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76688 & 1D0)*HF1W)
76689 ENDIF
76690
76691C...Choose flavour. Gives charge and velocity.
76692 NTRY=0
76693 100 NTRY=NTRY+1
76694 IF(NTRY.GT.100) THEN
76695 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76696 KFLC=0
76697 RETURN
76698 ENDIF
76699 KFLC=KFL
76700 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76701 MSTJ(93)=1
76702 PMQ=PYMASS(KFLC)
76703 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76704 QF=KCHG(KFLC,1)/3D0
76705 VQ=1D0
76706 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76707
76708C...Calculate weight in QED or QFD case.
76709 IF(MSTJ(102).LE.1) THEN
76710 RF=QF**2
76711 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76712 ELSE
76713 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76714 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76715 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76716 & VQ**3*HF1W
76717 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76718 ENDIF
76719
76720C...Weighting or new event (radiative photon). Cross-section update.
76721 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76722 PARJ(158)=PARJ(158)+1D0
76723 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76724 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76725 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76726 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76727 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76728
76729 RETURN
76730 END
76731
76732C*********************************************************************
76733
76734C...PYXJET
76735C...Selects number of jets in matrix element approach.
76736
76737 SUBROUTINE PYXJET(ECM,NJET,CUT)
76738
76739C...Double precision and integer declarations.
76740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76741 IMPLICIT INTEGER(I-N)
76742 INTEGER PYK,PYCHGE,PYCOMP
76743C...Commonblocks.
76744 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76745 SAVE /PYDAT1/
76746C...Local array and data.
76747 DIMENSION ZHUT(5)
76748 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76749
76750C...Trivial result for two-jets only, including parton shower.
76751 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76752 CUT=0D0
76753
76754C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76755 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76756 CF=4D0/3D0
76757 IF(MSTJ(109).EQ.2) CF=1D0
76758 IF(MSTJ(111).EQ.0) THEN
76759 Q2=ECM**2
76760 Q2R=ECM**2
76761 ELSEIF(MSTU(111).EQ.0) THEN
76762 PARJ(169)=MIN(1D0,PARJ(129))
76763 Q2=PARJ(169)*ECM**2
76764 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76765 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76766 Q2R=PARJ(168)*ECM**2
76767 ELSE
76768 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76769 Q2=PARJ(169)*ECM**2
76770 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76771 & (2D0*PARU(112)/ECM)**2))
76772 Q2R=PARJ(168)*ECM**2
76773 ENDIF
76774
76775C...alpha_strong for R and R itself.
76776 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76777 IF(IABS(MSTJ(101)).EQ.1) THEN
76778 RQCD=1D0+ALSPI
76779 ELSEIF(MSTJ(109).EQ.0) THEN
76780 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76781 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76782 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76783 ELSE
76784 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76785 ENDIF
76786
76787C...alpha_strong for jet rate. Initial value for y cut.
76788 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76789 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76790 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76791 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76792 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76793
76794C...Parametrization of first order three-jet cross-section.
76795 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76796 PARJ(152)=0D0
76797 ELSE
76798 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76799 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76800 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76801 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76802 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76803 & PARJ(152)=0D0
76804 ENDIF
76805
76806C...Parametrization of second order three-jet cross-section.
76807 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76808 & CUT.GE.0.25D0) THEN
76809 PARJ(153)=0D0
76810 ELSEIF(MSTJ(110).LE.1) THEN
76811 CT=LOG(1D0/CUT-2D0)
76812 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76813 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76814
76815C...Interpolation in second/first order ratio for Zhu parametrization.
76816 ELSEIF(MSTJ(110).EQ.2) THEN
76817 IZA=0
76818 DO 110 IY=1,5
76819 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76820 110 CONTINUE
76821 IF(IZA.NE.0) THEN
76822 ZHURAT=ZHUT(IZA)
76823 ELSE
76824 IZ=100D0*CUT
76825 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76826 ENDIF
76827 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76828 ENDIF
76829
76830C...Shift in second order three-jet cross-section with optimized Q^2.
76831 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76832 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76833 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76834
76835C...Parametrization of second order four-jet cross-section.
76836 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76837 PARJ(154)=0D0
76838 ELSE
76839 CT=LOG(1D0/CUT-5D0)
76840 IF(CUT.LE.0.018D0) THEN
76841 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76842 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76843 & 0.4059D0*CT**2)
76844 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76845 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76846 ELSE
76847 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76848 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76849 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76850 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76851 & 0.002093D0*CT**3)
76852 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76853 ENDIF
76854 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76855 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76856 ENDIF
76857
76858C...If negative three-jet rate, change y' optimization parameter.
76859 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76860 & PARJ(169).LT.0.99D0) THEN
76861 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76862 Q2=PARJ(169)*ECM**2
76863 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76864 GOTO 100
76865 ENDIF
76866
76867C...If too high cross-section, use harder cuts, or fail.
76868 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76869 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76870 & PARJ(169).LT.0.99D0) THEN
76871 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76872 Q2=PARJ(169)*ECM**2
76873 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76874 GOTO 100
76875 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76876 CALL PYERRM(26,
76877 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76878 ENDIF
76879 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76880 & PARJ(154))**(-1D0/3D0)
76881 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76882 GOTO 100
76883 ENDIF
76884
76885C...Scalar gluon (first order only).
76886 ELSE
76887 ALSPI=PYALPS(ECM**2)/PARU(1)
76888 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76889 PARJ(152)=0D0
76890 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76891 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76892 PARJ(153)=0D0
76893 PARJ(154)=0D0
76894 ENDIF
76895
76896C...Select number of jets.
76897 PARJ(150)=CUT
76898 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76899 NJET=2
76900 ELSEIF(MSTJ(101).LE.0) THEN
76901 NJET=MIN(4,2-MSTJ(101))
76902 ELSE
76903 RNJ=PYR(0)
76904 NJET=2
76905 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76906 IF(PARJ(154).GT.RNJ) NJET=4
76907 ENDIF
76908
76909 RETURN
76910 END
76911
76912C*********************************************************************
76913
76914C...PYX3JT
76915C...Selects the kinematical variables of three-jet events.
76916
76917 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76918
76919C...Double precision and integer declarations.
76920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76921 IMPLICIT INTEGER(I-N)
76922 INTEGER PYK,PYCHGE,PYCOMP
76923C...Commonblocks.
76924 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76925 SAVE /PYDAT1/
76926C...Local array.
76927 DIMENSION ZHUP(5,12)
76928
76929C...Coefficients of Zhu second order parametrization.
76930 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76931 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76932 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76933 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76934 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76935 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76936 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76937 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76938 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76939 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76940 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76941
76942C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76943 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76944 &X**7/49D0
76945
76946C...Event type. Mass effect factors and other common constants.
76947 MSTJ(120)=2
76948 MSTJ(121)=0
76949 PMQ=PYMASS(KFL)
76950 QME=(2D0*PMQ/ECM)**2
76951 IF(MSTJ(109).NE.1) THEN
76952 CUTL=LOG(CUT)
76953 CUTD=LOG(1D0/CUT-2D0)
76954 IF(MSTJ(109).EQ.0) THEN
76955 CF=4D0/3D0
76956 CN=3D0
76957 TR=2D0
76958 WTMX=MIN(20D0,37D0-6D0*CUTD)
76959 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
76960 ELSE
76961 CF=1D0
76962 CN=0D0
76963 TR=12D0
76964 WTMX=0D0
76965 ENDIF
76966
76967C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
76968 ALS2PI=PARU(118)/PARU(2)
76969 WTOPT=0D0
76970 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
76971 & LOG(PARJ(169))*ALS2PI
76972 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
76973
76974C...Choose three-jet events in allowed region.
76975 100 NJET=3
76976 110 Y13L=CUTL+CUTD*PYR(0)
76977 Y23L=CUTL+CUTD*PYR(0)
76978 Y13=EXP(Y13L)
76979 Y23=EXP(Y23L)
76980 Y12=1D0-Y13-Y23
76981 IF(Y12.LE.CUT) GOTO 110
76982 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
76983
76984C...Second order corrections.
76985 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
76986 Y12L=LOG(Y12)
76987 Y13M=LOG(1D0-Y13)
76988 Y23M=LOG(1D0-Y23)
76989 Y12M=LOG(1D0-Y12)
76990 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
76991 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
76992 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
76993 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
76994 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
76995 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
76996 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
76997 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
76998 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
76999 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77000 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77001 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77002 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77003 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77004 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77005 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77006 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77007 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77008 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77009 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77010 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77011 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77012 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77013 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77014 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77015 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77016 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77017
77018 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77019C...Second order corrections; Zhu parametrization of ERT.
77020 ZX=(Y23-Y13)**2
77021 ZY=1D0-Y12
77022 IZA=0
77023 DO 120 IY=1,5
77024 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77025 120 CONTINUE
77026 IF(IZA.NE.0) THEN
77027 IZ=IZA
77028 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77029 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77030 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77031 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77032 ELSE
77033 IZ=100D0*CUT
77034 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77035 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77036 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77037 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77038 IZ=IZ+1
77039 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77040 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77041 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77042 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77043 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77044 ENDIF
77045 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77046 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77047 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77048 ENDIF
77049
77050C...Impose mass cuts (gives two jets). For fixed jet number new try.
77051 X1=1D0-Y23
77052 X2=1D0-Y13
77053 X3=1D0-Y12
77054 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77055 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77056 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77057 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77058 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77059
77060C...Scalar gluon model (first order only, no mass effects).
77061 ELSE
77062 130 NJET=3
77063 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77064 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77065 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77066 X1=1D0-0.5D0*(X3+YD)
77067 X2=1D0-0.5D0*(X3-YD)
77068 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77069 IF(MSTJ(102).GE.2) THEN
77070 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77071 & X3**2*PYR(0)) NJET=2
77072 ENDIF
77073 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77074 ENDIF
77075
77076 RETURN
77077 END
77078
77079C*********************************************************************
77080
77081C...PYX4JT
77082C...Selects the kinematical variables of four-jet events.
77083
77084 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77085
77086C...Double precision and integer declarations.
77087 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77088 IMPLICIT INTEGER(I-N)
77089 INTEGER PYK,PYCHGE,PYCOMP
77090C...Commonblocks.
77091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77092 SAVE /PYDAT1/
77093C...Local arrays.
77094 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77095
77096C...Common constants. Colour factors for QCD and Abelian gluon theory.
77097 PMQ=PYMASS(KFL)
77098 QME=(2D0*PMQ/ECM)**2
77099 CT=LOG(1D0/CUT-5D0)
77100 IF(MSTJ(109).EQ.0) THEN
77101 CF=4D0/3D0
77102 CN=3D0
77103 TR=2.5D0
77104 ELSE
77105 CF=1D0
77106 CN=0D0
77107 TR=15D0
77108 ENDIF
77109
77110C...Choice of process (qqbargg or qqbarqqbar).
77111 100 NJET=4
77112 IT=1
77113 IF(PARJ(155).GT.PYR(0)) IT=2
77114 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77115 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77116 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77117 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77118 ID=1
77119
77120C...Sample the five kinematical variables (for qqgg preweighted in y34).
77121 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77122 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77123 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77124 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77125 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77126 VT=PYR(0)
77127 CP=COS(PARU(1)*PYR(0))
77128 Y14=(Y134-Y34)*VT
77129 Y13=Y134-Y14-Y34
77130 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77131 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77132 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77133 Y23=Y234-Y34-Y24
77134 Y12=1D0-Y134-Y23-Y24
77135 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77136 Y123=Y12+Y13+Y23
77137 Y124=Y12+Y14+Y24
77138
77139C...Calculate matrix elements for qqgg or qqqq process.
77140 IC=0
77141 WTTOT=0D0
77142 120 IC=IC+1
77143 IF(IT.EQ.1) THEN
77144 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77145 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77146 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77147 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77148 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77149 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77150 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77151 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77152 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77153 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77154 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77155 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77156 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77157 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77158 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77159 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77160 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77161 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77162 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77163 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77164 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77165 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77166 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77167 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77168 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77169 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77170 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77171 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77172 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77173 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77174 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77175 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77176 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77177 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77178 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77179 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77180 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77181 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77182 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77183 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77184 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77185 & CN*WTC(IC))/8D0
77186 ELSE
77187 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77188 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77189 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77190 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77191 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77192 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77193 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77194 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77195 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77196 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77197 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77198 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77199 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77200 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77201 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77202 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77203 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77204 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77205 ENDIF
77206
77207C...Permutations of momenta in matrix element. Weighting.
77208 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77209 YSAV=Y13
77210 Y13=Y14
77211 Y14=YSAV
77212 YSAV=Y23
77213 Y23=Y24
77214 Y24=YSAV
77215 YSAV=Y123
77216 Y123=Y124
77217 Y124=YSAV
77218 ENDIF
77219 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77220 YSAV=Y13
77221 Y13=Y23
77222 Y23=YSAV
77223 YSAV=Y14
77224 Y14=Y24
77225 Y24=YSAV
77226 YSAV=Y134
77227 Y134=Y234
77228 Y234=YSAV
77229 ENDIF
77230 IF(IC.LE.3) GOTO 120
77231 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77232 IC=5
77233
77234C...qqgg events: string configuration and event type.
77235 IF(IT.EQ.1) THEN
77236 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77237 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77238 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77239 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77240 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77241 IF(ID.EQ.2) GOTO 130
77242 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77243 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77244 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77245 IF(ID.EQ.2) GOTO 130
77246 ENDIF
77247 MSTJ(120)=3
77248 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77249 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77250 KFLN=21
77251
77252C...Mass cuts. Kinematical variables out.
77253 IF(Y12.LE.CUT+QME) NJET=2
77254 IF(NJET.EQ.2) GOTO 150
77255 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77256 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77257 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77258 X2=1D0-Y124
77259 X12=(1D0-Q12)*Y13+Q12*Y23
77260 X14=Y12-0.5D0*QME
77261 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77262
77263C...qqbarqqbar events: string configuration, choose new flavour.
77264 ELSE
77265 IF(ID.EQ.1) THEN
77266 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77267 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77268 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77269 IF(WTR.LT.WTD(4)) ID=4
77270 IF(ID.GE.2) GOTO 130
77271 ENDIF
77272 MSTJ(120)=5
77273 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77274 140 KFLN=1+INT(5D0*PYR(0))
77275 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77276 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77277 IF(KFLN.GT.MSTJ(104)) NJET=2
77278 PMQN=PYMASS(KFLN)
77279 QMEN=(2D0*PMQN/ECM)**2
77280
77281C...Mass cuts. Kinematical variables out.
77282 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77283 IF(NJET.EQ.2) GOTO 150
77284 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77285 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77286 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77287 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77288 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77289 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77290 & Q13*Y23)
77291 X14=Y24-0.5D0*QME
77292 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77293 & Q13*Y14)
77294 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77295 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77296 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77297 ENDIF
77298 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77299
77300 RETURN
77301 END
77302
77303C*********************************************************************
77304
77305C...PYXDIF
77306C...Gives the angular orientation of events.
77307
77308 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77309
77310C...Double precision and integer declarations.
77311 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77312 IMPLICIT INTEGER(I-N)
77313 INTEGER PYK,PYCHGE,PYCOMP
77314C...Commonblocks.
77315 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77316 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77317 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77318 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77319
77320C...Charge. Factors depending on polarization for QED case.
77321 QF=KCHG(KFL,1)/3D0
77322 POLL=1D0-PARJ(131)*PARJ(132)
77323 POLD=PARJ(132)-PARJ(131)
77324 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77325 HF1=POLL
77326 HF2=0D0
77327 HF3=PARJ(133)**2
77328 HF4=0D0
77329
77330C...Factors depending on flavour, energy and polarization for QFD case.
77331 ELSE
77332 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77333 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77334 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77335 AE=-1D0
77336 VE=4D0*PARU(102)-1D0
77337 AF=SIGN(1D0,QF)
77338 VF=AF-4D0*QF*PARU(102)
77339 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77340 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77341 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77342 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77343 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77344 & SFW*SFF**2*(VE**2-AE**2))
77345 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77346 & SFF*AE
77347 ENDIF
77348
77349C...Mass factor. Differential cross-sections for two-jet events.
77350 SQ2=SQRT(2D0)
77351 QME=0D0
77352 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77353 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77354 IF(NJET.EQ.2) THEN
77355 SIGU=4D0*SQRT(1D0-QME)
77356 SIGL=2D0*QME*SQRT(1D0-QME)
77357 SIGT=0D0
77358 SIGI=0D0
77359 SIGA=0D0
77360 SIGP=4D0
77361
77362C...Kinematical variables. Reduce four-jet event to three-jet one.
77363 ELSE
77364 IF(NJET.EQ.3) THEN
77365 X1=2D0*P(NC+1,4)/ECM
77366 X2=2D0*P(NC+3,4)/ECM
77367 ELSE
77368 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77369 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77370 X1=2D0*P(NC+1,4)/ECMR
77371 X2=2D0*P(NC+4,4)/ECMR
77372 ENDIF
77373
77374C...Differential cross-sections for three-jet (or reduced four-jet).
77375 XQ=(1D0-X1)/(1D0-X2)
77376 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77377 ST12=SQRT(1D0-CT12**2)
77378 IF(MSTJ(109).NE.1) THEN
77379 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77380 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77381 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77382 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77383 & X2)*XQ
77384 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77385 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77386 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77387 SIGA=X2**2*ST12/SQ2
77388 SIGP=2D0*(X1**2-X2**2*CT12)
77389
77390C...Differential cross-sect for scalar gluons (no mass effects).
77391 ELSE
77392 X3=2D0-X1-X2
77393 XT=X2*ST12
77394 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77395 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77396 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77397 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77398 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77399 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77400 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77401 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77402 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77403 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77404 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77405 ENDIF
77406 ENDIF
77407
77408C...Upper bounds for differential cross-section.
77409 HF1A=ABS(HF1)
77410 HF2A=ABS(HF2)
77411 HF3A=ABS(HF3)
77412 HF4A=ABS(HF4)
77413 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77414 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77415 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77416 &2D0*HF2A*ABS(SIGP)
77417
77418C...Generate angular orientation according to differential cross-sect.
77419 100 CHI=PARU(2)*PYR(0)
77420 CTHE=2D0*PYR(0)-1D0
77421 PHI=PARU(2)*PYR(0)
77422 CCHI=COS(CHI)
77423 SCHI=SIN(CHI)
77424 C2CHI=COS(2D0*CHI)
77425 S2CHI=SIN(2D0*CHI)
77426 THE=ACOS(CTHE)
77427 STHE=SIN(THE)
77428 C2PHI=COS(2D0*(PHI-PARJ(134)))
77429 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77430 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77431 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77432 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77433 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77434 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77435 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77436 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77437 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77438
77439 RETURN
77440 END
77441
77442C*********************************************************************
77443
77444C...PYONIA
77445C...Generates Upsilon and toponium decays into three gluons
77446C...or two gluons and a photon.
77447
77448 SUBROUTINE PYONIA(KFL,ECM)
77449
77450C...Double precision and integer declarations.
77451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77452 IMPLICIT INTEGER(I-N)
77453 INTEGER PYK,PYCHGE,PYCOMP
77454C...Commonblocks.
77455 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77456 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77457 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77458 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77459
77460C...Printout. Check input parameters.
77461 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77462 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77463 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77464 IF(MSTU(21).GE.1) RETURN
77465 ENDIF
77466 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77467 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77468 IF(MSTU(21).GE.1) RETURN
77469 ENDIF
77470
77471C...Initial e+e- and onium state (optional).
77472 NC=0
77473 IF(MSTJ(115).GE.2) THEN
77474 NC=NC+2
77475 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77476 K(NC-1,1)=21
77477 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77478 K(NC,1)=21
77479 ENDIF
77480 KFLC=IABS(KFL)
77481 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77482 NC=NC+1
77483 KF=110*KFLC+3
77484 MSTU10=MSTU(10)
77485 MSTU(10)=1
77486 P(NC,5)=ECM
77487 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77488 K(NC,1)=21
77489 K(NC,3)=1
77490 MSTU(10)=MSTU10
77491 ENDIF
77492
77493C...Choose x1 and x2 according to matrix element.
77494 NTRY=0
77495 100 X1=PYR(0)
77496 X2=PYR(0)
77497 X3=2D0-X1-X2
77498 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77499 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77500 NTRY=NTRY+1
77501 NJET=3
77502 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77503 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77504
77505C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77506 MSTU(111)=MSTJ(108)
77507 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77508 &MSTU(111)=1
77509 PARU(112)=PARJ(121)
77510 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77511 QF=0D0
77512 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77513 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77514 MK=0
77515 ECMC=ECM
77516 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77517 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77518 & NJET=2
77519 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77520 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77521 ELSE
77522 MK=1
77523 ECMC=SQRT(1D0-X1)*ECM
77524 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77525 K(NC+1,1)=1
77526 K(NC+1,2)=22
77527 K(NC+1,4)=0
77528 K(NC+1,5)=0
77529 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77530 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77531 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77532 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77533 NJET=2
77534 IF(ECMC.LT.4D0*PARJ(127)) THEN
77535 MSTU10=MSTU(10)
77536 MSTU(10)=1
77537 P(NC+2,5)=ECMC
77538 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77539 MSTU(10)=MSTU10
77540 NJET=0
77541 ENDIF
77542 ENDIF
77543 DO 110 IP=NC+1,N
77544 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77545 110 CONTINUE
77546
77547C...Differential cross-sections. Upper limit for cross-section.
77548 IF(MSTJ(106).EQ.1) THEN
77549 SQ2=SQRT(2D0)
77550 HF1=1D0-PARJ(131)*PARJ(132)
77551 HF3=PARJ(133)**2
77552 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77553 ST13=SQRT(1D0-CT13**2)
77554 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77555 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77556 SIGT=0.5D0*SIGL
77557 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77558 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77559 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77560
77561C...Angular orientation of event.
77562 120 CHI=PARU(2)*PYR(0)
77563 CTHE=2D0*PYR(0)-1D0
77564 PHI=PARU(2)*PYR(0)
77565 CCHI=COS(CHI)
77566 SCHI=SIN(CHI)
77567 C2CHI=COS(2D0*CHI)
77568 S2CHI=SIN(2D0*CHI)
77569 THE=ACOS(CTHE)
77570 STHE=SIN(THE)
77571 C2PHI=COS(2D0*(PHI-PARJ(134)))
77572 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77573 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77574 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77575 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77576 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77577 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77578 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77579 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77580 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77581 ENDIF
77582
77583C...Generate parton shower. Rearrange along strings and check.
77584 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77585 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77586 MSTJ14=MSTJ(14)
77587 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77588 IF(MSTJ(105).GE.0) MSTU(28)=0
77589 CALL PYPREP(0)
77590 MSTJ(14)=MSTJ14
77591 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77592 ENDIF
77593
77594C...Generate fragmentation. Information for PYTABU:
77595 IF(MSTJ(105).EQ.1) CALL PYEXEC
77596 MSTU(161)=110*KFLC+3
77597 MSTU(162)=0
77598
77599 RETURN
77600 END
77601
77602C*********************************************************************
77603
77604C...PYBOOK
77605C...Books a histogram.
77606
77607 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77608
77609C...Double precision declaration.
77610 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77611 IMPLICIT INTEGER(I-N)
77612C...Commonblock.
77613 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77614 SAVE /PYBINS/
77615C...Local character variables.
77616 CHARACTER TITLE*(*), TITFX*60
77617
77618C...Check that input is sensible. Find initial address in memory.
77619 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77620 &'(PYBOOK:) not allowed histogram number')
77621 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77622 &'(PYBOOK:) not allowed number of bins')
77623 IF(XL.GE.XU) CALL PYERRM(28,
77624 &'(PYBOOK:) x limits in wrong order')
77625 INDX(ID)=IHIST(4)
77626 IHIST(4)=IHIST(4)+28+NX
77627 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77628 &'(PYBOOK:) out of histogram space')
77629 IS=INDX(ID)
77630
77631C...Store histogram size and reset contents.
77632 BIN(IS+1)=NX
77633 BIN(IS+2)=XL
77634 BIN(IS+3)=XU
77635 BIN(IS+4)=(XU-XL)/NX
77636 CALL PYNULL(ID)
77637
77638C...Store title by conversion to integer to double precision.
77639 TITFX=TITLE//' '
77640 DO 100 IT=1,20
77641 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77642 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77643 100 CONTINUE
77644
77645 RETURN
77646 END
77647
77648C*********************************************************************
77649
77650C...PYFILL
77651C...Fills entry in histogram.
77652
77653 SUBROUTINE PYFILL(ID,X,W)
77654
77655C...Double precision declaration.
77656 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77657 IMPLICIT INTEGER(I-N)
77658C...Commonblock.
77659 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77660 SAVE /PYBINS/
77661
77662C...Find initial address in memory. Increase number of entries.
77663 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77664 &'(PYFILL:) not allowed histogram number')
77665 IS=INDX(ID)
77666 IF(IS.EQ.0) CALL PYERRM(28,
77667 &'(PYFILL:) filling unbooked histogram')
77668 BIN(IS+5)=BIN(IS+5)+1D0
77669
77670C...Find bin in x, including under/overflow, and fill.
77671 IF(X.LT.BIN(IS+2)) THEN
77672 BIN(IS+6)=BIN(IS+6)+W
77673 ELSEIF(X.GE.BIN(IS+3)) THEN
77674 BIN(IS+8)=BIN(IS+8)+W
77675 ELSE
77676 BIN(IS+7)=BIN(IS+7)+W
77677 IX=(X-BIN(IS+2))/BIN(IS+4)
77678 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77679 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77680 ENDIF
77681
77682 RETURN
77683 END
77684
77685C*********************************************************************
77686
77687C...PYFACT
77688C...Multiplies histogram contents by factor.
77689
77690 SUBROUTINE PYFACT(ID,F)
77691
77692C...Double precision declaration.
77693 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77694 IMPLICIT INTEGER(I-N)
77695C...Commonblock.
77696 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77697 SAVE /PYBINS/
77698
77699C...Find initial address in memory. Multiply all contents bins.
77700 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77701 &'(PYFACT:) not allowed histogram number')
77702 IS=INDX(ID)
77703 IF(IS.EQ.0) CALL PYERRM(28,
77704 &'(PYFACT:) scaling unbooked histogram')
77705 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77706 BIN(IX)=F*BIN(IX)
77707 100 CONTINUE
77708
77709 RETURN
77710 END
77711
77712C*********************************************************************
77713
77714C...PYOPER
77715C...Performs operations between histograms.
77716
77717 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77718
77719C...Double precision declaration.
77720 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77721 IMPLICIT INTEGER(I-N)
77722C...Commonblock.
77723 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77724 SAVE /PYBINS/
77725C...Character variable.
77726 CHARACTER OPER*(*)
77727
77728C...Find initial addresses in memory, and histogram size.
77729 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77730 &'(PYFACT:) not allowed histogram number')
77731 IS1=INDX(ID1)
77732 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77733 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77734 NX=NINT(BIN(IS3+1))
77735 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77736
77737C...Update info on number of histogram entries.
77738 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77739 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77740 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77741 BIN(IS3+5)=BIN(IS1+5)
77742 ENDIF
77743
77744C...Operations on pair of histograms: addition, subtraction,
77745C...multiplication, division.
77746 IF(OPER.EQ.'+') THEN
77747 DO 100 IX=6,8+NX
77748 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77749 100 CONTINUE
77750 ELSEIF(OPER.EQ.'-') THEN
77751 DO 110 IX=6,8+NX
77752 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77753 110 CONTINUE
77754 ELSEIF(OPER.EQ.'*') THEN
77755 DO 120 IX=6,8+NX
77756 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77757 120 CONTINUE
77758 ELSEIF(OPER.EQ.'/') THEN
77759 DO 130 IX=6,8+NX
77760 FA2=F2*BIN(IS2+IX)
77761 IF(ABS(FA2).LE.1D-20) THEN
77762 BIN(IS3+IX)=0D0
77763 ELSE
77764 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77765 ENDIF
77766 130 CONTINUE
77767
77768C...Operations on single histogram: multiplication+addition,
77769C...square root+addition, logarithm+addition.
77770 ELSEIF(OPER.EQ.'A') THEN
77771 DO 140 IX=6,8+NX
77772 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77773 140 CONTINUE
77774 ELSEIF(OPER.EQ.'S') THEN
77775 DO 150 IX=6,8+NX
77776 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77777 150 CONTINUE
77778 ELSEIF(OPER.EQ.'L') THEN
77779 ZMIN=1D20
77780 DO 160 IX=9,8+NX
77781 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77782 & ZMIN=0.8D0*BIN(IS1+IX)
77783 160 CONTINUE
77784 DO 170 IX=6,8+NX
77785 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77786 170 CONTINUE
77787
77788C...Operation on two or three histograms: average and
77789C...standard deviation.
77790 ELSEIF(OPER.EQ.'M') THEN
77791 DO 180 IX=6,8+NX
77792 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77793 BIN(IS2+IX)=0D0
77794 ELSE
77795 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77796 ENDIF
77797 IF(ID3.NE.0) THEN
77798 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77799 BIN(IS3+IX)=0D0
77800 ELSE
77801 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77802 & BIN(IS2+IX)**2))
77803 ENDIF
77804 ENDIF
77805 BIN(IS1+IX)=F1*BIN(IS1+IX)
77806 180 CONTINUE
77807 ENDIF
77808
77809 RETURN
77810 END
77811
77812C*********************************************************************
77813
77814C...PYHIST
77815C...Prints and resets all histograms.
77816
77817 SUBROUTINE PYHIST
77818
77819C...Double precision declaration.
77820 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77821 IMPLICIT INTEGER(I-N)
77822C...Commonblock.
77823 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77824 SAVE /PYBINS/
77825
77826C...Loop over histograms, print and reset used ones.
77827 DO 100 ID=1,IHIST(1)
77828 IS=INDX(ID)
77829 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77830 CALL PYPLOT(ID)
77831 CALL PYNULL(ID)
77832 ENDIF
77833 100 CONTINUE
77834
77835 RETURN
77836 END
77837
77838C*********************************************************************
77839
77840C...PYPLOT
77841C...Prints a histogram (but does not reset it).
77842
77843 SUBROUTINE PYPLOT(ID)
77844
77845C...Double precision declaration.
77846 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77847 IMPLICIT INTEGER(I-N)
77848C...Commonblocks.
77849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77850 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77851 SAVE /PYDAT1/,/PYBINS/
77852C...Local arrays and character variables.
77853 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77854 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77855
77856C...Steps in histogram scale. Character sequence.
77857 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77858 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77859
77860C...Find initial address in memory; skip if empty histogram.
77861 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77862 IS=INDX(ID)
77863 IF(IS.EQ.0) RETURN
77864 IF(NINT(BIN(IS+5)).LE.0) THEN
77865 WRITE(MSTU(11),5000) ID
77866 RETURN
77867 ENDIF
77868
77869C...Number of histogram lines and x bins.
77870 LIN=IHIST(3)-18
77871 NX=NINT(BIN(IS+1))
77872
77873C...Extract title by conversion from double precision via integer.
77874 DO 100 IT=1,20
77875 IEQ=NINT(BIN(IS+8+NX+IT))
77876 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77877 & //CHAR(MOD(IEQ,256))
77878 100 CONTINUE
77879
77880C...Find time; print title.
77881 CALL PYTIME(IDATI)
77882 IF(IDATI(1).GT.0) THEN
77883 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77884 ELSE
77885 WRITE(MSTU(11),5200) ID, TITLE
77886 ENDIF
77887
77888C...Find minimum and maximum bin content.
77889 YMIN=BIN(IS+9)
77890 YMAX=BIN(IS+9)
77891 DO 110 IX=IS+10,IS+8+NX
77892 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77893 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77894 110 CONTINUE
77895
77896C...Determine scale and step size for y axis.
77897 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77898 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77899 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77900 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77901 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77902 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77903 DELY=DYAC(1)
77904 DO 120 IDEL=1,9
77905 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77906 120 CONTINUE
77907 DY=DELY*10D0**IPOT
77908
77909C...Convert bin contents to integer form; fractional fill in top row.
77910 DO 130 IX=1,NX
77911 CTA=ABS(BIN(IS+8+IX))/DY
77912 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77913 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77914 130 CONTINUE
77915 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77916 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77917
77918C...Print histogram row by row.
77919 DO 150 IR=IRMA,IRMI,-1
77920 IF(IR.EQ.0) GOTO 150
77921 OUT=' '
77922 DO 140 IX=1,NX
77923 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77924 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77925 140 CONTINUE
77926 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77927 150 CONTINUE
77928
77929C...Print sign and value of bin contents.
77930 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77931 OUT=' '
77932 DO 160 IX=1,NX
77933 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77934 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77935 160 CONTINUE
77936 WRITE(MSTU(11),5400) OUT
77937 DO 180 IR=4,1,-1
77938 DO 170 IX=1,NX
77939 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77940 170 CONTINUE
77941 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77942 180 CONTINUE
77943
77944C...Print sign and value of lower bin edge.
77945 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77946 & 10.0001D0)-10
77947 OUT=' '
77948 DO 190 IX=1,NX
77949 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
77950 & OUT(IX:IX)=CHA(11)
77951 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
77952 190 CONTINUE
77953 WRITE(MSTU(11),5600) OUT
77954 DO 210 IR=3,1,-1
77955 DO 200 IX=1,NX
77956 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77957 200 CONTINUE
77958 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
77959 210 CONTINUE
77960 ENDIF
77961
77962C...Calculate and print statistics.
77963 CSUM=0D0
77964 CXSUM=0D0
77965 CXXSUM=0D0
77966 DO 220 IX=1,NX
77967 CTA=ABS(BIN(IS+8+IX))
77968 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
77969 CSUM=CSUM+CTA
77970 CXSUM=CXSUM+CTA*X
77971 CXXSUM=CXXSUM+CTA*X**2
77972 220 CONTINUE
77973 XMEAN=CXSUM/MAX(CSUM,1D-20)
77974 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
77975 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
77976 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
77977
77978C...Formats for output.
77979 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
77980 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
77981 &I2,':',I2/)
77982 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
77983 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
77984 5400 FORMAT(/8X,'Contents',3X,A100)
77985 5500 FORMAT(9X,'*10**',I2,3X,A100)
77986 5600 FORMAT(/8X,'Low edge',3X,A100)
77987 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
77988 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
77989 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
77990
77991 RETURN
77992 END
77993
77994C*********************************************************************
77995
77996C...PYNULL
77997C...Resets bin contents of a histogram.
77998
77999 SUBROUTINE PYNULL(ID)
78000
78001C...Double precision declaration.
78002 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78003 IMPLICIT INTEGER(I-N)
78004C...Commonblock.
78005 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78006 SAVE /PYBINS/
78007
78008 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78009 IS=INDX(ID)
78010 IF(IS.EQ.0) RETURN
78011 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78012 BIN(IX)=0D0
78013 100 CONTINUE
78014
78015 RETURN
78016 END
78017
78018C*********************************************************************
78019
78020C...PYDUMP
78021C...Dumps histogram contents on file for reading by other program.
78022C...Can also read back own dump.
78023
78024 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78025
78026C...Double precision declaration.
78027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78028 IMPLICIT INTEGER(I-N)
78029C...Commonblock.
78030 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78031 SAVE /PYBINS/
78032C...Local arrays and character variables.
78033 DIMENSION IHI(*),ISS(100),VAL(5)
78034 CHARACTER TITLE*60,FORMAT*13
78035
78036C...Dump all histograms that have been booked,
78037C...including titles and ranges, one after the other.
78038 IF(MDUMP.EQ.1) THEN
78039
78040C...Loop over histograms and find which are wanted and booked.
78041 IF(NHI.LE.0) THEN
78042 NW=IHIST(1)
78043 ELSE
78044 NW=NHI
78045 ENDIF
78046 DO 130 IW=1,NW
78047 IF(NHI.EQ.0) THEN
78048 ID=IW
78049 ELSE
78050 ID=IHI(IW)
78051 ENDIF
78052 IS=INDX(ID)
78053 IF(IS.NE.0) THEN
78054
78055C...Write title, histogram size, filling statistics.
78056 NX=NINT(BIN(IS+1))
78057 DO 100 IT=1,20
78058 IEQ=NINT(BIN(IS+8+NX+IT))
78059 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78060 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78061 100 CONTINUE
78062 WRITE(LFN,5100) ID,TITLE
78063 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78064 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78065 & BIN(IS+8)
78066
78067
78068C...Write histogram contents, in groups of five.
78069 DO 120 IXG=1,(NX+4)/5
78070 DO 110 IXV=1,5
78071 IX=5*IXG+IXV-5
78072 IF(IX.LE.NX) THEN
78073 VAL(IXV)=BIN(IS+8+IX)
78074 ELSE
78075 VAL(IXV)=0D0
78076 ENDIF
78077 110 CONTINUE
78078 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78079 120 CONTINUE
78080
78081C...Go to next histogram; finish.
78082 ELSEIF(NHI.GT.0) THEN
78083 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78084 ENDIF
78085 130 CONTINUE
78086
78087C...Read back in histograms dumped MDUMP=1.
78088 ELSEIF(MDUMP.EQ.2) THEN
78089
78090C...Read histogram number, title and range, and book.
78091 140 READ(LFN,5100,END=170) ID,TITLE
78092 READ(LFN,5200) NX,XL,XU
78093 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78094 IS=INDX(ID)
78095
78096C...Read filling statistics.
78097 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78098 BIN(IS+5)=DBLE(NENTRY)
78099
78100C...Read histogram contents, in groups of five.
78101 DO 160 IXG=1,(NX+4)/5
78102 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78103 DO 150 IXV=1,5
78104 IX=5*IXG+IXV-5
78105 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78106 150 CONTINUE
78107 160 CONTINUE
78108
78109C...Go to next histogram; finish.
78110 GOTO 140
78111 170 CONTINUE
78112
78113C...Write histogram contents in column format,
78114C...convenient e.g. for GNUPLOT input.
78115 ELSEIF(MDUMP.EQ.3) THEN
78116
78117C...Find addresses to wanted histograms.
78118 NSS=0
78119 IF(NHI.LE.0) THEN
78120 NW=IHIST(1)
78121 ELSE
78122 NW=NHI
78123 ENDIF
78124 DO 180 IW=1,NW
78125 IF(NHI.EQ.0) THEN
78126 ID=IW
78127 ELSE
78128 ID=IHI(IW)
78129 ENDIF
78130 IS=INDX(ID)
78131 IF(IS.NE.0.AND.NSS.LT.100) THEN
78132 NSS=NSS+1
78133 ISS(NSS)=IS
78134 ELSEIF(NSS.GE.100) THEN
78135 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78136 ELSEIF(NHI.GT.0) THEN
78137 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78138 ENDIF
78139 180 CONTINUE
78140
78141C...Check that they have common number of x bins. Fix format.
78142 NX=NINT(BIN(ISS(1)+1))
78143 DO 190 IW=2,NSS
78144 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78145 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78146 RETURN
78147 ENDIF
78148 190 CONTINUE
78149 FORMAT='(1P,000E12.4)'
78150 WRITE(FORMAT(5:7),'(I3)') NSS+1
78151
78152C...Write histogram contents; first column x values.
78153 DO 200 IX=1,NX
78154 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78155 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78156 200 CONTINUE
78157
78158 ENDIF
78159
78160C...Formats for output.
78161 5100 FORMAT(I5,5X,A60)
78162 5200 FORMAT(I5,1P,2D12.4)
78163 5300 FORMAT(I12,1P,3D12.4)
78164 5400 FORMAT(1P,5D12.4)
78165
78166 RETURN
78167 END
78168
78169C*********************************************************************
78170
78171C...PYSTOP
78172C...Allows users to handle STOP statemens
78173
78174 SUBROUTINE PYSTOP(MCOD)
78175
78176C...Double precision and integer declarations.
78177 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78178 IMPLICIT INTEGER(I-N)
78179 INTEGER PYK,PYCHGE,PYCOMP
78180C...Commonblocks.
78181 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78182 SAVE /PYDAT1/
78183
78184
78185C...Write message, then stop
78186 WRITE(MSTU(11),5000) MCOD
78187 STOP
78188
78189
78190C...Formats for output.
78191 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78192 END
78193
78194C*********************************************************************
78195
78196C...PYKCUT
78197C...Dummy routine, which the user can replace in order to make cuts on
78198C...the kinematics on the parton level before the matrix elements are
78199C...evaluated and the event is generated. The cross-section estimates
78200C...will automatically take these cuts into account, so the given
78201C...values are for the allowed phase space region only. MCUT=0 means
78202C...that the event has passed the cuts, MCUT=1 that it has failed.
78203
78204 SUBROUTINE PYKCUT(MCUT)
78205
78206C...Double precision and integer declarations.
78207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78208 IMPLICIT INTEGER(I-N)
78209 INTEGER PYK,PYCHGE,PYCOMP
78210C...Commonblocks.
78211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78212 COMMON/PYINT1/MINT(400),VINT(400)
78213 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78214 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78215
78216C...Set default value (accepting event) for MCUT.
78217 MCUT=0
78218
78219C...Read out subprocess number.
78220 ISUB=MINT(1)
78221 ISTSB=ISET(ISUB)
78222
78223C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78224 TAU=VINT(21)
78225 YST=VINT(22)
78226 CTH=0D0
78227 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78228 TAUP=0D0
78229 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78230
78231C...Calculate x_1, x_2, x_F.
78232 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78233 X1=SQRT(TAU)*EXP(YST)
78234 X2=SQRT(TAU)*EXP(-YST)
78235 ELSE
78236 X1=SQRT(TAUP)*EXP(YST)
78237 X2=SQRT(TAUP)*EXP(-YST)
78238 ENDIF
78239 XF=X1-X2
78240
78241C...Calculate shat, that, uhat, p_T^2.
78242 SHAT=TAU*VINT(2)
78243 SQM3=VINT(63)
78244 SQM4=VINT(64)
78245 RM3=SQM3/SHAT
78246 RM4=SQM4/SHAT
78247 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78248 RPTS=4D0*VINT(71)**2/SHAT
78249 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78250 RM34=2D0*RM3*RM4
78251 RSQM=1D0+RM34
78252 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78253 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78254 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78255 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78256
78257C...Decisions by user to be put here.
78258
78259C...Stop program if this routine is ever called.
78260C...You should not copy these lines to your own routine.
78261 WRITE(MSTU(11),5000)
78262 CALL PYSTOP(6)
78263
78264C...Format for error printout.
78265 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78266 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78267 &1X,'Execution stopped!')
78268
78269 RETURN
78270 END
78271
78272C*********************************************************************
78273
78274C...PYEVWT
78275C...Dummy routine, which the user can replace in order to multiply the
78276C...standard PYTHIA differential cross-section by a process- and
78277C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78278C...to generation of weighted events, with weight 1/WTXS, while for
78279C...MSTP(142)=2 it corresponds to a modification of the underlying
78280C...physics.
78281
78282 SUBROUTINE PYEVWT(WTXS)
78283
78284C...Double precision and integer declarations.
78285 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78286 IMPLICIT INTEGER(I-N)
78287 INTEGER PYK,PYCHGE,PYCOMP
78288C...Commonblocks.
78289 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78290 COMMON/PYINT1/MINT(400),VINT(400)
78291 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78292 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78293
78294C...Set default weight for WTXS.
78295 WTXS=1D0
78296
78297C...Read out subprocess number.
78298 ISUB=MINT(1)
78299 ISTSB=ISET(ISUB)
78300
78301C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78302 TAU=VINT(21)
78303 YST=VINT(22)
78304 CTH=0D0
78305 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78306 TAUP=0D0
78307 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78308
78309C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78310 X1=VINT(41)
78311 X2=VINT(42)
78312 XF=X1-X2
78313 SHAT=VINT(44)
78314 THAT=VINT(45)
78315 UHAT=VINT(46)
78316 PT2=VINT(48)
78317
78318C...Modifications by user to be put here.
78319
78320C...Stop program if this routine is ever called.
78321C...You should not copy these lines to your own routine.
78322 WRITE(MSTU(11),5000)
78323 CALL PYSTOP(4)
78324
78325C...Format for error printout.
78326 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78327 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78328 &1X,'Execution stopped!')
78329
78330 RETURN
78331 END
78332
78333C*********************************************************************
78334
78335C...UPINIT
78336C...Dummy routine, to be replaced by a user implementing external
78337C...processes. Is supposed to fill the HEPRUP commonblock with info
78338C...on incoming beams and allowed processes.
78339
78340C...New example: handles a standard Les Houches Events File.
78341
78342 SUBROUTINE UPINIT
78343
78344C...Double precision and integer declarations.
78345 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78346 IMPLICIT INTEGER(I-N)
78347
78348C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78349 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78350 SAVE /PYPARS/
78351
78352C...User process initialization commonblock.
78353 INTEGER MAXPUP
78354 PARAMETER (MAXPUP=100)
78355 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78356 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78357 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78358 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78359 &LPRUP(MAXPUP)
78360 SAVE /HEPRUP/
78361
78362C...Lines to read in assumed never longer than 200 characters.
78363 PARAMETER (MAXLEN=200)
78364 CHARACTER*(MAXLEN) STRING
78365
78366C...Format for reading lines.
78367 CHARACTER*6 STRFMT
78368 STRFMT='(A000)'
78369 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78370
78371C...Loop until finds line beginning with "<init>" or "<init ".
78372 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78373 IBEG=0
78374 110 IBEG=IBEG+1
78375C...Allow indentation.
78376 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78377 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78378 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78379
78380C...Read first line of initialization info.
78381 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78382 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78383
78384C...Read NPRUP subsequent lines with information on each process.
78385 DO 120 IPR=1,NPRUP
78386 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78387 & XMAXUP(IPR),LPRUP(IPR)
78388 120 CONTINUE
78389 RETURN
78390
78391C...Error exit: give up if initalization does not work.
78392 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78393 WRITE(*,*) ' Event generation will be stopped.'
78394 CALL PYSTOP(12)
78395
78396 RETURN
78397 END
78398
78399C...Old example: handles a simple Pythia 6.4 initialization file.
78400
78401c SUBROUTINE UPINIT
78402
78403C...Double precision and integer declarations.
78404c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78405c IMPLICIT INTEGER(I-N)
78406
78407C...Commonblocks.
78408c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78409c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78410c SAVE /PYDAT1/,/PYPARS/
78411
78412C...User process initialization commonblock.
78413c INTEGER MAXPUP
78414c PARAMETER (MAXPUP=100)
78415c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78416c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78417c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78418c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78419c &LPRUP(MAXPUP)
78420c SAVE /HEPRUP/
78421
78422C...Read info from file.
78423c IF(MSTP(161).GT.0) THEN
78424c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78425c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78426c DO 100 IPR=1,NPRUP
78427c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78428c & XMAXUP(IPR),LPRUP(IPR)
78429c 100 CONTINUE
78430c RETURN
78431C...Error or prematurely reached end of file.
78432c 110 WRITE(MSTU(11),5000)
78433c STOP
78434
78435C...Else not implemented.
78436c ELSE
78437c WRITE(MSTU(11),5100)
78438c STOP
78439c ENDIF
78440
78441C...Format for error printout.
78442c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78443c &1X,'Execution stopped!')
78444c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78445c &1X,'Dummy routine in PYTHIA file called instead.'/
78446c &1X,'Execution stopped!')
78447
78448c RETURN
78449c END
78450
78451C*********************************************************************
78452
78453C...UPEVNT
78454C...Dummy routine, to be replaced by a user implementing external
78455C...processes. Depending on cross section model chosen, it either has
78456C...to generate a process of the type IDPRUP requested, or pick a type
78457C...itself and generate this event. The event is to be stored in the
78458C...HEPEUP commonblock, including (often) an event weight.
78459
78460C...New example: handles a standard Les Houches Events File.
78461
78462 SUBROUTINE UPEVNT
78463
78464C...Double precision and integer declarations.
78465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78466 IMPLICIT INTEGER(I-N)
78467
78468C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78469 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78470 SAVE /PYPARS/
78471
78472C...User process event common block.
78473 INTEGER MAXNUP
78474 PARAMETER (MAXNUP=500)
78475 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78476 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78477 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78478 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78479 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78480 SAVE /HEPEUP/
78481
78482C...Lines to read in assumed never longer than 200 characters.
78483 PARAMETER (MAXLEN=200)
78484 CHARACTER*(MAXLEN) STRING
78485
78486C...Format for reading lines.
78487 CHARACTER*6 STRFMT
78488 STRFMT='(A000)'
78489 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78490
78491C...Loop until finds line beginning with "<event>" or "<event ".
78492 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78493 IBEG=0
78494 110 IBEG=IBEG+1
78495C...Allow indentation.
78496 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78497 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78498 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78499
78500C...Read first line of event info.
78501 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78502 &AQEDUP,AQCDUP
78503
78504C...Read NUP subsequent lines with information on each particle.
78505 DO 120 I=1,NUP
78506 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78507 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78508 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78509 120 CONTINUE
78510 RETURN
78511
78512C...Error exit, typically when no more events.
78513 130 WRITE(*,*) ' Failed to read LHEF event information.'
78514 WRITE(*,*) ' Will assume end of file has been reached.'
78515 NUP=0
78516 MSTI(51)=1
78517
78518 RETURN
78519 END
78520
78521C...Old example: handles a simple Pythia 6.4 event file.
78522
78523c SUBROUTINE UPEVNT
78524
78525C...Double precision and integer declarations.
78526c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78527c IMPLICIT INTEGER(I-N)
78528
78529C...Commonblocks.
78530c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78531c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78532c SAVE /PYDAT1/,/PYPARS/
78533
78534C...User process event common block.
78535c INTEGER MAXNUP
78536c PARAMETER (MAXNUP=500)
78537c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78538c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78539c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78540c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78541c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78542c SAVE /HEPEUP/
78543
78544C...Read info from file.
78545c IF(MSTP(162).GT.0) THEN
78546c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78547c & AQEDUP,AQCDUP
78548c DO 100 I=1,NUP
78549c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78550c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78551c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78552c 100 CONTINUE
78553c RETURN
78554C...Special when reached end of file or other error.
78555c 110 NUP=0
78556
78557C...Else not implemented.
78558c ELSE
78559c WRITE(MSTU(11),5000)
78560c STOP
78561c ENDIF
78562
78563C...Format for error printout.
78564c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78565c &1X,'Dummy routine in PYTHIA file called instead.'/
78566c &1X,'Execution stopped!')
78567
78568c RETURN
78569c END
78570
78571C*********************************************************************
78572
78573C...UPVETO
78574C...Dummy routine, to be replaced by user, to veto event generation
78575C...on the parton level, after parton showers but before multiple
78576C...interactions, beam remnants and hadronization is added.
78577C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78578C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78579C...be undecayed at this stage; if decayed their decay products will
78580C...have been allowed to shower.
78581
78582C...All partons at the end of the shower phase are stored in the
78583C...HEPEVT commonblock. The interesting information is
78584C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78585C...IDHEP(I) = the particle ID code according to PDG conventions,
78586C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78587C...All ISTHEP entries are 1, while the rest is zeroed.
78588
78589C...The user decision is to be conveyed by the IVETO value.
78590C...IVETO = 0 : retain current event and generate in full;
78591C... = 1 : abort generation of current event and move to next.
78592
78593 SUBROUTINE UPVETO(IVETO)
78594
78595C...HEPEVT commonblock.
78596 PARAMETER (NMXHEP=4000)
78597 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78598 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78599 DOUBLE PRECISION PHEP,VHEP
78600 SAVE /HEPEVT/
78601
78602C...Next few lines allow you to see what info PYVETO extracted from
78603C...the full event record for the first two events.
78604C...Delete if you don't want it.
78605 DATA NLIST/0/
78606 SAVE NLIST
78607 IF(NLIST.LE.2) THEN
78608 WRITE(*,*) ' Full event record at time of UPVETO call:'
78609 CALL PYLIST(1)
78610 WRITE(*,*) ' Part of event record made available to UPVETO:'
78611 CALL PYLIST(5)
78612 NLIST=NLIST+1
78613 ENDIF
78614
78615C...Make decision here.
78616 IVETO = 0
78617
78618 RETURN
78619 END
78620
78621C*********************************************************************
78622C...SUGRA
78623C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78624
78625 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78626 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78627 IMPLICIT INTEGER(I-N)
78628 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78629 INTEGER IMODL
78630C...Commonblocks.
78631 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78632 SAVE /PYDAT1/
78633
78634C...Stop program if this routine is ever called.
78635 WRITE(MSTU(11),5000)
78636 CALL PYSTOP(110)
78637
78638C...Format for error printout.
78639 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78640 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78641 &1X,'Execution stopped!')
78642
78643 RETURN
78644 END
78645
78646C*********************************************************************
78647
78648C...VISAJE
78649C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78650
78651 FUNCTION VISAJE()
78652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78653 IMPLICIT INTEGER(I-N)
78654 CHARACTER*40 VISAJE
78655
78656C...Commonblocks.
78657 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78658 SAVE /PYDAT1/
78659
78660C...Assign default value.
78661 VISAJE='Undefined'
78662
78663C...Stop program if this routine is ever called.
78664 WRITE(MSTU(11),5000)
78665 CALL PYSTOP(110)
78666
78667C...Format for error printout.
78668 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78669 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78670 &1X,'Execution stopped!')
78671
78672 RETURN
78673 END
78674
78675C*********************************************************************
78676
78677C...SSMSSM
78678C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78679
78680 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78681 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78682 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78683 &IDUM1,IDUM2)
78684 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78685 IMPLICIT INTEGER(I-N)
78686 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78687 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78688 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78689C...Commonblocks.
78690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78691 SAVE /PYDAT1/
78692
78693C...Stop program if this routine is ever called.
78694 WRITE(MSTU(11),5000)
78695 CALL PYSTOP(110)
78696
78697C...Format for error printout.
78698 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78699 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78700 &1X,'Execution stopped!')
78701 RETURN
78702 END
78703
78704C*********************************************************************
78705
78706C...FHSETFLAGS
78707C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78708
78709 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78711 IMPLICIT INTEGER(I-N)
78712Cmssmpart = 4 # full MSSM [recommended]
78713Cfieldren = 0 # MSbar field ren. [strongly recommended]
78714Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78715Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78716Cp2approx = 0 # no approximation [recommended]
78717Clooplevel= 2 # include 2-loop corrections
78718Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78719Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78720
78721C...Commonblocks.
78722 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78723 SAVE /PYDAT1/
78724
78725C...Stop program if this routine is ever called.
78726 WRITE(MSTU(11),5000)
78727 CALL PYSTOP(103)
78728
78729C...Format for error printout.
78730 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78731 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78732 &1X,'Execution stopped!')
78733 RETURN
78734 END
78735
78736C*********************************************************************
78737
78738C...FHSETPARA
78739C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78740
78741 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78742 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78743 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78744 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78746 IMPLICIT INTEGER(I-N)
78747
78748 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78749 DOUBLE COMPLEX DMU,
78750 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78751 & DM1, DM2, DM3
78752
78753C...Commonblocks.
78754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78755 SAVE /PYDAT1/
78756
78757C...Stop program if this routine is ever called.
78758 WRITE(MSTU(11),5000)
78759 CALL PYSTOP(103)
78760
78761C...Format for error printout.
78762 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78763 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78764 &1X,'Execution stopped!')
78765 RETURN
78766 END
78767
78768C*********************************************************************
78769
78770C...FHHIGGSCORR
78771C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78772
78773 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78775 IMPLICIT INTEGER(I-N)
78776
78777C...FeynHiggs variables
78778 DOUBLE PRECISION RMHIGG(4)
78779 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78780 DOUBLE COMPLEX DMU,
78781 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78782 & DM1, DM2, DM3
78783
78784C...Commonblocks.
78785 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78786 SAVE /PYDAT1/
78787
78788C...Stop program if this routine is ever called.
78789 WRITE(MSTU(11),5000)
78790 CALL PYSTOP(103)
78791
78792C...Format for error printout.
78793 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78794 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78795 &1X,'Execution stopped!')
78796 RETURN
78797 END
78798
78799C*********************************************************************
78800
78801C...PYTAUD
78802C...Dummy routine, to be replaced by user, to handle the decay of a
78803C...polarized tau lepton.
78804C...Input:
78805C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78806C...IORIG is the position where the mother of the tau is stored;
78807C... is 0 when the mother is not stored.
78808C...KFORIG is the flavour of the mother of the tau;
78809C... is 0 when the mother is not known.
78810C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78811C... e.g. in B hadron semileptonic decays the W propagator
78812C... is not explicitly stored but the W code is still unambiguous.
78813C...Output:
78814C...NDECAY is the number of decay products in the current tau decay.
78815C...These decay products should be added to the /PYJETS/ common block,
78816C...in positions N+1 through N+NDECAY. For each product I you must
78817C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78818C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78819
78820 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78821
78822C...Double precision and integer declarations.
78823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78824 IMPLICIT INTEGER(I-N)
78825 INTEGER PYK,PYCHGE,PYCOMP
78826C...Commonblocks.
78827 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78829 SAVE /PYJETS/,/PYDAT1/
78830
78831C...Stop program if this routine is ever called.
78832C...You should not copy these lines to your own routine.
78833 NDECAY=ITAU+IORIG+KFORIG
78834 WRITE(MSTU(11),5000)
78835 CALL PYSTOP(10)
78836
78837C...Format for error printout.
78838 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78839 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78840 &1X,'Execution stopped!')
78841
78842 RETURN
78843 END
78844
78845C*********************************************************************
78846
78847C...PYTIME
78848C...Finds current date and time.
78849C...Since this task is not standardized in Fortran 77, the routine
78850C...is dummy, to be replaced by the user. Examples are given for
78851C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78852C...you do not have access to suitable routines.
78853
78854 SUBROUTINE PYTIME(IDATI)
78855
78856C...Double precision and integer declarations.
78857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78858 IMPLICIT INTEGER(I-N)
78859 INTEGER PYK,PYCHGE,PYCOMP
78860 CHARACTER*8 ATIME
78861C...Local array.
78862 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78863
78864C...Example 0: if you do not have suitable routines.
78865 DO 100 J=1,6
78866 IDATI(J)=0
78867 100 CONTINUE
78868
78869C...Example 1: Fortran 90 routine.
78870C CALL DATE_AND_TIME(VALUES=IVAL)
78871C IDATI(1)=IVAL(1)
78872C IDATI(2)=IVAL(2)
78873C IDATI(3)=IVAL(3)
78874C IDATI(4)=IVAL(5)
78875C IDATI(5)=IVAL(6)
78876C IDATI(6)=IVAL(7)
78877
78878C...Example 2: DEC Fortran 77. AIX.
78879C CALL IDATE(IMON,IDAY,IYEAR)
78880C IDATI(1)=IYEAR
78881C IDATI(2)=IMON
78882C IDATI(3)=IDAY
78883C CALL ITIME(IHOUR,IMIN,ISEC)
78884C IDATI(4)=IHOUR
78885C IDATI(5)=IMIN
78886C IDATI(6)=ISEC
78887
78888C...Example 3: DEC Fortran, IRIX, IRIX64.
78889C CALL IDATE(IMON,IDAY,IYEAR)
78890C IDATI(1)=IYEAR
78891C IDATI(2)=IMON
78892C IDATI(3)=IDAY
78893C CALL TIME(ATIME)
78894C IHOUR=0
78895C IMIN=0
78896C ISEC=0
78897C READ(ATIME(1:2),'(I2)') IHOUR
78898C READ(ATIME(4:5),'(I2)') IMIN
78899C READ(ATIME(7:8),'(I2)') ISEC
78900C IDATI(4)=IHOUR
78901C IDATI(5)=IMIN
78902C IDATI(6)=ISEC
78903
78904C...Example 4: GNU LINUX libU77, SunOS.
78905C CALL IDATE(IDTEMP)
78906C IDATI(1)=IDTEMP(3)
78907C IDATI(2)=IDTEMP(2)
78908C IDATI(3)=IDTEMP(1)
78909C CALL ITIME(IDTEMP)
78910C IDATI(4)=IDTEMP(1)
78911C IDATI(5)=IDTEMP(2)
78912C IDATI(6)=IDTEMP(3)
78913
78914C...Common code to ensure right century.
78915 IDATI(1)=2000+MOD(IDATI(1),100)
78916
78917 RETURN
78918 END
be4253b2 78919C... ALICE interface to PDFLIB with possibility to select nuclear structure
78920C... functions.
78921C...
78922C... The MSTP array in the PYPARS common block is used to enable and
78923C... select the nuclear structure functions.
78924C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78925C... =1: internal PYTHIA acording to MSTP(51)
78926C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78927C... MSTP( 51) = 1000xNPGROUP+NPSET
78928C... MSTP(151) = 1000xNAGROUP+NASET
78929C... MSTP(192) : Mass number of nucleus side 1
78930C... MSTP(193) : Mass number of nucleus side 2
78931C...
78932C...
78933C... MINT(124) : side (1 or 2)
78934
78935
78936 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78937C...
78938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78939 IMPLICIT INTEGER(I-N)
78940C...Interface to PDFLIB.
78941 COMMON/LW50512/QCDL4,QCDL5
78942 SAVE /LW50512/
78943 DOUBLE PRECISION QCDL4,QCDL5
78944 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
78945 SAVE /LW50513/
78946 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
78947C...
78948 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78949 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78950 DOUBLE PRECISION VALUE(20)
78951 CHARACTER*20 PARM(20)
78952 write(6,*) MSTP(52)
78953 write(6,*) PARM
78954 write(6,*) VALUE
78955
78956 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78957 PARM(5)='NATYPE'
78958 VALUE(5)=4
78959 PARM(6)='NAGROUP'
78960 VALUE(6)=MSTP(191)/1000
78961 PARM(7)='NASET'
78962 VALUE(7)=MOD(MSTP(191),1000)
78963 CALL PDFSET(PARM,VALUE,
78964 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78965 > QCDL4,QCDL5,
78966 > XMIN,XMAX,Q2MIN,Q2MAX)
78967 IF (MSTP(194) .EQ. 0) THEN
78968 CALL SETLHAPARM("EKS98")
78969 ELSE
78970 CALL SETLHAPARM("EPS08")
78971 ENDIF
78972 ELSE
78973 write(6,*) "-> pdfset"
78974 CALL PDFSET(PARM,VALUE,
78975 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
78976 > QCDL4,QCDL5,
78977 > XMIN,XMAX,Q2MIN,Q2MAX)
78978 ENDIF
78979 write(6,*) "done"
78980 END
78981
78982
78983
78984 SUBROUTINE STRUCTM_ALICE
78985 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78986C...
78987 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78988 IMPLICIT INTEGER(I-N)
78989 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78990 COMMON/PYINT1/MINT(400),VINT(400)
78991C write(6,*) "structm_alice->"
78992 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
78993 A=MSTP(191+MINT(124))
78994C write(6,*) mint(124), "-> structa ", A
78995 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78996 ELSE
78997C write(6,*) mint(124), "-> structm "
78998 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
78999 ENDIF
79000 END
79001