]> 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
EPS09 added.
[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
7a398e1e 3578
3579 DO 2 I = 1, 4000
3580 DO 1 J = 1, 5
3581 V(I,J) = 0.
3582 1 ENDDO
3583 2 ENDDO
02626a96 3584C...Initial values for some counters.
3585 MSTU(1)=0
3586 MSTU(2)=0
3587 N=0
3588 MINT(5)=MINT(5)+1
3589 MINT(7)=0
3590 MINT(8)=0
3591 MINT(30)=0
3592 MINT(83)=0
3593 MINT(84)=MSTP(126)
3594 MSTU(24)=0
3595 MSTU70=0
3596 MSTJ14=MSTJ(14)
3597C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3598 NCT=0
3599 MINT(33)=0
3600C...Zero counters for pT-ordered showers (failsafe)
3601 NPART=0
3602 NPARTD=0
3603
3604C...Let called routines know call is from PYEVNW (not PYEVNT).
3605 MINT(35)=3
3606
3607C...If variable energies: redo incoming kinematics and cross-section.
3608 MSTI(61)=0
3609 IF(MSTP(171).EQ.1) THEN
3610 CALL PYINKI(1)
3611 IF(MSTI(61).EQ.1) THEN
3612 MINT(5)=MINT(5)-1
3613 RETURN
3614 ENDIF
3615 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3616 CALL PYXTOT
3617 ENDIF
3618
3619C...Loop over number of pileup events; check space left.
3620 IF(MSTP(131).LE.0) THEN
3621 NPILE=1
3622 ELSE
3623 CALL PYPILE(2)
3624 NPILE=MINT(81)
3625 ENDIF
3626 DO 300 IPILE=1,NPILE
3627 IF(MINT(84)+100.GE.MSTU(4)) THEN
3628 CALL PYERRM(11,
3629 & '(PYEVNW:) no more space in PYJETS for pileup events')
3630 IF(MSTU(21).GE.1) GOTO 310
3631 ENDIF
3632 MINT(82)=IPILE
3633
3634C...Generate variables of hard scattering.
3635 MINT(51)=0
3636 MSTI(52)=0
3637 LOOPHS =0
3638 100 CONTINUE
3639 LOOPHS = LOOPHS + 1
3640 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3641 IF(LOOPHS.GE.10) THEN
3642 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3643 & //'multiple interactions. Returning.')
3644 MINT(51)=1
3645 RETURN
3646 ENDIF
3647 MINT(31)=0
3648 MINT(39)=0
3649 MINT(36)=0
3650 MINT(51)=0
3651 MINT(57)=0
3652 CALL PYRAND
3653 IF(MSTI(61).EQ.1) THEN
3654 MINT(5)=MINT(5)-1
3655 RETURN
3656 ENDIF
3657 IF(MINT(51).EQ.2) RETURN
3658 ISUB=MINT(1)
3659 IF(MSTP(111).EQ.-1) GOTO 290
3660
3661C...Loopback point if PYPREP fails, especially for junction topologies.
3662 NPREP=0
3663 MNT31S=MINT(31)
3664 110 NPREP=NPREP+1
3665 MINT(31)=MNT31S
3666
3667 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3668C...Hard scattering (including low-pT):
3669C...reconstruct kinematics and colour flow of hard scattering.
3670 MINT31=MINT(31)
3671 120 MINT(31)=MINT31
3672 MINT(51)=0
3673 CALL PYSCAT
3674 IF(MINT(51).EQ.1) GOTO 100
3675 NPARTD=N
3676 NFIN=N
3677
3678C...Intertwined initial state showers and multiple interactions.
3679C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3680C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3681 MSTP61=MSTP(61)
3682 IF (MINT(47).LT.2) MSTP(61)=0
3683 MSTP81=MSTP(81)
3684 IF (MINT(50).EQ.0) MSTP(81)=0
3685 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3686 & MINT(111).NE.12) THEN
3687C...Absolute max pT2 scale for evolution: phase space limit.
3688 PT2MXS=0.25D0*VINT(2)
3689C...Check if more constrained by ISR and MI max scales:
3690 PT2MXS=MIN(PT2MXS,MAX(VINT(56),VINT(62)))
3691C...Loopback point in case of failure in evolution.
3692 LOOP=0
3693 130 LOOP=LOOP+1
3694 MINT(51)=0
3695 IF(LOOP.GT.100) THEN
3696 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3697 & //'multiple interactions. Trying new point.')
3698 MINT(51)=1
3699 RETURN
3700 ENDIF
3701
3702C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3703C...once per event. (E.g. compute constants and save variables to be
3704C...restored later in case of failure.)
3705 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3706
3707C...Initialize interleaved MI/ISR/JI evolution.
3708C...PT2MAX: absolute upper limit for evolution - Initialization may
3709C... return a PT2MAX which is lower than this.
3710C...PT2MIN: absolute lower limit for evolution - Initialization may
3711C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3712 PT2MAX=PT2MXS
3713 PT2MIN=0D0
3714 CALL PYEVOL(0,PT2MAX,PT2MIN)
3715C...If failed to initialize evolution, generate a new hard process
3716 IF (MINT(51).EQ.1) GOTO 100
3717
3718C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3719C...In principle factorized, so can be stopped and restarted.
3720C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3721C PT2MED=MAX(10D0**2,PT2MIN)
3722C CALL PYEVOL(1,PT2MAX,PT2MED)
3723C IF (MINT(51).EQ.1) GOTO 160
3724C PT2MAX=PT2MED
3725 CALL PYEVOL(1,PT2MAX,PT2MIN)
3726C...If fatal error (e.g., massive hard-process initiator, but no available
3727C...phase space for creation), generate a new hard process
3728 IF (MINT(51).EQ.2) GOTO 100
3729C...If smaller error, just try running evolution again
3730 IF (MINT(51).EQ.1) GOTO 130
3731
3732C...Finalize interleaved MI/ISR/JI evolution.
3733 CALL PYEVOL(2,PT2MAX,PT2MIN)
3734 IF (MINT(51).EQ.1) GOTO 130
3735
3736 ENDIF
3737 MSTP(61)=MSTP61
3738 MSTP(81)=MSTP81
3739 IF(MINT(51).EQ.1) GOTO 100
3740C...(MINT(52) is actually obsolete in this routine. Set anyway
3741C...to ensure PYDOCU stable.)
3742 MINT(52)=N
3743 MINT(53)=N
3744
3745C...Beam remnants - new scheme.
3746 140 IF(MINT(50).EQ.1) THEN
3747 IF (ISUB.EQ.95) MINT(31)=1
3748
3749C...Beam remnant flavour and colour assignments - new scheme.
3750 CALL PYMIHK
3751 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3752 & GOTO 120
3753 IF(MINT(51).EQ.1) GOTO 100
3754
3755C...Primordial kT and beam remnant momentum sharing - new scheme.
3756 CALL PYMIRM
3757 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3758 & GOTO 120
3759 IF(MINT(51).EQ.1) GOTO 100
3760 IF (ISUB.EQ.95) MINT(31)=0
3761 ELSEIF(MINT(111).NE.12) THEN
3762C...Hadron remnants and primordial kT - old model.
3763C...Happens e.g. for direct photon on one side.
3764 IPU1=IMI(1,1,1)
3765 IPU2=IMI(2,1,1)
3766 CALL PYREMN(IPU1,IPU2)
3767 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3768 & 110
3769 IF(MINT(51).EQ.1) GOTO 100
3770C...PYREMN does not set colour tags for BRs, so needs to be done now.
3771 DO 160 I=MINT(53)+1,N
3772 DO 150 KCS=4,5
3773 IDA=MOD(K(I,KCS),MSTU(5))
3774 IF (IDA.NE.0) THEN
3775 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3776 ELSE
3777 MCT(I,KCS-3)=0
3778 ENDIF
3779 150 CONTINUE
3780 160 CONTINUE
3781C...Instruct PYPREP to use colour tags
3782 MINT(33)=1
3783
3784 DO 360 MQGST=1,2
3785 DO 350 I=MINT(84)+1,N
3786
3787C...Look for coloured string endpoint, or (later) leftover gluon.
3788 IF (K(I,1).NE.3) GOTO 350
3789 KC=PYCOMP(K(I,2))
3790 IF(KC.EQ.0) GOTO 350
3791 KQ=KCHG(KC,2)
3792 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3793
3794C... Pick up loose string end with no previous tag.
3795 KCS=4
3796 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3797 IF(MCT(I,KCS-3).NE.0) GOTO 350
3798
3799 CALL PYCTTR(I,KCS,I)
3800 IF(MINT(51).NE.0) RETURN
3801
3802 350 CONTINUE
3803 360 CONTINUE
3804C...Now delete any colour processing information if set (since partons
3805C...otherwise not FS showered!)
3806 DO 170 I=MINT(84)+1,N
3807 IF (I.LE.N) THEN
3808 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3809 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3810 ENDIF
3811 170 CONTINUE
3812 ENDIF
3813
3814C...Showering of final state partons (optional).
3815 ALAMSV=PARJ(81)
3816 PARJ(81)=PARP(72)
3817 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3818 & THEN
3819 QMAX=VINT(55)
3820 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3821 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3822C...External processes: handle successive showers.
3823 ELSEIF(ISET(ISUB).EQ.11) THEN
3824 CALL PYADSH(NFIN)
3825 ENDIF
3826 PARJ(81)=ALAMSV
3827
3828C...Allow possibility for user to abort event generation.
3829 IVETO=0
3830 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3831 IF(IVETO.EQ.1) THEN
3832C...........No reason to count this as an error
3833 LOOPHS = LOOPHS-1
3834 GOTO 100
3835 ENDIF
3836
3837
3838C...Decay of final state resonances.
3839 MINT(32)=0
3840 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3841 CALL PYRESD(0)
3842 IF(MINT(51).NE.0) GOTO 100
3843 ENDIF
3844
3845 IF(MINT(51).EQ.1) GOTO 100
3846
3847 ELSEIF(ISUB.NE.99) THEN
3848C...Diffractive and elastic scattering.
3849 CALL PYDIFF
3850
3851 ELSE
3852C...DIS scattering (photon flux external).
3853 CALL PYDISG
3854 IF(MINT(51).EQ.1) GOTO 100
3855 ENDIF
3856
3857C...Check that no odd resonance left undecayed.
3858 MINT(54)=N
3859 IF(MSTP(111).GE.1) THEN
3860 NFIX=N
3861 DO 180 I=MINT(84)+1,NFIX
3862 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3863 & K(I,2).NE.22) THEN
3864 KCA=PYCOMP(K(I,2))
3865 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3866 CALL PYRESD(I)
3867 IF(MINT(51).EQ.1) GOTO 100
3868 ENDIF
3869 ENDIF
3870 180 CONTINUE
3871 ENDIF
3872
3873C...Boost hadronic subsystem to overall rest frame.
3874C..(Only relevant when photon inside lepton beam.)
3875 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3876
3877C...Recalculate energies from momenta and masses (if desired).
3878 IF(MSTP(113).GE.1) THEN
3879 DO 190 I=MINT(83)+1,N
3880 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3881 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3882 190 CONTINUE
3883 NRECAL=N
3884 ENDIF
3885
3886C...Colour reconnection before string formation
3887 CALL PYFSCR(MINT(84)+1)
3888
3889C...Rearrange partons along strings, check invariant mass cuts.
3890 MSTU(28)=0
3891 IF(MSTP(111).LE.0) MSTJ(14)=-1
3892 CALL PYPREP(MINT(84)+1)
3893 MSTJ(14)=MSTJ14
3894 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3895 MSTU(24)=0
3896 GOTO 100
3897 ENDIF
3898 IF(MINT(51).EQ.1) GOTO 110
3899 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3900 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3901 DO 220 I=MINT(84)+1,N
3902 IF(K(I,2).EQ.94) THEN
3903 DO 210 I1=I+1,MIN(N,I+10)
3904 IF(K(I1,3).EQ.I) THEN
3905 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3906 IF(K(I1,3).EQ.0) THEN
3907 DO 200 II=MINT(84)+1,I-1
3908 IF(K(II,2).EQ.K(I1,2)) THEN
3909 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3910 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3911 ENDIF
3912 200 CONTINUE
3913 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3914 ENDIF
3915 ENDIF
3916 210 CONTINUE
3917CC...Also collapse particles decaying to themselves (if same KS)
3918 ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3919 & .AND.K(I,4).LT.N) THEN
3920 IDA=K(I,4)
3921 IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3922 K(I,1)=0
3923 ENDIF
3924 ENDIF
3925 220 CONTINUE
3926 CALL PYEDIT(12)
3927 CALL PYEDIT(14)
3928 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3929 IF(MSTP(125).EQ.0) MINT(4)=0
3930 DO 240 I=MINT(83)+1,N
3931 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3932 DO 230 I1=I+1,N
3933 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3934 IF(K(I1,3).EQ.I) K(I,5)=I1
3935 230 CONTINUE
3936 ENDIF
3937 240 CONTINUE
3938 ENDIF
3939
3940C...Introduce separators between sections in PYLIST event listing.
3941 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3942 MSTU70=1
3943 MSTU(71)=N
3944 ELSEIF(IPILE.EQ.1) THEN
3945 MSTU70=3
3946 MSTU(71)=2
3947 MSTU(72)=MINT(4)
3948 MSTU(73)=N
3949 ENDIF
3950
3951C...Go back to lab frame (needed for vertices, also in fragmentation).
3952 CALL PYFRAM(1)
3953
3954C...Set nonvanishing production vertex (optional).
3955 IF(MSTP(151).EQ.1) THEN
3956 DO 250 J=1,4
3957 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3958 & SIN(PARU(2)*PYR(0))
3959 250 CONTINUE
3960 DO 270 I=MINT(83)+1,N
3961 DO 260 J=1,4
3962 V(I,J)=V(I,J)+VTX(J)
3963 260 CONTINUE
3964 270 CONTINUE
3965 ENDIF
3966
3967C...Perform hadronization (if desired).
3968 IF(MSTP(111).GE.1) THEN
3969 CALL PYEXEC
3970 IF(MSTU(24).NE.0) GOTO 100
3971 ENDIF
3972 IF(MSTP(113).GE.1) THEN
3973 DO 280 I=NRECAL,N
3974 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3975 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3976 280 CONTINUE
3977 ENDIF
3978 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3979
3980C...Store event information and calculate Monte Carlo estimates of
3981C...subprocess cross-sections.
3982 290 IF(IPILE.EQ.1) CALL PYDOCU
3983
3984C...Set counters for current pileup event and loop to next one.
3985 MSTI(41)=IPILE
3986 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3987 IF(MSTU70.LT.10) THEN
3988 MSTU70=MSTU70+1
3989 MSTU(70+MSTU70)=N
3990 ENDIF
3991 MINT(83)=N
3992 MINT(84)=N+MSTP(126)
3993 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3994 300 CONTINUE
3995
3996C...Generic information on pileup events. Reconstruct missing history.
3997 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3998 PARI(91)=VINT(132)
3999 PARI(92)=VINT(133)
4000 PARI(93)=VINT(134)
4001 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4002 ENDIF
4003 CALL PYEDIT(16)
4004
4005C...Transform to the desired coordinate frame.
4006 310 CALL PYFRAM(MSTP(124))
4007 MSTU(70)=MSTU70
4008 PARU(21)=VINT(1)
4009
4010C...Error messages
4011 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4012 &1X,'Execution stopped.')
4013
4014 RETURN
4015 END
4016
4017
4018C***********************************************************************
4019
4020C...PYSTAT
4021C...Prints out information about cross-sections, decay widths, branching
4022C...ratios, kinematical limits, status codes and parameter values.
4023
4024 SUBROUTINE PYSTAT(MSTAT)
4025
4026C...Double precision and integer declarations.
4027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4028 IMPLICIT INTEGER(I-N)
4029 INTEGER PYK,PYCHGE,PYCOMP
4030C...Parameter statement to help give large particle numbers.
4031 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4032 &KEXCIT=4000000,KDIMEN=5000000)
4033 PARAMETER (EPS=1D-3)
4034C...Commonblocks.
4035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4037 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4038 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4039 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4040 COMMON/PYINT1/MINT(400),VINT(400)
4041 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4042 COMMON/PYINT4/MWID(500),WIDS(500,5)
4043 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4044 COMMON/PYINT6/PROC(0:500)
4045 CHARACTER PROC*28, CHTMP*16
4046 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4047 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4048 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4049 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4050C...Local arrays, character variables and data.
4051 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4052 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4053 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4054 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4055 CHARACTER*24 CHD0, CHDC(10)
4056 CHARACTER*6 DNAME(3)
4057 DATA PROGA/
4058 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4059 &'VMD/hadron * anomalous ','direct * direct ',
4060 &'direct * anomalous ','anomalous * anomalous '/
4061 DATA DISGA/'e * VMD','e * anomalous'/
4062 DATA PROGG9/
4063 &'direct * direct ','direct * VMD ',
4064 &'direct * anomalous ','VMD * direct ',
4065 &'VMD * VMD ','VMD * anomalous ',
4066 &'anomalous * direct ','anomalous * VMD ',
4067 &'anomalous * anomalous ','DIS * VMD ',
4068 &'DIS * anomalous ','VMD * DIS ',
4069 &'anomalous * DIS '/
4070 DATA PROGG4/
4071 &'direct * direct ','direct * resolved ',
4072 &'resolved * direct ','resolved * resolved '/
4073 DATA PROGG2/
4074 &'direct * hadron ','resolved * hadron '/
4075 DATA PROGP4/
4076 &'VMD * hadron ','direct * hadron ',
4077 &'anomalous * hadron ','DIS * hadron '/
4078 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4079 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4080 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4081 &' y*_small ',' eta*_large ',' eta*_small ',
4082 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4083 &' x_2 ',' x_F ',' cos(theta_hard) ',
4084 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4085 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4086 &' tau'' '/
4087 DATA DNAME /'q ','lepton','nu '/
4088
4089C...Cross-sections.
4090 IF(MSTAT.LE.1) THEN
4091 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4092 WRITE(MSTU(11),5000)
4093 WRITE(MSTU(11),5100)
4094 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4095 DO 100 I=1,500
4096 IF(MSUB(I).NE.1) GOTO 100
4097 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4098 100 CONTINUE
4099 IF(MINT(121).GT.1) THEN
4100 WRITE(MSTU(11),5300)
4101 DO 110 IGA=1,MINT(121)
4102 CALL PYSAVE(3,IGA)
4103 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4104 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4105 & XSEC(0,3)
4106 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4107 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4108 & XSEC(0,3)
4109 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4110 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4111 & XSEC(0,3)
4112 ELSEIF(MINT(121).EQ.4) THEN
4113 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4114 & XSEC(0,3)
4115 ELSEIF(MINT(121).EQ.2) THEN
4116 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4117 & XSEC(0,3)
4118 ELSE
4119 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4120 & XSEC(0,3)
4121 ENDIF
4122 110 CONTINUE
4123 CALL PYSAVE(5,0)
4124 ENDIF
4125 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4126 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4127
4128C...Decay widths and branching ratios.
4129 ELSEIF(MSTAT.EQ.2) THEN
4130 WRITE(MSTU(11),5500)
4131 WRITE(MSTU(11),5600)
4132 DO 140 KC=1,500
4133 KF=KCHG(KC,4)
4134 CALL PYNAME(KF,CHKF)
4135 IOFF=0
4136 IF(KC.LE.22) THEN
4137 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4138 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4139 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4140 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4141 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4142 ELSE
4143 IF(MWID(KC).LE.0) GOTO 140
4144 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4145 & KF/KSUSY1.EQ.2)) GOTO 140
4146 ENDIF
4147C...Off-shell branchings.
4148 IF(IOFF.EQ.1) THEN
4149 NGP=0
4150 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4151 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4152 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4153 DO 120 J=1,MDCY(KC,3)
4154 IDC=J+MDCY(KC,2)-1
4155 NGP1=0
4156 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4157 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4158 NGP2=0
4159 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4160 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4161 CALL PYNAME(KFDP(IDC,1),CHD1)
4162 CALL PYNAME(KFDP(IDC,2),CHD2)
4163 IF(KFDP(IDC,3).EQ.0) THEN
4164 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4165 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4166 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4167 ELSE
4168 CALL PYNAME(KFDP(IDC,3),CHD3)
4169 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4170 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4171 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4172 ENDIF
4173 120 CONTINUE
4174C...On-shell decays.
4175 ELSE
4176 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4177 BRFIN=1D0
4178 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4179 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4180 & STATE(MDCY(KC,1)),BRFIN
4181 DO 130 J=1,MDCY(KC,3)
4182 IDC=J+MDCY(KC,2)-1
4183 NGP1=0
4184 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4185 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4186 NGP2=0
4187 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4188 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4189 BRPRI=0D0
4190 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4191 BRFIN=0D0
4192 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4193 CALL PYNAME(KFDP(IDC,1),CHD1)
4194 CALL PYNAME(KFDP(IDC,2),CHD2)
4195 IF(KFDP(IDC,3).EQ.0) THEN
4196 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4197 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4198 & CHD2(1:10),WDTP(J),BRPRI,
4199 & STATE(MDME(IDC,1)),BRFIN
4200 ELSE
4201 CALL PYNAME(KFDP(IDC,3),CHD3)
4202 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4203 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4204 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4205 & STATE(MDME(IDC,1)),BRFIN
4206 ENDIF
4207 130 CONTINUE
4208 ENDIF
4209 140 CONTINUE
4210 WRITE(MSTU(11),6000)
4211
4212C...Allowed incoming partons/particles at hard interaction.
4213 ELSEIF(MSTAT.EQ.3) THEN
4214 WRITE(MSTU(11),6100)
4215 CALL PYNAME(MINT(11),CHAU)
4216 CHIN(1)=CHAU(1:12)
4217 CALL PYNAME(MINT(12),CHAU)
4218 CHIN(2)=CHAU(1:12)
4219 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4220 DO 150 I=-20,22
4221 IF(I.EQ.0) GOTO 150
4222 IA=IABS(I)
4223 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4224 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4225 CALL PYNAME(I,CHAU)
4226 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4227 & STATE(KFIN(2,I))
4228 150 CONTINUE
4229 WRITE(MSTU(11),6400)
4230
4231C...User-defined limits on kinematical variables.
4232 ELSEIF(MSTAT.EQ.4) THEN
4233 WRITE(MSTU(11),6500)
4234 WRITE(MSTU(11),6600)
4235 SHRMAX=CKIN(2)
4236 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4237 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4238 PTHMIN=MAX(CKIN(3),CKIN(5))
4239 PTHMAX=CKIN(4)
4240 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4241 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4242 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4243 DO 160 I=4,14
4244 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4245 160 CONTINUE
4246 SPRMAX=CKIN(32)
4247 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4248 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4249 WRITE(MSTU(11),7000)
4250
4251C...Status codes and parameter values.
4252 ELSEIF(MSTAT.EQ.5) THEN
4253 WRITE(MSTU(11),7100)
4254 WRITE(MSTU(11),7200)
4255 DO 170 I=1,100
4256 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4257 & PARP(100+I)
4258 170 CONTINUE
4259
4260C...List of all processes implemented in the program.
4261 ELSEIF(MSTAT.EQ.6) THEN
4262 WRITE(MSTU(11),7400)
4263 WRITE(MSTU(11),7500)
4264 DO 180 I=1,500
4265 IF(ISET(I).LT.0) GOTO 180
4266 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4267 180 CONTINUE
4268 WRITE(MSTU(11),7700)
4269
4270 ELSEIF(MSTAT.EQ.7) THEN
4271 WRITE (MSTU(11),8000)
4272 NMODES(0)=0
4273 NMODES(10)=0
4274 NMODES(9)=0
4275 DO 290 ILR=1,2
4276 DO 280 KFSM=1,16
4277 KFSUSY=ILR*KSUSY1+KFSM
4278 NRVDC=0
4279C...SDOWN DECAYS
4280 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4281 NRVDC=3
4282 DO 190 I=1,NRVDC
4283 PBRAT(I)=0D0
4284 NMODES(I)=0
4285 190 CONTINUE
4286 CALL PYNAME(KFSUSY,CHTMP)
4287 CHD0=CHTMP//' '
4288 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4289 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4290 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4291 KC=PYCOMP(KFSUSY)
4292 DO 200 J=1,MDCY(KC,3)
4293 IDC=J+MDCY(KC,2)-1
4294 ID1=IABS(KFDP(IDC,1))
4295 ID2=IABS(KFDP(IDC,2))
4296 IF (KFDP(IDC,3).EQ.0) THEN
4297 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4298 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4299 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4300 NMODES(1)=NMODES(1)+1
4301 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4302 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4303 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4304 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4305 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4306 NMODES(2)=NMODES(2)+1
4307 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4308 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4309 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4310 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4311 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4312 NMODES(3)=NMODES(3)+1
4313 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4314 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4315 ENDIF
4316 ENDIF
4317 200 CONTINUE
4318 ENDIF
4319C...SUP DECAYS
4320 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4321 NRVDC=2
4322 DO 210 I=1,NRVDC
4323 NMODES(I)=0
4324 PBRAT(I)=0D0
4325 210 CONTINUE
4326 CALL PYNAME(KFSUSY,CHTMP)
4327 CHD0=CHTMP//' '
4328 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4329 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4330 KC=PYCOMP(KFSUSY)
4331 DO 220 J=1,MDCY(KC,3)
4332 IDC=J+MDCY(KC,2)-1
4333 ID1=IABS(KFDP(IDC,1))
4334 ID2=IABS(KFDP(IDC,2))
4335 IF (KFDP(IDC,3).EQ.0) THEN
4336 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4337 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4338 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4339 NMODES(1)=NMODES(1)+1
4340 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4341 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4342 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4343 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4344 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4345 NMODES(2)=NMODES(2)+1
4346 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4347 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4348 ENDIF
4349 ENDIF
4350 220 CONTINUE
4351 ENDIF
4352C...SLEPTON DECAYS
4353 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4354 NRVDC=2
4355 DO 230 I=1,NRVDC
4356 PBRAT(I)=0D0
4357 NMODES(I)=0
4358 230 CONTINUE
4359 CALL PYNAME(KFSUSY,CHTMP)
4360 CHD0=CHTMP//' '
4361 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4362 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4363 KC=PYCOMP(KFSUSY)
4364 DO 240 J=1,MDCY(KC,3)
4365 IDC=J+MDCY(KC,2)-1
4366 ID1=IABS(KFDP(IDC,1))
4367 ID2=IABS(KFDP(IDC,2))
4368 IF (KFDP(IDC,3).EQ.0) THEN
4369 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4370 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4371 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4372 NMODES(1)=NMODES(1)+1
4373 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4374 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4375 ENDIF
4376 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4377 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4378 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4379 NMODES(2)=NMODES(2)+1
4380 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4381 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4382 ENDIF
4383 ENDIF
4384 240 CONTINUE
4385 ENDIF
4386C...SNEUTRINO DECAYS
4387 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4388 & THEN
4389 NRVDC=2
4390 DO 250 I=1,NRVDC
4391 PBRAT(I)=0D0
4392 NMODES(I)=0
4393 250 CONTINUE
4394 CALL PYNAME(KFSUSY,CHTMP)
4395 CHD0=CHTMP//' '
4396 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4397 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4398 KC=PYCOMP(KFSUSY)
4399 DO 260 J=1,MDCY(KC,3)
4400 IDC=J+MDCY(KC,2)-1
4401 ID1=IABS(KFDP(IDC,1))
4402 ID2=IABS(KFDP(IDC,2))
4403 IF (KFDP(IDC,3).EQ.0) THEN
4404 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4405 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4406 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4407 NMODES(1)=NMODES(1)+1
4408 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4409 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4410 ENDIF
4411 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4412 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4413 NMODES(2)=NMODES(2)+1
4414 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4415 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4416 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4417 ENDIF
4418 ENDIF
4419 260 CONTINUE
4420 ENDIF
4421 IF (NRVDC.NE.0) THEN
4422 DO 270 I=1,NRVDC
4423 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4424 NMODES(0)=NMODES(0)+NMODES(I)
4425 270 CONTINUE
4426 ENDIF
4427 280 CONTINUE
4428 290 CONTINUE
4429 DO 370 KFSM=21,37
4430 KFSUSY=KSUSY1+KFSM
4431 NRVDC=0
4432C...NEUTRALINO DECAYS
4433 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4434 NRVDC=4
4435 DO 300 I=1,NRVDC
4436 PBRAT(I)=0D0
4437 NMODES(I)=0
4438 300 CONTINUE
4439 CALL PYNAME(KFSUSY,CHTMP)
4440 CHD0=CHTMP//' '
4441 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4442 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4443 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4444 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4445 KC=PYCOMP(KFSUSY)
4446 DO 310 J=1,MDCY(KC,3)
4447 IDC=J+MDCY(KC,2)-1
4448 ID1=IABS(KFDP(IDC,1))
4449 ID2=IABS(KFDP(IDC,2))
4450 ID3=IABS(KFDP(IDC,3))
4451 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4452 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4453 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4454 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4455 NMODES(1)=NMODES(1)+1
4456 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4457 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4458 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4459 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4460 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4461 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4462 NMODES(2)=NMODES(2)+1
4463 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4464 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4465 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4466 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4467 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4468 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4469 NMODES(3)=NMODES(3)+1
4470 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4471 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4472 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4473 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4474 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4475 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4476 NMODES(4)=NMODES(4)+1
4477 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4478 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4479 ENDIF
4480 310 CONTINUE
4481 ENDIF
4482C...CHARGINO DECAYS
4483 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4484 NRVDC=5
4485 DO 320 I=1,NRVDC
4486 PBRAT(I)=0D0
4487 NMODES(I)=0
4488 320 CONTINUE
4489 CALL PYNAME(KFSUSY,CHTMP)
4490 CHD0=CHTMP//' '
4491 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4492 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4493 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4494 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4495 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4496 KC=PYCOMP(KFSUSY)
4497 DO 330 J=1,MDCY(KC,3)
4498 IDC=J+MDCY(KC,2)-1
4499 ID1=IABS(KFDP(IDC,1))
4500 ID2=IABS(KFDP(IDC,2))
4501 ID3=IABS(KFDP(IDC,3))
4502 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4503 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4504 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4505 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4506 NMODES(1)=NMODES(1)+1
4507 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4508 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4509 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4510 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4511 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4512 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4513 NMODES(1)=NMODES(1)+1
4514 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4515 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4516 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4517 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4518 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4519 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4520 NMODES(2)=NMODES(2)+1
4521 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4522 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4523 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4524 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4525 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4526 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4527 NMODES(3)=NMODES(3)+1
4528 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4529 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4530 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4531 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4532 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4533 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4534 NMODES(3)=NMODES(3)+1
4535 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4536 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4537 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4538 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4539 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4540 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4541 NMODES(4)=NMODES(4)+1
4542 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4543 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4544 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4545 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4546 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4547 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4548 NMODES(4)=NMODES(4)+1
4549 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4550 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4551 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4552 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4553 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4554 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4555 NMODES(5)=NMODES(5)+1
4556 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4557 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4558 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4559 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4560 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4561 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4562 NMODES(5)=NMODES(5)+1
4563 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4564 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4565 ENDIF
4566 330 CONTINUE
4567 ENDIF
4568C...GLUINO DECAYS
4569 IF (KFSM.EQ.21) THEN
4570 NRVDC=3
4571 DO 340 I=1,NRVDC
4572 PBRAT(I)=0D0
4573 NMODES(I)=0
4574 340 CONTINUE
4575 CALL PYNAME(KFSUSY,CHTMP)
4576 CHD0=CHTMP//' '
4577 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4578 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4579 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4580 KC=PYCOMP(KFSUSY)
4581 DO 350 J=1,MDCY(KC,3)
4582 IDC=J+MDCY(KC,2)-1
4583 ID1=IABS(KFDP(IDC,1))
4584 ID2=IABS(KFDP(IDC,2))
4585 ID3=IABS(KFDP(IDC,3))
4586 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4587 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4588 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4589 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4590 NMODES(1)=NMODES(1)+1
4591 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4592 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4593 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4594 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4595 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4596 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4597 NMODES(2)=NMODES(2)+1
4598 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4599 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4600 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4601 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4602 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4603 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4604 NMODES(3)=NMODES(3)+1
4605 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4606 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4607 ENDIF
4608 350 CONTINUE
4609 ENDIF
4610
4611 IF (NRVDC.NE.0) THEN
4612 DO 360 I=1,NRVDC
4613 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4614 NMODES(0)=NMODES(0)+NMODES(I)
4615 360 CONTINUE
4616 ENDIF
4617 370 CONTINUE
4618 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4619
4620 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4621 WRITE (MSTU(11),8500)
4622 DO 400 IRV=1,3
4623 DO 390 JRV=1,3
4624 DO 380 KRV=1,3
4625 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4626 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4627 380 CONTINUE
4628 390 CONTINUE
4629 400 CONTINUE
4630 WRITE (MSTU(11),8600)
4631 ENDIF
4632 ENDIF
4633
4634C...Formats for printouts.
4635 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4636 &'Events and Cross-sections',1X,9('*'))
4637 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4638 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4639 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4640 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4641 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4642 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4643 &'I',12X,'I')
4644 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4645 &D10.3,1X,'I')
4646 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4647 &1X,'I',34X,'I',28X,'I',12X,'I')
4648 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4649 &1X,'********* Total number of errors, excluding junctions =',
4650 &1X,I8,' *************'/
4651 &1X,'********* Total number of errors, including junctions =',
4652 &1X,I8,' *************'/
4653 &1X,'********* Total number of warnings = ',
4654 &1X,I8,' *************'/
4655 &1X,'********* Fraction of events that fail fragmentation ',
4656 &'cuts =',1X,F8.5,' *********'/)
4657 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4658 &'Ratios',1X,27('*'))
4659 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4660 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4661 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4662 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4663 &1X,98('='))
4664 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4665 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4666 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4667 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4668 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4669 &1P,D10.3,0P,1X,'I')
4670 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4671 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4672 &1P,D10.3,0P,1X,'I')
4673 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4674 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4675 &'Particles at Hard Interaction',1X,7('*'))
4676 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4677 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4678 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4679 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4680 &78('=')/1X,'I',38X,'I',37X,'I')
4681 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4682 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4683 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4684 &'Kinematical Variables',1X,12('*'))
4685 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4686 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4687 &16X,'I')
4688 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4689 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4690 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4691 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4692 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4693 &'Parameter Values',1X,12('*'))
4694 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4695 &'PARP(I)'/)
4696 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4697 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4698 &1X,13('*'))
4699 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4700 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4701 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4702 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4703 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4704 8000 FORMAT(1X/ 1X/
4705 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4706 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4707 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4708 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4709 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4710 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4711 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4712 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4713 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4714 & /1X,70('='))
4715 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4716 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4717 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4718 8500 FORMAT(1X/ 1X/
4719 & 1X,'R-Violating couplings',1X/ 1X /
4720 & 1X,55('=')/
4721 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4722 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4723 & ,'I',15X,'I',15X,'I',15X,'I')
4724 8600 FORMAT(1X,55('='))
4725 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4726 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4727
4728 RETURN
4729 END
4730
4731C*********************************************************************
4732
4733C...PYUPEV
4734C...Administers the hard-process generation required for output to the
4735C...Les Houches event record.
4736
4737 SUBROUTINE PYUPEV
4738
4739C...Double precision and integer declarations.
4740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4741 IMPLICIT INTEGER(I-N)
4742 INTEGER PYK,PYCHGE,PYCOMP
4743
4744C...Commonblocks.
4745 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4746 COMMON/PYCTAG/NCT,MCT(4000,2)
4747 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4748 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4749 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4750 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4751 COMMON/PYINT1/MINT(400),VINT(400)
4752 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4753 COMMON/PYINT4/MWID(500),WIDS(500,5)
4754 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4755 &/PYINT1/,/PYINT2/,/PYINT4/
4756
4757C...HEPEUP for output.
4758 INTEGER MAXNUP
4759 PARAMETER (MAXNUP=500)
4760 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4761 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4762 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4763 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4764 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4765 SAVE /HEPEUP/
4766
4767C...Stop if no subprocesses on.
4768 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4769 WRITE(MSTU(11),5100)
4770 STOP
4771 ENDIF
4772
4773C...Special flags for hard-process generation only.
4774 MSTP71=MSTP(71)
4775 MSTP(71)=0
4776 MST128=MSTP(128)
4777 MSTP(128)=1
4778
4779C...Initial values for some counters.
4780 N=0
4781 MINT(5)=MINT(5)+1
4782 MINT(7)=0
4783 MINT(8)=0
4784 MINT(30)=0
4785 MINT(83)=0
4786 MINT(84)=MSTP(126)
4787 MSTU(24)=0
4788 MSTU70=0
4789 MSTJ14=MSTJ(14)
4790C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4791 MINT(33)=0
4792
4793C...If variable energies: redo incoming kinematics and cross-section.
4794 MSTI(61)=0
4795 IF(MSTP(171).EQ.1) THEN
4796 CALL PYINKI(1)
4797 IF(MSTI(61).EQ.1) THEN
4798 MINT(5)=MINT(5)-1
4799 RETURN
4800 ENDIF
4801 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4802 CALL PYXTOT
4803 ENDIF
4804
4805C...Do not allow pileup events.
4806 MINT(82)=1
4807
4808C...Generate variables of hard scattering.
4809 MINT(51)=0
4810 MSTI(52)=0
4811 100 CONTINUE
4812 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4813 MINT(31)=0
4814 MINT(51)=0
4815 MINT(57)=0
4816 CALL PYRAND
4817 IF(MSTI(61).EQ.1) THEN
4818 MINT(5)=MINT(5)-1
4819 RETURN
4820 ENDIF
4821 IF(MINT(51).EQ.2) RETURN
4822 ISUB=MINT(1)
4823
4824 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4825C...Hard scattering (including low-pT):
4826C...reconstruct kinematics and colour flow of hard scattering.
4827 MINT31=MINT(31)
4828 110 MINT(31)=MINT31
4829 MINT(51)=0
4830 CALL PYSCAT
4831 IF(MINT(51).EQ.1) GOTO 100
4832 IPU1=MINT(84)+1
4833 IPU2=MINT(84)+2
4834
4835C...Decay of final state resonances.
4836 MINT(32)=0
4837 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4838 & CALL PYRESD(0)
4839 IF(MINT(51).EQ.1) GOTO 100
4840 MINT(52)=N
4841
4842C...Longitudinal boost of hard scattering.
4843 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4844 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4845
4846 ELSEIF(ISUB.NE.99) THEN
4847C...Diffractive and elastic scattering.
4848 CALL PYDIFF
4849
4850 ELSE
4851C...DIS scattering (photon flux external).
4852 CALL PYDISG
4853 IF(MINT(51).EQ.1) GOTO 100
4854 ENDIF
4855
4856C...Check that no odd resonance left undecayed.
4857 MINT(54)=N
4858 NFIX=N
4859 DO 120 I=MINT(84)+1,NFIX
4860 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4861 & K(I,2).NE.22) THEN
4862 KCA=PYCOMP(K(I,2))
4863 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4864 CALL PYRESD(I)
4865 IF(MINT(51).EQ.1) GOTO 100
4866 ENDIF
4867 ENDIF
4868 120 CONTINUE
4869
4870C...Boost hadronic subsystem to overall rest frame.
4871C..(Only relevant when photon inside lepton beam.)
4872 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4873
4874C...Store event information and calculate Monte Carlo estimates of
4875C...subprocess cross-sections.
4876 130 CALL PYDOCU
4877
4878C...Transform to the desired coordinate frame.
4879 140 CALL PYFRAM(MSTP(124))
4880 MSTU(70)=MSTU70
4881 PARU(21)=VINT(1)
4882
4883C...Restore special flags for hard-process generation only.
4884 MSTP(71)=MSTP71
4885 MSTP(128)=MST128
4886
4887C...Trace colour tags; convert to LHA style labels.
4888 NCT=100
4889 DO 150 I=MINT(84)+1,N
4890 MCT(I,1)=0
4891 MCT(I,2)=0
4892 150 CONTINUE
4893 DO 160 I=MINT(84)+1,N
4894 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4895 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4896 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4897 & THEN
4898 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4899 IDA=MOD(K(I,4),MSTU(5))
4900 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4901 & MCT(IMO,2).NE.0) THEN
4902 MCT(I,1)=MCT(IMO,2)
4903 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4904 & MCT(IMO,1).NE.0) THEN
4905 MCT(I,1)=MCT(IMO,1)
4906 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4907 & MCT(IDA,2).NE.0) THEN
4908 MCT(I,1)=MCT(IDA,2)
4909 ELSE
4910 NCT=NCT+1
4911 MCT(I,1)=NCT
4912 ENDIF
4913 ENDIF
4914 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4915 & THEN
4916 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4917 IDA=MOD(K(I,5),MSTU(5))
4918 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4919 & MCT(IMO,1).NE.0) THEN
4920 MCT(I,2)=MCT(IMO,1)
4921 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4922 & MCT(IMO,2).NE.0) THEN
4923 MCT(I,2)=MCT(IMO,2)
4924 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4925 & MCT(IDA,1).NE.0) THEN
4926 MCT(I,2)=MCT(IDA,1)
4927 ELSE
4928 NCT=NCT+1
4929 MCT(I,2)=NCT
4930 ENDIF
4931 ENDIF
4932 ENDIF
4933 160 CONTINUE
4934
4935C...Put event in HEPEUP commonblock.
4936 NUP=N-MINT(84)
4937 IDPRUP=MINT(1)
4938 XWGTUP=1D0
4939 SCALUP=VINT(53)
4940 AQEDUP=VINT(57)
4941 AQCDUP=VINT(58)
4942 DO 180 I=1,NUP
4943 IDUP(I)=K(I+MINT(84),2)
4944 IF(I.LE.2) THEN
4945 ISTUP(I)=-1
4946 MOTHUP(1,I)=0
4947 MOTHUP(2,I)=0
4948 ELSEIF(K(I+4,3).EQ.0) THEN
4949 ISTUP(I)=1
4950 MOTHUP(1,I)=1
4951 MOTHUP(2,I)=2
4952 ELSE
4953 ISTUP(I)=1
4954 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4955 MOTHUP(2,I)=0
4956 ENDIF
4957 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4958 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4959 ICOLUP(1,I)=MCT(I+MINT(84),1)
4960 ICOLUP(2,I)=MCT(I+MINT(84),2)
4961 DO 170 J=1,5
4962 PUP(J,I)=P(I+MINT(84),J)
4963 170 CONTINUE
4964 VTIMUP(I)=V(I,5)
4965 SPINUP(I)=9D0
4966 180 CONTINUE
4967
4968C...Optionally write out event to disk. Minimal size for time/spin fields.
4969 IF(MSTP(162).GT.0) THEN
4970 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4971 DO 190 I=1,NUP
4972 IF(VTIMUP(I).EQ.0D0) THEN
4973 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4974 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4975 & ' 0. 9.'
4976 ELSE
4977 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4978 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4979 & VTIMUP(I),' 9.'
4980 ENDIF
4981 190 CONTINUE
4982
4983C...Optional extra line with parton-density information.
4984 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4985 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4986 ENDIF
4987
4988C...Error messages and other print formats.
4989 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4990 &1X,'Execution stopped.')
4991 5200 FORMAT(1P,2I6,4E14.6)
4992 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4993 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4994 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
4995
4996 RETURN
4997 END
4998
4999C*********************************************************************
5000
5001C...PYUPIN
5002C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5003C...processes, and optionally stores that information on file.
5004
5005 SUBROUTINE PYUPIN
5006
5007C...Double precision and integer declarations.
5008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5009 IMPLICIT INTEGER(I-N)
5010
5011C...Commonblocks.
5012 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5013 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5014 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5015 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5016 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5017
5018C...User process initialization commonblock.
5019 INTEGER MAXPUP
5020 PARAMETER (MAXPUP=100)
5021 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5022 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5023 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5024 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5025 &LPRUP(MAXPUP)
5026 SAVE /HEPRUP/
5027
5028C...Store info on incoming beams.
5029 IDBMUP(1)=K(1,2)
5030 IDBMUP(2)=K(2,2)
5031 EBMUP(1)=P(1,4)
5032 EBMUP(2)=P(2,4)
5033 PDFGUP(1)=0
5034 PDFGUP(2)=0
5035 PDFSUP(1)=MSTP(51)
5036 PDFSUP(2)=MSTP(51)
5037
5038C...Event weighting strategy.
5039 IDWTUP=3
5040
5041C...Info on individual processes.
5042 NPRUP=0
5043 DO 100 ISUB=1,500
5044 IF(MSUB(ISUB).EQ.1) THEN
5045 NPRUP=NPRUP+1
5046 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5047 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5048 XMAXUP(NPRUP)=1D0
5049 LPRUP(NPRUP)=ISUB
5050 ENDIF
5051 100 CONTINUE
5052
5053C...Write info to file.
5054 IF(MSTP(161).GT.0) THEN
5055 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5056 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5057 DO 110 IPR=1,NPRUP
5058 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5059 & LPRUP(IPR)
5060 110 CONTINUE
5061 ENDIF
5062
5063C...Formats for printout.
5064 5100 FORMAT(1P,2I8,2E14.6,6I6)
5065 5200 FORMAT(1P,3E14.6,I6)
5066
5067 RETURN
5068 END
5069
5070
5071C*********************************************************************
5072
5073C...Combine the two old-style Pythia initialization and event files
5074C...into a single Les Houches Event File.
5075
5076 SUBROUTINE PYLHEF
5077
5078C...Double precision and integer declarations.
5079 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5080 IMPLICIT INTEGER(I-N)
5081
5082C...PYTHIA commonblock: only used to provide read/write units and version.
5083 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5084 SAVE /PYPARS/
5085
5086C...User process initialization commonblock.
5087 INTEGER MAXPUP
5088 PARAMETER (MAXPUP=100)
5089 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5090 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5091 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5092 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5093 &LPRUP(MAXPUP)
5094 SAVE /HEPRUP/
5095
5096C...User process event common block.
5097 INTEGER MAXNUP
5098 PARAMETER (MAXNUP=500)
5099 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5100 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5101 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5102 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5103 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5104 SAVE /HEPEUP/
5105
5106C...Lines to read in assumed never longer than 200 characters.
5107 PARAMETER (MAXLEN=200)
5108 CHARACTER*(MAXLEN) STRING
5109
5110C...Format for reading lines.
5111 CHARACTER*6 STRFMT
5112 STRFMT='(A000)'
5113 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5114
5115C...Rewind initialization and event files.
5116 REWIND MSTP(161)
5117 REWIND MSTP(162)
5118
5119C...Write header info.
5120 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5121 WRITE(MSTP(163),'(A)') '<!--'
5122 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5123 &MSTP(181),'.',MSTP(182)
5124 WRITE(MSTP(163),'(A)') '-->'
5125
5126C...Read first line of initialization info and get number of processes.
5127 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5128 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5129 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5130
5131C...Copy initialization lines, omitting trailing blanks.
5132C...Embed in <init> ... </init> block.
5133 WRITE(MSTP(163),'(A)') '<init>'
5134 DO 140 IPR=0,NPRUP
5135 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5136 LEN=MAXLEN+1
5137 120 LEN=LEN-1
5138 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5139 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5140 140 CONTINUE
5141 WRITE(MSTP(163),'(A)') '</init>'
5142
5143C...Begin event loop. Read first line of event info or already done.
5144 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5145 200 CONTINUE
5146
5147C...Look at first line to know number of particles in event.
5148 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5149
5150C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5151 WRITE(MSTP(163),'(A)') '<event>'
5152 DO 240 I=0,NUP
5153 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5154 LEN=MAXLEN+1
5155 220 LEN=LEN-1
5156 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5157 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5158 240 CONTINUE
5159
5160C...Copy trailing comment lines - with a # in the first column - as is.
5161 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5162 IF(STRING(1:1).EQ.'#') THEN
5163 LEN=MAXLEN+1
5164 280 LEN=LEN-1
5165 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5166 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5167 GOTO 260
5168 ENDIF
5169
5170C..End the <event> block. Loop back to look for next event.
5171 WRITE(MSTP(163),'(A)') '</event>'
5172 GOTO 200
5173
5174C...Successfully reached end of event loop: write closing tag
5175C...and remove temporary intermediate files (unless asked not to).
5176 300 WRITE(MSTP(163),'(A)') '</event>'
5177 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5178 IF(MSTP(164).EQ.1) RETURN
5179 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5180 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5181 RETURN
5182
5183C...Error exit.
5184 400 WRITE(*,*) ' PYLHEF file joining failed!'
5185
5186 RETURN
5187 END
5188
5189C*********************************************************************
5190
5191C...PYINRE
5192C...Calculates full and effective widths of gauge bosons, stores
5193C...masses and widths, rescales coefficients to be used for
5194C...resonance production generation.
5195
5196 SUBROUTINE PYINRE
5197
5198C...Double precision and integer declarations.
5199 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5200 IMPLICIT INTEGER(I-N)
5201 INTEGER PYK,PYCHGE,PYCOMP
5202C...Parameter statement to help give large particle numbers.
5203 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5204 &KEXCIT=4000000,KDIMEN=5000000)
5205C...Commonblocks.
5206 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5207 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5208 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5209 COMMON/PYDAT4/CHAF(500,2)
5210 CHARACTER CHAF*16
5211 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5212 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5213 COMMON/PYINT1/MINT(400),VINT(400)
5214 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5215 COMMON/PYINT4/MWID(500),WIDS(500,5)
5216 COMMON/PYINT6/PROC(0:500)
5217 CHARACTER PROC*28
5218 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5219 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5220 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5221C...Local arrays and data.
5222 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5223 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5224
5225C...Born level couplings in MSSM Higgs doublet sector.
5226 XW=PARU(102)
5227 XWV=XW
5228 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5229 XW1=1D0-XW
5230 IF(MSTP(4).EQ.2) THEN
5231 TANBE=PARU(141)
5232 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5233 SQMZ=PMAS(23,1)**2
5234 SQMW=PMAS(24,1)**2
5235 SQMH=PMAS(25,1)**2
5236 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5237 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5238 SQMHC=SQMA+SQMW
5239 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5240 WRITE(MSTU(11),5000)
5241 CALL PYSTOP(101)
5242 ENDIF
5243 PMAS(35,1)=SQRT(SQMHP)
5244 PMAS(36,1)=SQRT(SQMA)
5245 PMAS(37,1)=SQRT(SQMHC)
5246 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5247 & (SQMA-SQMZ)))
5248 BESU=ATAN(TANBE)
5249 PARU(142)=1D0
5250 PARU(143)=1D0
5251 PARU(161)=-SIN(ALSU)/COS(BESU)
5252 PARU(162)=COS(ALSU)/SIN(BESU)
5253 PARU(163)=PARU(161)
5254 PARU(164)=SIN(BESU-ALSU)
5255 PARU(165)=PARU(164)
5256 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5257 PARU(171)=COS(ALSU)/COS(BESU)
5258 PARU(172)=SIN(ALSU)/SIN(BESU)
5259 PARU(173)=PARU(171)
5260 PARU(174)=COS(BESU-ALSU)
5261 PARU(175)=PARU(174)
5262 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5263 & SIN(BESU+ALSU)
5264 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5265 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5266 PARU(181)=TANBE
5267 PARU(182)=1D0/TANBE
5268 PARU(183)=PARU(181)
5269 PARU(184)=0D0
5270 PARU(185)=PARU(184)
5271 PARU(186)=COS(BESU-ALSU)
5272 PARU(187)=SIN(BESU-ALSU)
5273 PARU(188)=PARU(186)
5274 PARU(189)=PARU(187)
5275 PARU(190)=0D0
5276 PARU(195)=COS(BESU-ALSU)
5277 ENDIF
5278
5279C...Reset effective widths of gauge bosons.
5280 DO 110 I=1,500
5281 DO 100 J=1,5
5282 WIDS(I,J)=1D0
5283 100 CONTINUE
5284 110 CONTINUE
5285
5286C...Order resonances by increasing mass (except Z0 and W+/-).
5287 NRES=0
5288 DO 140 KC=1,500
5289 KF=KCHG(KC,4)
5290 IF(KF.EQ.0) GOTO 140
5291 IF(MWID(KC).EQ.0) GOTO 140
5292 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5293 IF(MSTP(1).LE.3) GOTO 140
5294 ENDIF
5295 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5296 IF(IMSS(1).LE.0) GOTO 140
5297 ENDIF
5298 NRES=NRES+1
5299 PMRES=PMAS(KC,1)
5300 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5301 DO 120 I1=NRES-1,1,-1
5302 IF(PMRES.GE.PMORD(I1)) GOTO 130
5303 KCORD(I1+1)=KCORD(I1)
5304 PMORD(I1+1)=PMORD(I1)
5305 120 CONTINUE
5306 130 KCORD(I1+1)=KC
5307 PMORD(I1+1)=PMRES
5308 140 CONTINUE
5309
5310C...Loop over possible resonances.
5311 DO 180 I=1,NRES
5312 KC=KCORD(I)
5313 KF=KCHG(KC,4)
5314
5315C...Check that no fourth generation channels on by mistake.
5316 IF(MSTP(1).LE.3) THEN
5317 DO 150 J=1,MDCY(KC,3)
5318 IDC=J+MDCY(KC,2)-1
5319 KFA1=IABS(KFDP(IDC,1))
5320 KFA2=IABS(KFDP(IDC,2))
5321 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5322 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5323 & MDME(IDC,1)=-1
5324 150 CONTINUE
5325 ENDIF
5326
5327C...Check that no supersymmetric channels on by mistake.
5328 IF(IMSS(1).LE.0) THEN
5329 DO 160 J=1,MDCY(KC,3)
5330 IDC=J+MDCY(KC,2)-1
5331 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5332 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5333 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5334 & MDME(IDC,1)=-1
5335 160 CONTINUE
5336 ENDIF
5337
5338C...Find mass and evaluate width.
5339 PMR=PMAS(KC,1)
5340 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5341 IF(MWID(KC).EQ.3) MINT(63)=1
5342 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5343 MINT(51)=0
5344
5345C...Evaluate suppression factors due to non-simulated channels.
5346 IF(KCHG(KC,3).EQ.0) THEN
5347 WDTP0I=0D0
5348 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5349 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5350 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5351 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5352 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5353 WIDS(KC,3)=0D0
5354 WIDS(KC,4)=0D0
5355 WIDS(KC,5)=0D0
5356 ELSE
5357 IF(MWID(KC).EQ.3) MINT(63)=1
5358 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5359 MINT(51)=0
5360 WDTP0I=0D0
5361 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5362 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5363 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5364 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5365 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5366 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5367 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5368 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5369 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5370 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5371 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5372 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5373 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5374 ENDIF
5375
5376C...Set resonance widths and branching ratios;
5377C...also on/off switch for decays.
5378 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5379 PMAS(KC,2)=WDTP(0)
5380 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5381 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5382 DO 170 J=1,MDCY(KC,3)
5383 IDC=J+MDCY(KC,2)-1
5384 BRAT(IDC)=0D0
5385 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5386 170 CONTINUE
5387 ENDIF
5388 180 CONTINUE
5389
5390C...Flavours of leptoquark: redefine charge and name.
5391 KFLQQ=KFDP(MDCY(42,2),1)
5392 KFLQL=KFDP(MDCY(42,2),2)
5393 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5394 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5395 LL=1
5396 IF(IABS(KFLQL).EQ.13) LL=2
5397 IF(IABS(KFLQL).EQ.15) LL=3
5398 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5399 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5400 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5401
5402C...Special cases in treatment of gamma*/Z0: redefine process name.
5403 IF(MSTP(43).EQ.1) THEN
5404 PROC(1)='f + fbar -> gamma*'
5405 PROC(15)='f + fbar -> g + gamma*'
5406 PROC(19)='f + fbar -> gamma + gamma*'
5407 PROC(30)='f + g -> f + gamma*'
5408 PROC(35)='f + gamma -> f + gamma*'
5409 ELSEIF(MSTP(43).EQ.2) THEN
5410 PROC(1)='f + fbar -> Z0'
5411 PROC(15)='f + fbar -> g + Z0'
5412 PROC(19)='f + fbar -> gamma + Z0'
5413 PROC(30)='f + g -> f + Z0'
5414 PROC(35)='f + gamma -> f + Z0'
5415 ELSEIF(MSTP(43).EQ.3) THEN
5416 PROC(1)='f + fbar -> gamma*/Z0'
5417 PROC(15)='f + fbar -> g + gamma*/Z0'
5418 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5419 PROC(30)='f + g -> f + gamma*/Z0'
5420 PROC(35)='f + gamma -> f + gamma*/Z0'
5421 ENDIF
5422
5423C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5424 IF(MSTP(44).EQ.1) THEN
5425 PROC(141)='f + fbar -> gamma*'
5426 ELSEIF(MSTP(44).EQ.2) THEN
5427 PROC(141)='f + fbar -> Z0'
5428 ELSEIF(MSTP(44).EQ.3) THEN
5429 PROC(141)='f + fbar -> Z''0'
5430 ELSEIF(MSTP(44).EQ.4) THEN
5431 PROC(141)='f + fbar -> gamma*/Z0'
5432 ELSEIF(MSTP(44).EQ.5) THEN
5433 PROC(141)='f + fbar -> gamma*/Z''0'
5434 ELSEIF(MSTP(44).EQ.6) THEN
5435 PROC(141)='f + fbar -> Z0/Z''0'
5436 ELSEIF(MSTP(44).EQ.7) THEN
5437 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5438 ENDIF
5439
5440C...Special cases in treatment of WW -> WW: redefine process name.
5441 IF(MSTP(45).EQ.1) THEN
5442 PROC(77)='W+ + W+ -> W+ + W+'
5443 ELSEIF(MSTP(45).EQ.2) THEN
5444 PROC(77)='W+ + W- -> W+ + W-'
5445 ELSEIF(MSTP(45).EQ.3) THEN
5446 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5447 ENDIF
5448
5449C...Format for error information.
5450 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5451 &'combination'/1X,'Execution stopped!')
5452
5453 RETURN
5454 END
5455
5456C*********************************************************************
5457
5458C...PYINBM
5459C...Identifies the two incoming particles and the choice of frame.
5460
5461 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5462
5463C...Double precision and integer declarations.
5464 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5465 IMPLICIT INTEGER(I-N)
5466 INTEGER PYK,PYCHGE,PYCOMP
5467
5468C...User process initialization commonblock.
5469 INTEGER MAXPUP
5470 PARAMETER (MAXPUP=100)
5471 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5472 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5473 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5474 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5475 &LPRUP(MAXPUP)
5476 SAVE /HEPRUP/
5477
5478C...Commonblocks.
5479 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5480 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5481 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5482 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5483 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5484 COMMON/PYINT1/MINT(400),VINT(400)
5485 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5486
5487C...Local arrays, character variables and data.
5488 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5489 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5490 DIMENSION LEN(3),KCDE(39),PM(2)
5491 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5492 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5493 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5494 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5495 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5496 &'nu_taubar ','pi+ ','pi- ','n0 ',
5497 &'nbar0 ','p+ ','pbar- ','gamma ',
5498 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5499 &'xi- ','xi0 ','omega- ','pi0 ',
5500 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5501 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5502 &'k+ ','k- ','ks0 ','kl0 '/
5503 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5504 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5505 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5506
5507C...Store initial energy. Default frame.
5508 VINT(290)=WIN
5509 MINT(111)=0
5510
5511C...Special user process initialization; convert to normal input.
5512 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5513 MINT(111)=11
5514 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5515 CALL PYNAME(IDBMUP(1),CHNAME)
5516 CHBEAM=CHNAME(1:12)
5517 CALL PYNAME(IDBMUP(2),CHNAME)
5518 CHTARG=CHNAME(1:12)
5519 ENDIF
5520
5521C...Convert character variables to lowercase and find their length.
5522 CHCOM(1)=CHFRAM
5523 CHCOM(2)=CHBEAM
5524 CHCOM(3)=CHTARG
5525 DO 130 I=1,3
5526 LEN(I)=12
5527 DO 110 LL=12,1,-1
5528 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5529 DO 100 LA=1,26
5530 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5531 & CHALP(1)(LA:LA)
5532 100 CONTINUE
5533 110 CONTINUE
5534 CHIDNT(I)=CHCOM(I)
5535
5536C...Fix up bar, underscore and charge in particle name (if needed).
5537 DO 120 LL=1,10
5538 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5539 CHTEMP=CHIDNT(I)
5540 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5541 ENDIF
5542 120 CONTINUE
5543 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5544 CHTEMP=CHIDNT(I)
5545 CHIDNT(I)='nu_'//CHTEMP(3:7)
5546 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5547 CHIDNT(I)(1:3)='n0 '
5548 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5549 CHIDNT(I)(1:5)='nbar0'
5550 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5551 CHIDNT(I)(1:3)='p+ '
5552 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5553 & CHIDNT(I)(1:2).EQ.'p-') THEN
5554 CHIDNT(I)(1:5)='pbar-'
5555 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5556 CHIDNT(I)(7:7)='0'
5557 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5558 CHIDNT(I)(1:7)='reggeon'
5559 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5560 CHIDNT(I)(1:7)='pomeron'
5561 ENDIF
5562 130 CONTINUE
5563
5564C...Identify free initialization.
5565 IF(CHCOM(1)(1:2).EQ.'no') THEN
5566 MINT(65)=1
5567 RETURN
5568 ENDIF
5569
5570C...Identify incoming beam and target particles.
5571 DO 160 I=1,2
5572 DO 140 J=1,39
5573 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5574 140 CONTINUE
5575 PM(I)=PYMASS(MINT(10+I))
5576 VINT(2+I)=PM(I)
5577 MINT(140+I)=0
5578 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5579 CHTEMP=CHIDNT(I+1)(7:12)//' '
5580 DO 150 J=1,12
5581 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5582 150 CONTINUE
5583 PM(I)=PYMASS(MINT(140+I))
5584 VINT(302+I)=PM(I)
5585 ENDIF
5586 160 CONTINUE
5587 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5588 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5589 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5590
5591C...Identify choice of frame and input energies.
5592 CHINIT=' '
5593
5594C...Events defined in the CM frame.
5595 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5596 MINT(111)=1
5597 S=WIN**2
5598 IF(MSTP(122).GE.1) THEN
5599 IF(CHCOM(2)(1:1).NE.'e') THEN
5600 LOFFS=(31-(LEN(2)+LEN(3)))/2
5601 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5602 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5603 & ' collider'//' '
5604 ELSE
5605 LOFFS=(30-(LEN(2)+LEN(3)))/2
5606 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5607 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5608 & ' collider'//' '
5609 ENDIF
5610 WRITE(MSTU(11),5200) CHINIT
5611 WRITE(MSTU(11),5300) WIN
5612 ENDIF
5613
5614C...Events defined in fixed target frame.
5615 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5616 MINT(111)=2
5617 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5618 IF(MSTP(122).GE.1) THEN
5619 LOFFS=(29-(LEN(2)+LEN(3)))/2
5620 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5621 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5622 & ' fixed target'//' '
5623 WRITE(MSTU(11),5200) CHINIT
5624 WRITE(MSTU(11),5400) WIN
5625 WRITE(MSTU(11),5500) SQRT(S)
5626 ENDIF
5627
5628C...Frame defined by user three-vectors.
5629 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5630 MINT(111)=3
5631 P(1,5)=PM(1)
5632 P(2,5)=PM(2)
5633 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5634 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5635 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5636 & (P(1,3)+P(2,3))**2
5637 IF(MSTP(122).GE.1) THEN
5638 LOFFS=(22-(LEN(2)+LEN(3)))/2
5639 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5640 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5641 & ' user configuration'//' '
5642 WRITE(MSTU(11),5200) CHINIT
5643 WRITE(MSTU(11),5600)
5644 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5645 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5646 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5647 ENDIF
5648
5649C...Frame defined by user four-vectors.
5650 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5651 MINT(111)=4
5652 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5653 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5654 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5655 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5656 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5657 & (P(1,3)+P(2,3))**2
5658 IF(MSTP(122).GE.1) THEN
5659 LOFFS=(22-(LEN(2)+LEN(3)))/2
5660 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5661 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5662 & ' user configuration'//' '
5663 WRITE(MSTU(11),5200) CHINIT
5664 WRITE(MSTU(11),5600)
5665 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5666 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5667 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5668 ENDIF
5669
5670C...Frame defined by user five-vectors.
5671 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5672 MINT(111)=5
5673 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5674 & (P(1,3)+P(2,3))**2
5675 IF(MSTP(122).GE.1) THEN
5676 LOFFS=(22-(LEN(2)+LEN(3)))/2
5677 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5678 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5679 & ' user configuration'//' '
5680 WRITE(MSTU(11),5200) CHINIT
5681 WRITE(MSTU(11),5600)
5682 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5683 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5684 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5685 ENDIF
5686
5687C...Frame defined by HEPRUP common block.
5688 ELSEIF(MINT(111).GE.11) THEN
5689 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5690 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5691 IF(MSTP(122).GE.1) THEN
5692 LOFFS=(22-(LEN(2)+LEN(3)))/2
5693 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5694 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5695 & ' user configuration'//' '
5696 WRITE(MSTU(11),5200) CHINIT
5697 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5698 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5699 ENDIF
5700
5701C...Unknown frame. Error for too low CM energy.
5702 ELSE
5703 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5704 CALL PYSTOP(7)
5705 ENDIF
5706 IF(S.LT.PARP(2)**2) THEN
5707 WRITE(MSTU(11),5900) SQRT(S)
5708 CALL PYSTOP(7)
5709 ENDIF
5710
5711C...Formats for initialization and error information.
5712 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5713 &1X,'Execution stopped!')
5714 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5715 &1X,'Execution stopped!')
5716 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5717 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5718 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5719 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5720 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5721 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5722 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5723 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5724 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5725 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5726 &1X,'Execution stopped!')
5727 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5728 &'generation.'/1X,'Execution stopped!')
5729 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5730 &'GeV beam energies',13X,'I')
5731
5732 RETURN
5733 END
5734
5735C*********************************************************************
5736
5737C...PYINKI
5738C...Sets up kinematics, including rotations and boosts to/from CM frame.
5739
5740 SUBROUTINE PYINKI(MODKI)
5741
5742C...Double precision and integer declarations.
5743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5744 IMPLICIT INTEGER(I-N)
5745 INTEGER PYK,PYCHGE,PYCOMP
5746
5747C...User process initialization commonblock.
5748 INTEGER MAXPUP
5749 PARAMETER (MAXPUP=100)
5750 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5751 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5752 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5753 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5754 &LPRUP(MAXPUP)
5755 SAVE /HEPRUP/
5756
5757C...Commonblocks.
5758 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5761 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5762 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5763 COMMON/PYINT1/MINT(400),VINT(400)
5764 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5765
5766C...Set initial flavour state.
5767 N=2
5768 DO 100 I=1,2
5769 K(I,1)=1
5770 K(I,2)=MINT(10+I)
5771 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5772 100 CONTINUE
5773
5774C...Reset boost. Do kinematics for various cases.
5775 DO 110 J=6,10
5776 VINT(J)=0D0
5777 110 CONTINUE
5778
5779C...Set up kinematics for events defined in CM frame.
5780 IF(MINT(111).EQ.1) THEN
5781 WIN=VINT(290)
5782 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5783 S=WIN**2
5784 P(1,5)=VINT(3)
5785 P(2,5)=VINT(4)
5786 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5787 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5788 P(1,1)=0D0
5789 P(1,2)=0D0
5790 P(2,1)=0D0
5791 P(2,2)=0D0
5792 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5793 & (4D0*S))
5794 P(2,3)=-P(1,3)
5795 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5796 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5797
5798C...Set up kinematics for fixed target events.
5799 ELSEIF(MINT(111).EQ.2) THEN
5800 WIN=VINT(290)
5801 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5802 P(1,5)=VINT(3)
5803 P(2,5)=VINT(4)
5804 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5805 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5806 P(1,1)=0D0
5807 P(1,2)=0D0
5808 P(2,1)=0D0
5809 P(2,2)=0D0
5810 P(1,3)=WIN
5811 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5812 P(2,3)=0D0
5813 P(2,4)=P(2,5)
5814 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5815 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5816 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5817
5818C...Set up kinematics for events in user-defined frame.
5819 ELSEIF(MINT(111).EQ.3) THEN
5820 P(1,5)=VINT(3)
5821 P(2,5)=VINT(4)
5822 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5823 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5824 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5825 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5826 DO 120 J=1,3
5827 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5828 120 CONTINUE
5829 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5830 VINT(7)=PYANGL(P(1,1),P(1,2))
5831 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5832 VINT(6)=PYANGL(P(1,3),P(1,1))
5833 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5834 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5835
5836C...Set up kinematics for events with user-defined four-vectors.
5837 ELSEIF(MINT(111).EQ.4) THEN
5838 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5839 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5840 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5841 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5842 DO 130 J=1,3
5843 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5844 130 CONTINUE
5845 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5846 VINT(7)=PYANGL(P(1,1),P(1,2))
5847 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5848 VINT(6)=PYANGL(P(1,3),P(1,1))
5849 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5850 S=(P(1,4)+P(2,4))**2
5851
5852C...Set up kinematics for events with user-defined five-vectors.
5853 ELSEIF(MINT(111).EQ.5) THEN
5854 DO 140 J=1,3
5855 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5856 140 CONTINUE
5857 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5858 VINT(7)=PYANGL(P(1,1),P(1,2))
5859 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5860 VINT(6)=PYANGL(P(1,3),P(1,1))
5861 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5862 S=(P(1,4)+P(2,4))**2
5863
5864C...Set up kinematics for events with external user processes.
5865 ELSEIF(MINT(111).GE.11) THEN
5866 P(1,5)=VINT(3)
5867 P(2,5)=VINT(4)
5868 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5869 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5870 P(1,1)=0D0
5871 P(1,2)=0D0
5872 P(2,1)=0D0
5873 P(2,2)=0D0
5874 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5875 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5876 P(1,4)=EBMUP(1)
5877 P(2,4)=EBMUP(2)
5878 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5879 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5880 S=(P(1,4)+P(2,4))**2
5881 ENDIF
5882
5883C...Return or error for too low CM energy.
5884 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5885 IF(MSTP(172).LE.1) THEN
5886 CALL PYERRM(23,
5887 & '(PYINKI:) too low invariant mass in this event')
5888 ELSE
5889 MSTI(61)=1
5890 RETURN
5891 ENDIF
5892 ENDIF
5893
5894C...Save information on incoming particles.
5895 VINT(1)=SQRT(S)
5896 VINT(2)=S
5897 IF(MINT(111).GE.4) THEN
5898 IF(MINT(141).EQ.0) THEN
5899 VINT(3)=P(1,5)
5900 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5901 ELSE
5902 VINT(303)=P(1,5)
5903 ENDIF
5904 IF(MINT(142).EQ.0) THEN
5905 VINT(4)=P(2,5)
5906 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5907 ELSE
5908 VINT(304)=P(2,5)
5909 ENDIF
5910 ENDIF
5911 VINT(5)=P(1,3)
5912 IF(MODKI.EQ.0) VINT(289)=S
5913 DO 150 J=1,5
5914 V(1,J)=0D0
5915 V(2,J)=0D0
5916 VINT(290+J)=P(1,J)
5917 VINT(295+J)=P(2,J)
5918 150 CONTINUE
5919
5920C...Store pT cut-off and related constants to be used in generation.
5921 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5922 IF(MSTP(82).LE.1) THEN
5923 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5924 ELSE
5925 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5926 ENDIF
5927 VINT(149)=4D0*PTMN**2/S
5928 VINT(154)=PTMN
5929
5930 RETURN
5931 END
5932
5933C*********************************************************************
5934
5935C...PYINPR
5936C...Selects partonic subprocesses to be included in the simulation.
5937
5938 SUBROUTINE PYINPR
5939
5940C...Double precision and integer declarations.
5941 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5942 IMPLICIT INTEGER(I-N)
5943 INTEGER PYK,PYCHGE,PYCOMP
5944
5945C...User process initialization commonblock.
5946 INTEGER MAXPUP
5947 PARAMETER (MAXPUP=100)
5948 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5949 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5950 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5951 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5952 &LPRUP(MAXPUP)
5953 SAVE /HEPRUP/
5954
5955C...Commonblocks and character variables.
5956 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5957 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5958 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5959 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5960 COMMON/PYINT1/MINT(400),VINT(400)
5961 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5962 COMMON/PYINT6/PROC(0:500)
5963 CHARACTER PROC*28
5964 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
5965 &/PYINT6/
5966 CHARACTER CHIPR*10
5967
5968C...Reset processes to be included.
5969 IF(MSEL.NE.0) THEN
5970 DO 100 I=1,500
5971 MSUB(I)=0
5972 100 CONTINUE
5973 ENDIF
5974
5975C...Set running pTmin scale.
5976 IF(MSTP(82).LE.1) THEN
5977 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5978 ELSE
5979 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5980 ENDIF
5981
5982C...Begin by assuming incoming photon to enter subprocess.
5983 IF(MINT(11).EQ.22) MINT(15)=22
5984 IF(MINT(12).EQ.22) MINT(16)=22
5985
5986C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
5987 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
5988 MSUB(10)=1
5989 MINT(123)=MINT(122)+1
5990
5991C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
5992C...allow mixture.
5993C...Here also set a few parameters otherwise normally not touched.
5994 ELSEIF(MINT(121).GT.1) THEN
5995
5996C...Parton distributions dampened at small Q2; go to low energies,
5997C...alpha_s <1; no minimum pT cut-off a priori.
5998 IF(MSTP(18).EQ.2) THEN
5999 MSTP(57)=3
6000 PARP(2)=2D0
6001 PARU(115)=1D0
6002 CKIN(5)=0.2D0
6003 CKIN(6)=0.2D0
6004 ENDIF
6005
6006C...Define pT cut-off parameters and whether run involves low-pT.
6007 PTMVMD=PTMRUN
6008 VINT(154)=PTMVMD
6009 PTMDIR=PTMVMD
6010 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6011 PTMANO=PTMVMD
6012 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6013 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6014 IPTL=1
6015 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6016 IF(MSEL.EQ.2) IPTL=1
6017
6018C...Set up for p/gamma * gamma; real or virtual photons.
6019 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6020 & MSTP(14).EQ.30)) THEN
6021
6022C...Set up for p/VMD * VMD.
6023 IF(MINT(122).EQ.1) THEN
6024 MINT(123)=2
6025 MSUB(11)=1
6026 MSUB(12)=1
6027 MSUB(13)=1
6028 MSUB(28)=1
6029 MSUB(53)=1
6030 MSUB(68)=1
6031 IF(IPTL.EQ.1) MSUB(95)=1
6032 IF(MSEL.EQ.2) THEN
6033 MSUB(91)=1
6034 MSUB(92)=1
6035 MSUB(93)=1
6036 MSUB(94)=1
6037 ENDIF
6038 IF(IPTL.EQ.1) CKIN(3)=0D0
6039
6040C...Set up for p/VMD * direct gamma.
6041 ELSEIF(MINT(122).EQ.2) THEN
6042 MINT(123)=0
6043 IF(MINT(121).EQ.6) MINT(123)=5
6044 MSUB(131)=1
6045 MSUB(132)=1
6046 MSUB(135)=1
6047 MSUB(136)=1
6048 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6049
6050C...Set up for p/VMD * anomalous gamma.
6051 ELSEIF(MINT(122).EQ.3) THEN
6052 MINT(123)=3
6053 IF(MINT(121).EQ.6) MINT(123)=7
6054 MSUB(11)=1
6055 MSUB(12)=1
6056 MSUB(13)=1
6057 MSUB(28)=1
6058 MSUB(53)=1
6059 MSUB(68)=1
6060 IF(IPTL.EQ.1) MSUB(95)=1
6061 IF(MSEL.EQ.2) THEN
6062 MSUB(91)=1
6063 MSUB(92)=1
6064 MSUB(93)=1
6065 MSUB(94)=1
6066 ENDIF
6067 IF(IPTL.EQ.1) CKIN(3)=0D0
6068
6069C...Set up for DIS * p.
6070 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6071 & IABS(MINT(12)).GT.100)) THEN
6072 MINT(123)=8
6073 IF(IPTL.EQ.1) MSUB(99)=1
6074
6075C...Set up for direct * direct gamma (switch off leptons).
6076 ELSEIF(MINT(122).EQ.4) THEN
6077 MINT(123)=0
6078 MSUB(137)=1
6079 MSUB(138)=1
6080 MSUB(139)=1
6081 MSUB(140)=1
6082 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6083 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6084 110 CONTINUE
6085 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6086
6087C...Set up for direct * anomalous gamma.
6088 ELSEIF(MINT(122).EQ.5) THEN
6089 MINT(123)=6
6090 MSUB(131)=1
6091 MSUB(132)=1
6092 MSUB(135)=1
6093 MSUB(136)=1
6094 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6095
6096C...Set up for anomalous * anomalous gamma.
6097 ELSEIF(MINT(122).EQ.6) THEN
6098 MINT(123)=3
6099 MSUB(11)=1
6100 MSUB(12)=1
6101 MSUB(13)=1
6102 MSUB(28)=1
6103 MSUB(53)=1
6104 MSUB(68)=1
6105 IF(IPTL.EQ.1) MSUB(95)=1
6106 IF(MSEL.EQ.2) THEN
6107 MSUB(91)=1
6108 MSUB(92)=1
6109 MSUB(93)=1
6110 MSUB(94)=1
6111 ENDIF
6112 IF(IPTL.EQ.1) CKIN(3)=0D0
6113 ENDIF
6114
6115C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6116 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6117
6118C...Set up for direct * direct gamma (switch off leptons).
6119 IF(MINT(122).EQ.1) THEN
6120 MINT(123)=0
6121 MSUB(137)=1
6122 MSUB(138)=1
6123 MSUB(139)=1
6124 MSUB(140)=1
6125 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6126 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6127 120 CONTINUE
6128 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6129
6130C...Set up for direct * VMD and VMD * direct gamma.
6131 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6132 MINT(123)=5
6133 MSUB(131)=1
6134 MSUB(132)=1
6135 MSUB(135)=1
6136 MSUB(136)=1
6137 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6138
6139C...Set up for direct * anomalous and anomalous * direct gamma.
6140 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6141 MINT(123)=6
6142 MSUB(131)=1
6143 MSUB(132)=1
6144 MSUB(135)=1
6145 MSUB(136)=1
6146 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6147
6148C...Set up for VMD*VMD.
6149 ELSEIF(MINT(122).EQ.5) THEN
6150 MINT(123)=2
6151 MSUB(11)=1
6152 MSUB(12)=1
6153 MSUB(13)=1
6154 MSUB(28)=1
6155 MSUB(53)=1
6156 MSUB(68)=1
6157 IF(IPTL.EQ.1) MSUB(95)=1
6158 IF(MSEL.EQ.2) THEN
6159 MSUB(91)=1
6160 MSUB(92)=1
6161 MSUB(93)=1
6162 MSUB(94)=1
6163 ENDIF
6164 IF(IPTL.EQ.1) CKIN(3)=0D0
6165
6166C...Set up for VMD * anomalous and anomalous * VMD gamma.
6167 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6168 MINT(123)=7
6169 MSUB(11)=1
6170 MSUB(12)=1
6171 MSUB(13)=1
6172 MSUB(28)=1
6173 MSUB(53)=1
6174 MSUB(68)=1
6175 IF(IPTL.EQ.1) MSUB(95)=1
6176 IF(MSEL.EQ.2) THEN
6177 MSUB(91)=1
6178 MSUB(92)=1
6179 MSUB(93)=1
6180 MSUB(94)=1
6181 ENDIF
6182 IF(IPTL.EQ.1) CKIN(3)=0D0
6183
6184C...Set up for anomalous * anomalous gamma.
6185 ELSEIF(MINT(122).EQ.9) THEN
6186 MINT(123)=3
6187 MSUB(11)=1
6188 MSUB(12)=1
6189 MSUB(13)=1
6190 MSUB(28)=1
6191 MSUB(53)=1
6192 MSUB(68)=1
6193 IF(IPTL.EQ.1) MSUB(95)=1
6194 IF(MSEL.EQ.2) THEN
6195 MSUB(91)=1
6196 MSUB(92)=1
6197 MSUB(93)=1
6198 MSUB(94)=1
6199 ENDIF
6200 IF(IPTL.EQ.1) CKIN(3)=0D0
6201
6202C...Set up for DIS * VMD and VMD * DIS gamma.
6203 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6204 MINT(123)=8
6205 IF(IPTL.EQ.1) MSUB(99)=1
6206
6207C...Set up for DIS * anomalous and anomalous * DIS gamma.
6208 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6209 MINT(123)=9
6210 IF(IPTL.EQ.1) MSUB(99)=1
6211 ENDIF
6212
6213C...Set up for gamma* * p; virtual photons = dir, res.
6214 ELSEIF(MINT(121).EQ.2) THEN
6215
6216C...Set up for direct * p.
6217 IF(MINT(122).EQ.1) THEN
6218 MINT(123)=0
6219 MSUB(131)=1
6220 MSUB(132)=1
6221 MSUB(135)=1
6222 MSUB(136)=1
6223 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6224
6225C...Set up for resolved * p.
6226 ELSEIF(MINT(122).EQ.2) THEN
6227 MINT(123)=1
6228 MSUB(11)=1
6229 MSUB(12)=1
6230 MSUB(13)=1
6231 MSUB(28)=1
6232 MSUB(53)=1
6233 MSUB(68)=1
6234 IF(IPTL.EQ.1) MSUB(95)=1
6235 IF(MSEL.EQ.2) THEN
6236 MSUB(91)=1
6237 MSUB(92)=1
6238 MSUB(93)=1
6239 MSUB(94)=1
6240 ENDIF
6241 IF(IPTL.EQ.1) CKIN(3)=0D0
6242 ENDIF
6243
6244C...Set up for gamma* * gamma*; virtual photons = dir, res.
6245 ELSEIF(MINT(121).EQ.4) THEN
6246
6247C...Set up for direct * direct gamma (switch off leptons).
6248 IF(MINT(122).EQ.1) THEN
6249 MINT(123)=0
6250 MSUB(137)=1
6251 MSUB(138)=1
6252 MSUB(139)=1
6253 MSUB(140)=1
6254 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6255 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6256 130 CONTINUE
6257 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6258
6259C...Set up for direct * resolved and resolved * direct gamma.
6260 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6261 MINT(123)=5
6262 MSUB(131)=1
6263 MSUB(132)=1
6264 MSUB(135)=1
6265 MSUB(136)=1
6266 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6267
6268C...Set up for resolved * resolved gamma.
6269 ELSEIF(MINT(122).EQ.4) THEN
6270 MINT(123)=2
6271 MSUB(11)=1
6272 MSUB(12)=1
6273 MSUB(13)=1
6274 MSUB(28)=1
6275 MSUB(53)=1
6276 MSUB(68)=1
6277 IF(IPTL.EQ.1) MSUB(95)=1
6278 IF(MSEL.EQ.2) THEN
6279 MSUB(91)=1
6280 MSUB(92)=1
6281 MSUB(93)=1
6282 MSUB(94)=1
6283 ENDIF
6284 IF(IPTL.EQ.1) CKIN(3)=0D0
6285 ENDIF
6286
6287C...End of special set up for gamma-p and gamma-gamma.
6288 ENDIF
6289 CKIN(1)=2D0*CKIN(3)
6290 ENDIF
6291
6292C...Flavour information for individual beams.
6293 DO 140 I=1,2
6294 MINT(40+I)=1
6295 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6296 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6297 MINT(44+I)=MINT(40+I)
6298 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6299 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6300 140 CONTINUE
6301
6302C...If two real gammas, whereof one direct, pick the first.
6303C...For two virtual photons, keep requested order.
6304 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6305 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6306 MINT(41)=1
6307 MINT(45)=1
6308 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6309 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6310 MINT(41)=1
6311 MINT(45)=1
6312 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6313 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6314 MINT(42)=1
6315 MINT(46)=1
6316 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6317 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6318 MINT(41)=1
6319 MINT(45)=1
6320 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6321 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6322 MINT(42)=1
6323 MINT(46)=1
6324 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6325 MINT(41)=1
6326 MINT(45)=1
6327 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6328 MINT(42)=1
6329 MINT(46)=1
6330 ENDIF
6331 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6332 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6333 IF(MINT(11).EQ.22) THEN
6334 MINT(41)=1
6335 MINT(45)=1
6336 ELSE
6337 MINT(42)=1
6338 MINT(46)=1
6339 ENDIF
6340 ENDIF
6341 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6342 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6343 ENDIF
6344
6345C...Flavour information on combination of incoming particles.
6346 MINT(43)=2*MINT(41)+MINT(42)-2
6347 MINT(44)=MINT(43)
6348 IF(MINT(123).LE.0) THEN
6349 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6350 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6351 ELSEIF(MINT(123).LE.3) THEN
6352 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6353 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6354 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6355 MINT(43)=4
6356 MINT(44)=1
6357 ENDIF
6358 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6359 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6360 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6361 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6362 MINT(50)=0
6363 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6364 MINT(107)=0
6365 MINT(108)=0
6366 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6367 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6368 & MINT(107)=2
6369 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6370 & MINT(107)=3
6371 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6372 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6373 & MINT(122).EQ.10) MINT(108)=2
6374 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6375 & MINT(122).EQ.11) MINT(108)=3
6376 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6377 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6378 IF(MINT(122).GE.3) MINT(107)=1
6379 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6380 ELSEIF(MINT(121).EQ.2) THEN
6381 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6382 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6383 ELSE
6384 IF(MINT(11).EQ.22) THEN
6385 MINT(107)=MINT(123)
6386 IF(MINT(123).GE.4) MINT(107)=0
6387 IF(MINT(123).EQ.7) MINT(107)=2
6388 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6389 IF(MSTP(14).EQ.28) MINT(107)=2
6390 IF(MSTP(14).EQ.29) MINT(107)=3
6391 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6392 & MINT(107)=4
6393 ENDIF
6394 IF(MINT(12).EQ.22) THEN
6395 MINT(108)=MINT(123)
6396 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6397 IF(MINT(123).EQ.7) MINT(108)=3
6398 IF(MSTP(14).EQ.26) MINT(108)=2
6399 IF(MSTP(14).EQ.27) MINT(108)=3
6400 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6401 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6402 & MINT(108)=4
6403 ENDIF
6404 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6405 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6406 MINTTP=MINT(107)
6407 MINT(107)=MINT(108)
6408 MINT(108)=MINTTP
6409 ENDIF
6410 ENDIF
6411 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6412 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6413
6414C...Select default processes according to incoming beams
6415C...(already done for gamma-p and gamma-gamma with
6416C...MSTP(14) = 10, 20, 25 or 30).
6417 IF(MINT(121).GT.1) THEN
6418 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6419
6420 IF(MINT(43).EQ.1) THEN
6421C...Lepton + lepton -> gamma/Z0 or W.
6422 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6423 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6424
6425 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6426 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6427C...Unresolved photon + lepton: Compton scattering.
6428 MSUB(133)=1
6429 MSUB(134)=1
6430
6431 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6432 & .OR.MINT(12).EQ.22)) THEN
6433C...DIS as pure gamma* + f -> f process.
6434 MSUB(99)=1
6435
6436 ELSEIF(MINT(43).LE.3) THEN
6437C...Lepton + hadron: deep inelastic scattering.
6438 MSUB(10)=1
6439
6440 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6441 & MINT(12).EQ.22) THEN
6442C...Two unresolved photons: fermion pair production,
6443C...exclude lepton pairs.
6444 DO 150 ISUB=137,140
6445 MSUB(ISUB)=1
6446 150 CONTINUE
6447 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6448 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6449 160 CONTINUE
6450 PTMDIR=PTMRUN
6451 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6452 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6453 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6454
6455 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6456 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6457 & MINT(12).EQ.22)) THEN
6458C...Unresolved photon + hadron: photon-parton scattering.
6459 DO 170 ISUB=131,136
6460 MSUB(ISUB)=1
6461 170 CONTINUE
6462
6463 ELSEIF(MSEL.EQ.1) THEN
6464C...High-pT QCD processes:
6465 MSUB(11)=1
6466 MSUB(12)=1
6467 MSUB(13)=1
6468 MSUB(28)=1
6469 MSUB(53)=1
6470 MSUB(68)=1
6471 PTMN=PTMRUN
6472 VINT(154)=PTMN
6473 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6474 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6475
6476 ELSE
6477C...All QCD processes:
6478 MSUB(11)=1
6479 MSUB(12)=1
6480 MSUB(13)=1
6481 MSUB(28)=1
6482 MSUB(53)=1
6483 MSUB(68)=1
6484 MSUB(91)=1
6485 MSUB(92)=1
6486 MSUB(93)=1
6487 MSUB(94)=1
6488 MSUB(95)=1
6489 ENDIF
6490
6491 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6492C...Heavy quark production.
6493 MSUB(81)=1
6494 MSUB(82)=1
6495 MSUB(84)=1
6496 DO 180 J=1,MIN(8,MDCY(21,3))
6497 MDME(MDCY(21,2)+J-1,1)=0
6498 180 CONTINUE
6499 MDME(MDCY(21,2)+MSEL-1,1)=1
6500 MSUB(85)=1
6501 DO 190 J=1,MIN(12,MDCY(22,3))
6502 MDME(MDCY(22,2)+J-1,1)=0
6503 190 CONTINUE
6504 MDME(MDCY(22,2)+MSEL-1,1)=1
6505
6506 ELSEIF(MSEL.EQ.10) THEN
6507C...Prompt photon production:
6508 MSUB(14)=1
6509 MSUB(18)=1
6510 MSUB(29)=1
6511
6512 ELSEIF(MSEL.EQ.11) THEN
6513C...Z0/gamma* production:
6514 MSUB(1)=1
6515
6516 ELSEIF(MSEL.EQ.12) THEN
6517C...W+/- production:
6518 MSUB(2)=1
6519
6520 ELSEIF(MSEL.EQ.13) THEN
6521C...Z0 + jet:
6522 MSUB(15)=1
6523 MSUB(30)=1
6524
6525 ELSEIF(MSEL.EQ.14) THEN
6526C...W+/- + jet:
6527 MSUB(16)=1
6528 MSUB(31)=1
6529
6530 ELSEIF(MSEL.EQ.15) THEN
6531C...Z0 & W+/- pair production:
6532 MSUB(19)=1
6533 MSUB(20)=1
6534 MSUB(22)=1
6535 MSUB(23)=1
6536 MSUB(25)=1
6537
6538 ELSEIF(MSEL.EQ.16) THEN
6539C...h0 production:
6540 MSUB(3)=1
6541 MSUB(102)=1
6542 MSUB(103)=1
6543 MSUB(123)=1
6544 MSUB(124)=1
6545
6546 ELSEIF(MSEL.EQ.17) THEN
6547C...h0 & Z0 or W+/- pair production:
6548 MSUB(24)=1
6549 MSUB(26)=1
6550
6551 ELSEIF(MSEL.EQ.18) THEN
6552C...h0 production; interesting processes in e+e-.
6553 MSUB(24)=1
6554 MSUB(103)=1
6555 MSUB(123)=1
6556 MSUB(124)=1
6557
6558 ELSEIF(MSEL.EQ.19) THEN
6559C...h0, H0 and A0 production; interesting processes in e+e-.
6560 MSUB(24)=1
6561 MSUB(103)=1
6562 MSUB(123)=1
6563 MSUB(124)=1
6564 MSUB(153)=1
6565 MSUB(171)=1
6566 MSUB(173)=1
6567 MSUB(174)=1
6568 MSUB(158)=1
6569 MSUB(176)=1
6570 MSUB(178)=1
6571 MSUB(179)=1
6572
6573 ELSEIF(MSEL.EQ.21) THEN
6574C...Z'0 production:
6575 MSUB(141)=1
6576
6577 ELSEIF(MSEL.EQ.22) THEN
6578C...W'+/- production:
6579 MSUB(142)=1
6580
6581 ELSEIF(MSEL.EQ.23) THEN
6582C...H+/- production:
6583 MSUB(143)=1
6584
6585 ELSEIF(MSEL.EQ.24) THEN
6586C...R production:
6587 MSUB(144)=1
6588
6589 ELSEIF(MSEL.EQ.25) THEN
6590C...LQ (leptoquark) production.
6591 MSUB(145)=1
6592 MSUB(162)=1
6593 MSUB(163)=1
6594 MSUB(164)=1
6595
6596 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6597C...Production of one heavy quark (W exchange):
6598 MSUB(83)=1
6599 DO 200 J=1,MIN(8,MDCY(21,3))
6600 MDME(MDCY(21,2)+J-1,1)=0
6601 200 CONTINUE
6602 MDME(MDCY(21,2)+MSEL-31,1)=1
6603
6604CMRENNA++Define SUSY alternatives.
6605 ELSEIF(MSEL.EQ.39) THEN
6606C...Turn on all SUSY processes.
6607 IF(MINT(43).EQ.4) THEN
6608C...Hadron-hadron processes.
6609 DO 210 I=201,301
6610 IF(ISET(I).GE.0) MSUB(I)=1
6611 210 CONTINUE
6612 ELSEIF(MINT(43).EQ.1) THEN
6613C...Lepton-lepton processes: QED production of squarks.
6614 DO 220 I=201,214
6615 MSUB(I)=1
6616 220 CONTINUE
6617 MSUB(210)=0
6618 MSUB(211)=0
6619 MSUB(212)=0
6620 DO 230 I=216,228
6621 MSUB(I)=1
6622 230 CONTINUE
6623 DO 240 I=261,263
6624 MSUB(I)=1
6625 240 CONTINUE
6626 MSUB(277)=1
6627 MSUB(278)=1
6628 ENDIF
6629
6630 ELSEIF(MSEL.EQ.40) THEN
6631C...Gluinos and squarks.
6632 IF(MINT(43).EQ.4) THEN
6633 MSUB(243)=1
6634 MSUB(244)=1
6635 MSUB(258)=1
6636 MSUB(259)=1
6637 MSUB(261)=1
6638 MSUB(262)=1
6639 MSUB(264)=1
6640 MSUB(265)=1
6641 DO 250 I=271,296
6642 MSUB(I)=1
6643 250 CONTINUE
6644 ELSEIF(MINT(43).EQ.1) THEN
6645 MSUB(277)=1
6646 MSUB(278)=1
6647 ENDIF
6648
6649 ELSEIF(MSEL.EQ.41) THEN
6650C...Stop production.
6651 MSUB(261)=1
6652 MSUB(262)=1
6653 MSUB(263)=1
6654 IF(MINT(43).EQ.4) THEN
6655 MSUB(264)=1
6656 MSUB(265)=1
6657 ENDIF
6658
6659 ELSEIF(MSEL.EQ.42) THEN
6660C...Slepton production.
6661 DO 260 I=201,214
6662 MSUB(I)=1
6663 260 CONTINUE
6664 IF(MINT(43).NE.4) THEN
6665 MSUB(210)=0
6666 MSUB(211)=0
6667 MSUB(212)=0
6668 ENDIF
6669
6670 ELSEIF(MSEL.EQ.43) THEN
6671C...Neutralino/Chargino + Gluino/Squark.
6672 IF(MINT(43).EQ.4) THEN
6673 DO 270 I=237,242
6674 MSUB(I)=1
6675 270 CONTINUE
6676 DO 280 I=246,254
6677 MSUB(I)=1
6678 280 CONTINUE
6679 MSUB(256)=1
6680 ENDIF
6681
6682 ELSEIF(MSEL.EQ.44) THEN
6683C...Neutralino/Chargino pair production.
6684 IF(MINT(43).EQ.4) THEN
6685 DO 290 I=216,236
6686 MSUB(I)=1
6687 290 CONTINUE
6688 ELSEIF(MINT(43).EQ.1) THEN
6689 DO 300 I=216,228
6690 MSUB(I)=1
6691 300 CONTINUE
6692 ENDIF
6693
6694 ELSEIF(MSEL.EQ.45) THEN
6695C...Sbottom production.
6696 MSUB(287)=1
6697 MSUB(288)=1
6698 IF(MINT(43).EQ.4) THEN
6699 DO 310 I=281,296
6700 MSUB(I)=1
6701 310 CONTINUE
6702 ENDIF
6703
6704 ELSEIF(MSEL.EQ.50) THEN
6705C...Pair production of technipions and gauge bosons.
6706 DO 320 I=361,368
6707 MSUB(I)=1
6708 320 CONTINUE
6709 IF(MINT(43).EQ.4) THEN
6710 DO 330 I=370,377
6711 MSUB(I)=1
6712 330 CONTINUE
6713 ENDIF
6714
6715 ELSEIF(MSEL.EQ.51) THEN
6716C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6717 DO 340 I=381,386
6718 MSUB(I)=1
6719 340 CONTINUE
6720
6721 ELSEIF(MSEL.EQ.61) THEN
6722C...Charmonium production in colour octet model, with recoiling parton.
6723 DO 342 I=421,439
6724 MSUB(I)=1
6725 342 CONTINUE
6726
6727 ELSEIF(MSEL.EQ.62) THEN
6728C...Bottomonium production in colour octet model, with recoiling parton.
6729 DO 344 I=461,479
6730 MSUB(I)=1
6731 344 CONTINUE
6732
6733 ELSEIF(MSEL.EQ.63) THEN
6734C...Charmonium and bottomonium production in colour octet model.
6735 DO 346 I=421,439
6736 MSUB(I)=1
6737 MSUB(I+40)=1
6738 346 CONTINUE
6739 ENDIF
6740
6741C...Find heaviest new quark flavour allowed in processes 81-84.
6742 KFLQM=1
6743 DO 350 I=1,MIN(8,MDCY(21,3))
6744 IDC=I+MDCY(21,2)-1
6745 IF(MDME(IDC,1).LE.0) GOTO 350
6746 KFLQM=I
6747 350 CONTINUE
6748 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6749 &KFLQM=MSTP(7)
6750 MINT(55)=KFLQM
6751 KFPR(81,1)=KFLQM
6752 KFPR(81,2)=KFLQM
6753 KFPR(82,1)=KFLQM
6754 KFPR(82,2)=KFLQM
6755 KFPR(83,1)=KFLQM
6756 KFPR(84,1)=KFLQM
6757 KFPR(84,2)=KFLQM
6758
6759C...Find heaviest new fermion flavour allowed in process 85.
6760 KFLFM=1
6761 DO 360 I=1,MIN(12,MDCY(22,3))
6762 IDC=I+MDCY(22,2)-1
6763 IF(MDME(IDC,1).LE.0) GOTO 360
6764 KFLFM=KFDP(IDC,1)
6765 360 CONTINUE
6766 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6767 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6768 MINT(56)=KFLFM
6769 KFPR(85,1)=KFLFM
6770 KFPR(85,2)=KFLFM
6771
6772C...Import relevant information on external user processes.
6773 IF(MINT(111).GE.11) THEN
6774 IPYPR=0
6775 DO 390 IUP=1,NPRUP
6776C...Find next empty PYTHIA process number slot and enable it.
6777 370 IPYPR=IPYPR+1
6778 IF(IPYPR.GT.500) CALL PYERRM(26,
6779 & '(PYINPR.) no more empty slots for user processes')
6780 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6781 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6782 ISET(IPYPR)=11
6783C...Overwrite KFPR with references back to process number and ID.
6784 KFPR(IPYPR,1)=IUP
6785 KFPR(IPYPR,2)=LPRUP(IUP)
6786C...Process title.
6787 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6788 ICHIN=1
6789 DO 380 ICH=1,9
6790 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6791 380 CONTINUE
6792 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6793C...Switch on process.
6794 MSUB(IPYPR)=1
6795 390 CONTINUE
6796 ENDIF
6797
6798 RETURN
6799 END
6800
6801C*********************************************************************
6802
6803C...PYXTOT
6804C...Parametrizes total, elastic and diffractive cross-sections
6805C...for different energies and beams. Donnachie-Landshoff for
6806C...total and Schuler-Sjostrand for elastic and diffractive.
6807C...Process code IPROC:
6808C...= 1 : p + p;
6809C...= 2 : pbar + p;
6810C...= 3 : pi+ + p;
6811C...= 4 : pi- + p;
6812C...= 5 : pi0 + p;
6813C...= 6 : phi + p;
6814C...= 7 : J/psi + p;
6815C...= 11 : rho + rho;
6816C...= 12 : rho + phi;
6817C...= 13 : rho + J/psi;
6818C...= 14 : phi + phi;
6819C...= 15 : phi + J/psi;
6820C...= 16 : J/psi + J/psi;
6821C...= 21 : gamma + p (DL);
6822C...= 22 : gamma + p (VDM).
6823C...= 23 : gamma + pi (DL);
6824C...= 24 : gamma + pi (VDM);
6825C...= 25 : gamma + gamma (DL);
6826C...= 26 : gamma + gamma (VDM).
6827
6828 SUBROUTINE PYXTOT
6829
6830C...Double precision and integer declarations.
6831 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6832 IMPLICIT INTEGER(I-N)
6833 INTEGER PYK,PYCHGE,PYCOMP
6834C...Commonblocks.
6835 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6837 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6838 COMMON/PYINT1/MINT(400),VINT(400)
6839 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6840 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6841 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6842C...Local arrays.
6843 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6844 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6845 &CEFFD(10,9),SIGTMP(6,0:5)
6846
6847C...Common constants.
6848 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6849 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6850 &FACDD/0.0084D0/
6851
6852C...Number of multiple processes to be evaluated (= 0 : undefined).
6853 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6854C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6855 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6856 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6857 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6858 DATA YPAR/
6859 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6860 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6861 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6862
6863C...Beam and target hadron class:
6864C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6865 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6866 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6867C...Characteristic class masses, slope parameters, beta = sqrt(X).
6868 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6869 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6870 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6871
6872C...Fitting constants used in parametrizations of diffractive results.
6873 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6874 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6875 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6876 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6877 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6878 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6879 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6880 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6881 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6882 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6883 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6884 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6885 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6886 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6887 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6888 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6889 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6890 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6891 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6892 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6893 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6894 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6895 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6896 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6897 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6898 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6899 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6900 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6901 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6902
6903C...Parameters. Combinations of the energy.
6904 AEM=PARU(101)
6905 PMTH=PARP(102)
6906 S=VINT(2)
6907 SRT=VINT(1)
6908 SEPS=S**EPS
6909 SETA=S**ETA
6910 SLOG=LOG(S)
6911
6912C...Ratio of gamma/pi (for rescaling in parton distributions).
6913 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
6914 &(XPAR(5)*SEPS+YPAR(5)*SETA)
6915 VINT(317)=1D0
6916 IF(MINT(50).NE.1) RETURN
6917
6918C...Order flavours of incoming particles: KF1 < KF2.
6919 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
6920 KF1=IABS(MINT(11))
6921 KF2=IABS(MINT(12))
6922 IORD=1
6923 ELSE
6924 KF1=IABS(MINT(12))
6925 KF2=IABS(MINT(11))
6926 IORD=2
6927 ENDIF
6928 ISGN12=ISIGN(1,MINT(11)*MINT(12))
6929
6930C...Find process number (for lookup tables).
6931 IF(KF1.GT.1000) THEN
6932 IPROC=1
6933 IF(ISGN12.LT.0) IPROC=2
6934 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
6935 IPROC=3
6936 IF(ISGN12.LT.0) IPROC=4
6937 IF(KF1.EQ.111) IPROC=5
6938 ELSEIF(KF1.GT.100) THEN
6939 IPROC=11
6940 ELSEIF(KF2.GT.1000) THEN
6941 IPROC=21
6942 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
6943 ELSEIF(KF2.GT.100) THEN
6944 IPROC=23
6945 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
6946 ELSE
6947 IPROC=25
6948 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
6949 ENDIF
6950
6951C... Number of multiple processes to be stored; beam/target side.
6952 NPR=NPROC(IPROC)
6953 MINT(101)=1
6954 MINT(102)=1
6955 IF(NPR.EQ.3) THEN
6956 MINT(100+IORD)=4
6957 ELSEIF(NPR.EQ.6) THEN
6958 MINT(101)=4
6959 MINT(102)=4
6960 ENDIF
6961 N1=0
6962 IF(MINT(101).EQ.4) N1=4
6963 N2=0
6964 IF(MINT(102).EQ.4) N2=4
6965
6966C...Do not do any more for user-set or undefined cross-sections.
6967 IF(MSTP(31).LE.0) RETURN
6968 IF(NPR.EQ.0) CALL PYERRM(26,
6969 &'(PYXTOT:) cross section for this process not yet implemented')
6970
6971C...Parameters. Combinations of the energy.
6972 AEM=PARU(101)
6973 PMTH=PARP(102)
6974 S=VINT(2)
6975 SRT=VINT(1)
6976 SEPS=S**EPS
6977 SETA=S**ETA
6978 SLOG=LOG(S)
6979
6980C...Loop over multiple processes (for VDM).
6981 DO 110 I=1,NPR
6982 IF(NPR.EQ.1) THEN
6983 IPR=IPROC
6984 ELSEIF(NPR.EQ.3) THEN
6985 IPR=I+4
6986 IF(KF2.LT.1000) IPR=I+10
6987 ELSEIF(NPR.EQ.6) THEN
6988 IPR=I+10
6989 ENDIF
6990
6991C...Evaluate hadron species, mass, slope contribution and fit number.
6992 IHA=IHADA(IPR)
6993 IHB=IHADB(IPR)
6994 PMA=PMHAD(IHA)
6995 PMB=PMHAD(IHB)
6996 BHA=BHAD(IHA)
6997 BHB=BHAD(IHB)
6998 ISD=IFITSD(IPR)
6999 IDD=IFITDD(IPR)
7000
7001C...Skip if energy too low relative to masses.
7002 DO 100 J=0,5
7003 SIGTMP(I,J)=0D0
7004 100 CONTINUE
7005 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7006
7007C...Total cross-section. Elastic slope parameter and cross-section.
7008 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7009 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7010 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7011
7012C...Diffractive scattering A + B -> X + B.
7013 BSD=2D0*BHB
7014 SQML=(PMA+PMTH)**2
7015 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7016 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7017 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7018 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7019 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7020 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7021 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7022
7023C...Diffractive scattering A + B -> A + X.
7024 BSD=2D0*BHA
7025 SQML=(PMB+PMTH)**2
7026 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7027 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7028 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7029 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7030 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7031 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7032 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7033
7034C...Order single diffractive correctly.
7035 IF(IORD.EQ.2) THEN
7036 SIGSAV=SIGTMP(I,2)
7037 SIGTMP(I,2)=SIGTMP(I,3)
7038 SIGTMP(I,3)=SIGSAV
7039 ENDIF
7040
7041C...Double diffractive scattering A + B -> X1 + X2.
7042 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7043 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7044 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7045 IF(YEFF.LE.0) SUM1=0D0
7046 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7047 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7048 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7049 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7050 & (2D0*ALP)
7051 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7052 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7053 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7054 & (2D0*ALP)
7055 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7056 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7057 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7058 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7059 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7060
7061C...Non-diffractive by unitarity.
7062 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7063 & SIGTMP(I,4)
7064 110 CONTINUE
7065
7066C...Put temporary results in output array: only one process.
7067 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7068 DO 120 J=0,5
7069 SIGT(0,0,J)=SIGTMP(1,J)
7070 120 CONTINUE
7071
7072C...Beam multiple processes.
7073 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7074 IF(MINT(107).EQ.2) THEN
7075 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7076 ELSE
7077 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7078 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7079 ENDIF
7080 IF(MSTP(20).GT.0) THEN
7081 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7082 ENDIF
7083 DO 140 I=1,4
7084 IF(MINT(107).EQ.2) THEN
7085 CONV=(AEM/PARP(160+I))*VINT(317)
7086 ELSEIF(VINT(154).GT.PARP(15)) THEN
7087 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7088 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7089 ELSE
7090 CONV=0D0
7091 ENDIF
7092 I1=MAX(1,I-1)
7093 DO 130 J=0,5
7094 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7095 130 CONTINUE
7096 140 CONTINUE
7097 DO 150 J=0,5
7098 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7099 150 CONTINUE
7100
7101C...Target multiple processes.
7102 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7103 IF(MINT(108).EQ.2) THEN
7104 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7105 ELSE
7106 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7107 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7108 ENDIF
7109 IF(MSTP(20).GT.0) THEN
7110 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7111 ENDIF
7112 DO 170 I=1,4
7113 IF(MINT(108).EQ.2) THEN
7114 CONV=(AEM/PARP(160+I))*VINT(317)
7115 ELSEIF(VINT(154).GT.PARP(15)) THEN
7116 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7117 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7118 ELSE
7119 CONV=0D0
7120 ENDIF
7121 IV=MAX(1,I-1)
7122 DO 160 J=0,5
7123 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7124 160 CONTINUE
7125 170 CONTINUE
7126 DO 180 J=0,5
7127 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7128 180 CONTINUE
7129
7130C...Both beam and target multiple processes.
7131 ELSE
7132 IF(MINT(107).EQ.2) THEN
7133 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7134 ELSE
7135 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7136 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7137 ENDIF
7138 IF(MINT(108).EQ.2) THEN
7139 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7140 ELSE
7141 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7142 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7143 ENDIF
7144 IF(MSTP(20).GT.0) THEN
7145 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7146 & VINT(308)))**MSTP(20)
7147 ENDIF
7148 DO 210 I1=1,4
7149 DO 200 I2=1,4
7150 IF(MINT(107).EQ.2) THEN
7151 CONV=(AEM/PARP(160+I1))*VINT(317)
7152 ELSEIF(VINT(154).GT.PARP(15)) THEN
7153 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7154 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7155 ELSE
7156 CONV=0D0
7157 ENDIF
7158 IF(MINT(108).EQ.2) THEN
7159 CONV=CONV*(AEM/PARP(160+I2))
7160 ELSEIF(VINT(154).GT.PARP(15)) THEN
7161 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7162 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7163 ELSE
7164 CONV=0D0
7165 ENDIF
7166 IF(I1.LE.2) THEN
7167 IV=MAX(1,I2-1)
7168 ELSEIF(I2.LE.2) THEN
7169 IV=MAX(1,I1-1)
7170 ELSEIF(I1.EQ.I2) THEN
7171 IV=2*I1-2
7172 ELSE
7173 IV=5
7174 ENDIF
7175 DO 190 J=0,5
7176 JV=J
7177 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7178 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7179 190 CONTINUE
7180 200 CONTINUE
7181 210 CONTINUE
7182 DO 230 J=0,5
7183 DO 220 I=1,4
7184 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7185 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7186 220 CONTINUE
7187 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7188 230 CONTINUE
7189 ENDIF
7190
7191C...Scale up uniformly for Donnachie-Landshoff parametrization.
7192 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7193 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7194 DO 260 I1=0,N1
7195 DO 250 I2=0,N2
7196 DO 240 J=0,5
7197 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7198 240 CONTINUE
7199 250 CONTINUE
7200 260 CONTINUE
7201 ENDIF
7202
7203 RETURN
7204 END
7205
7206C*********************************************************************
7207
7208C...PYMAXI
7209C...Finds optimal set of coefficients for kinematical variable selection
7210C...and the maximum of the part of the differential cross-section used
7211C...in the event weighting.
7212
7213 SUBROUTINE PYMAXI
7214
7215C...Double precision and integer declarations.
7216 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7217 IMPLICIT INTEGER(I-N)
7218 INTEGER PYK,PYCHGE,PYCOMP
7219C...Parameter statement to help give large particle numbers.
7220 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7221 &KEXCIT=4000000,KDIMEN=5000000)
7222
7223C...User process initialization commonblock.
7224 INTEGER MAXPUP
7225 PARAMETER (MAXPUP=100)
7226 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7227 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7228 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7229 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7230 &LPRUP(MAXPUP)
7231 SAVE /HEPRUP/
7232
7233C...Commonblocks.
7234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7235 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7236 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7237 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7238 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7239 COMMON/PYINT1/MINT(400),VINT(400)
7240 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7241 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7242 COMMON/PYINT4/MWID(500),WIDS(500,5)
7243 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7244 COMMON/PYINT6/PROC(0:500)
7245 CHARACTER PROC*28
7246 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7247 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7248 COMMON/PYTCCO/COEFX(194:380,2)
7249 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7250 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7251 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7252 &/PYTCSM/,/TCPARA/
7253C...Local arrays, character variables and data.
7254 LOGICAL IOK
7255 CHARACTER CVAR(4)*4
7256 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7257 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7258 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7259 &IQ(9),IP(9)
7260 DATA CVAR/'tau ','tau''','y* ','cth '/
7261 DATA SIGSSM/3*0D0/
7262
7263C...Initial values and loop over subprocesses.
7264 NPOSI=0
7265 VINT(143)=1D0
7266 VINT(144)=1D0
7267 XSEC(0,1)=0D0
7268 ITECH=0
7269 DO 460 ISUB=1,500
7270 MINT(1)=ISUB
7271 MINT(51)=0
7272
7273C...Find maximum weight factors for photon flux.
7274 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7275 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7276 ENDIF
7277
7278C...Select subprocess to study: skip cases not applicable.
7279 IF(ISET(ISUB).EQ.11) THEN
7280 IF(MSUB(ISUB).NE.1) GOTO 460
7281C...User process intialization: cross section model dependent.
7282 IF(IABS(IDWTUP).EQ.1) THEN
7283 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7284 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7285 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7286 ELSE
7287 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7288 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7289 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7290 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7291 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7292 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7293 ENDIF
7294 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7295 & WTGAGA*XSEC(ISUB,1)
7296 NPOSI=NPOSI+1
7297 GOTO 450
7298 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7299 CALL PYSIGH(NCHN,SIGS)
7300 XSEC(ISUB,1)=SIGS
7301 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7302 & WTGAGA*XSEC(ISUB,1)
7303 IF(MSUB(ISUB).NE.1) GOTO 460
7304 NPOSI=NPOSI+1
7305 GOTO 450
7306 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7307 CALL PYSIGH(NCHN,SIGS)
7308 XSEC(ISUB,1)=SIGS
7309 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7310 & WTGAGA*XSEC(ISUB,1)
7311 IF(XSEC(ISUB,1).EQ.0D0) THEN
7312 MSUB(ISUB)=0
7313 ELSE
7314 NPOSI=NPOSI+1
7315 ENDIF
7316 GOTO 450
7317 ELSEIF(ISUB.EQ.96) THEN
7318 IF(MINT(50).EQ.0) GOTO 460
7319 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7320 & GOTO 460
7321 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7322 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7323 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7324 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7325 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7326 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7327 ELSE
7328 IF(MSUB(ISUB).NE.1) GOTO 460
7329 ENDIF
7330 ISTSB=ISET(ISUB)
7331 IF(ISUB.EQ.96) ISTSB=2
7332 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7333 MWTXS=0
7334 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7335 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7336
7337C...Find resonances (explicit or implicit in cross-section).
7338 MINT(72)=0
7339 KFR1=0
7340 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7341 KFR1=KFPR(ISUB,1)
7342 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7343 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7344 KFR1=23
7345 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7346 & .OR.ISUB.EQ.177) THEN
7347 KFR1=24
7348 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7349 KFR1=25
7350 IF(MSTP(46).EQ.5) THEN
7351 KFR1=89
7352 PMAS(89,1)=PARP(45)
7353 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7354 ENDIF
7355 ENDIF
7356 CKMX=CKIN(2)
7357 IF(CKMX.LE.0D0) CKMX=VINT(1)
7358 KCR1=PYCOMP(KFR1)
7359 IF(KFR1.NE.0) THEN
7360 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7361 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7362 ENDIF
7363 IF(KFR1.NE.0) THEN
7364 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7365 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7366 MINT(72)=1
7367 MINT(73)=KFR1
7368 VINT(73)=TAUR1
7369 VINT(74)=GAMR1
7370 ENDIF
7371 KFR2=0
7372 KFR3=0
7373 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7374 $ (ISUB.GE.361.AND.ISUB.LE.380))
7375 $ THEN
7376 KFR2=23
7377 IF(ISUB.EQ.141) THEN
7378 KCR2=PYCOMP(KFR2)
7379 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7380 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7381 KFR2=0
7382 ELSE
7383 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7384 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7385 MINT(72)=2
7386 MINT(74)=KFR2
7387 VINT(75)=TAUR2
7388 VINT(76)=GAMR2
7389 ENDIF
7390 ELSEIF(ITECH.EQ.0) THEN
7391 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7392 ITECH=1
7393 KFR1=KTECHN+113
7394 KCR1=PYCOMP(KFR1)
7395 KFR2=KTECHN+223
7396 KCR2=PYCOMP(KFR2)
7397 KFR3=KTECHN+115
7398 KCR3=PYCOMP(KFR3)
7399 IRES=0
7400C...Order the resonances
7401 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7402 KCT=KCR3
7403 KCR3=KCR2
7404 KCR2=KCT
7405 ENDIF
7406 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7407 KCT=KCR3
7408 KCR3=KCR1
7409 KCR1=KCT
7410 ENDIF
7411 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7412 KCT=KCR2
7413 KCR2=KCR1
7414 KCR1=KCT
7415 ENDIF
7416 DO 101 I=1,3
7417 IF(I.EQ.1) THEN
7418 SHN0=PMAS(KCR1,1)**2
7419 ELSEIF(I.EQ.2) THEN
7420 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7421 SHN0=PMAS(KCR2,1)**2
7422 ELSEIF(I.EQ.3) THEN
7423 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7424 SHN0=PMAS(KCR3,1)**2
7425 ENDIF
7426 AEM=PYALEM(SHN0)
7427 FAR=SQRT(AEM/ALPRHT)
7428 SHN=SHN0*(1D0-FAR)
7429 CALL PYTECM(SHN,S1,WIDO,1)
7430 RES=SHN-S1
7431 SHN=S1*.99D0
7432 SHSTEP=2D0
7433 102 SHN=SHN+SHSTEP
7434 CALL PYTECM(SHN,S1,WIDO,1)
7435 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7436 IOK=.FALSE.
7437 IF(IRES.GT.0) THEN
7438 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7439 ELSEIF(IRES.EQ.0) THEN
7440 IOK=.TRUE.
7441 ENDIF
7442 IF(IOK) THEN
7443 IRES=IRES+1
7444 XMAS(IRES)=SQRT(S1)
7445 XWID(IRES)=WIDO
7446 ENDIF
7447 ENDIF
7448 RES=SHN-S1
7449 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7450 101 CONTINUE
7451 JRES=0
7452 KFR1=KTECHN+213
7453 KCR1=PYCOMP(KFR1)
7454 KFR2=KTECHN+215
7455 KCR2=PYCOMP(KFR2)
7456 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7457 KCT=KCR2
7458 KCR2=KCR1
7459 KCR1=KCT
7460 ENDIF
7461 DO 103 I=1,2
7462 IF(I.EQ.1) THEN
7463 SHN0=PMAS(KCR1,1)**2
7464 ELSEIF(I.EQ.2) THEN
7465 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7466 SHN0=PMAS(KCR2,1)**2
7467 ENDIF
7468 AEM=PYALEM(SHN0)
7469 FAR=SQRT(AEM/ALPRHT)
7470 SHN=SHN0*(1D0-FAR)
7471 CALL PYTECM(SHN,S1,WIDO,2)
7472 RES=SHN-S1
7473 SHN=S1*.99D0
7474 SHSTEP=2D0
7475 104 SHN=SHN+SHSTEP
7476 CALL PYTECM(SHN,S1,WIDO,2)
7477 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7478 IOK=.FALSE.
7479 IF(JRES.GT.0) THEN
7480 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7481 ELSEIF(JRES.EQ.0) THEN
7482 IOK=.TRUE.
7483 ENDIF
7484 IF(IOK) THEN
7485 JRES=JRES+1
7486 YMAS(JRES)=SQRT(S1)
7487 YWID(JRES)=WIDO
7488 ENDIF
7489 ENDIF
7490 RES=SHN-S1
7491 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7492 103 CONTINUE
7493 ENDIF
7494 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7495 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7496 MINT(72)=IRES
7497 IF(IRES.GE.1) THEN
7498 VINT(73)=XMAS(1)**2/VINT(2)
7499 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7500 TAUR1=VINT(73)
7501 GAMR1=VINT(74)
7502 XM1=XMAS(1)
7503 XG1=XWID(1)
7504 KFR1=1
7505 ENDIF
7506 IF(IRES.GE.2) THEN
7507 VINT(75)=XMAS(2)**2/VINT(2)
7508 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7509 TAUR2=VINT(75)
7510 GAMR2=VINT(76)
7511 XM2=XMAS(2)
7512 XG2=XWID(2)
7513 KFR2=2
7514 ENDIF
7515 IF(IRES.EQ.3) THEN
7516 VINT(77)=XMAS(3)**2/VINT(2)
7517 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7518 TAUR3=VINT(77)
7519 GAMR3=VINT(78)
7520 XM3=XMAS(3)
7521 XG3=XWID(3)
7522 KFR3=3
7523 ENDIF
7524C...Charged current: rho+- and a+-
7525 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7526 MINT(72)=IRES
7527 IF(JRES.GE.1) THEN
7528 VINT(73)=YMAS(1)**2/VINT(2)
7529 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7530 KFR1=1
7531 TAUR1=VINT(73)
7532 GAMR1=VINT(74)
7533 XM1=YMAS(1)
7534 XG1=YWID(1)
7535 ENDIF
7536 IF(JRES.GE.2) THEN
7537 VINT(75)=YMAS(2)**2/VINT(2)
7538 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7539 KFR2=2
7540 TAUR2=VINT(73)
7541 GAMR2=VINT(74)
7542 XM2=YMAS(2)
7543 XG2=YWID(2)
7544 ENDIF
7545 KFR3=0
7546 ENDIF
7547 IF(ISUB.NE.141) THEN
7548 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7549 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7550 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7551 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7552 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7553 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7554 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7555
7556 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7557 MINT(72)=2
7558 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7559 MINT(72)=2
7560 MINT(74)=KFR3
7561 VINT(75)=TAUR3
7562 VINT(76)=GAMR3
7563 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7564 MINT(72)=2
7565 MINT(73)=KFR2
7566 VINT(73)=TAUR2
7567 VINT(74)=GAMR2
7568 MINT(74)=KFR3
7569 VINT(75)=TAUR3
7570 VINT(76)=GAMR3
7571 ELSEIF(KFR1.NE.0) THEN
7572 MINT(72)=1
7573 ELSEIF(KFR2.NE.0) THEN
7574 MINT(72)=1
7575 MINT(73)=KFR2
7576 VINT(73)=TAUR2
7577 VINT(74)=GAMR2
7578 ELSEIF(KFR3.NE.0) THEN
7579 MINT(72)=1
7580 MINT(73)=KFR3
7581 VINT(73)=TAUR3
7582 VINT(74)=GAMR3
7583 ELSE
7584 MINT(72)=0
7585 ENDIF
7586 ELSE
7587 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7588
7589 ELSEIF(KFR2.NE.0) THEN
7590 KFR1=KFR2
7591 TAUR1=TAUR2
7592 GAMR1=GAMR2
7593 MINT(72)=1
7594 MINT(73)=KFR1
7595 VINT(73)=TAUR1
7596 VINT(74)=GAMR1
7597 KFR2=0
7598 ELSE
7599 MINT(72)=0
7600 ENDIF
7601 ENDIF
7602 ENDIF
7603
7604C...Find product masses and minimum pT of process.
7605 SQM3=0D0
7606 SQM4=0D0
7607 MINT(71)=0
7608 VINT(71)=CKIN(3)
7609 VINT(80)=1D0
7610 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7611 NBW=0
7612 DO 110 I=1,2
7613 PMMN(I)=0D0
7614 IF(KFPR(ISUB,I).EQ.0) THEN
7615 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7616 & PARP(41)) THEN
7617 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7618 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7619 ELSE
7620 NBW=NBW+1
7621C...This prevents SUSY/t particles from becoming too light.
7622 KFLW=KFPR(ISUB,I)
7623 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7624 KCW=PYCOMP(KFLW)
7625 PMMN(I)=PMAS(KCW,1)
7626 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7627 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7628 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7629 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7630 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7631 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7632 PMMN(I)=MIN(PMMN(I),PMSUM)
7633 ENDIF
7634 100 CONTINUE
7635 ELSEIF(KFLW.EQ.6) THEN
7636 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7637 ENDIF
7638 ENDIF
7639 110 CONTINUE
7640 IF(NBW.GE.1) THEN
7641 CKIN41=CKIN(41)
7642 CKIN43=CKIN(43)
7643 CKIN(41)=MAX(PMMN(1),CKIN(41))
7644 CKIN(43)=MAX(PMMN(2),CKIN(43))
7645 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7646 CKIN(41)=CKIN41
7647 CKIN(43)=CKIN43
7648 IF(MINT(51).EQ.1) THEN
7649 WRITE(MSTU(11),5100) ISUB
7650 MSUB(ISUB)=0
7651 GOTO 460
7652 ENDIF
7653 SQM3=PQM3**2
7654 SQM4=PQM4**2
7655 ENDIF
7656 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7657 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7658 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7659 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7660 ELSEIF(ISUB.EQ.96) THEN
7661 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7662 ENDIF
7663 ENDIF
7664 VINT(63)=SQM3
7665 VINT(64)=SQM4
7666
7667C...Prepare for additional variable choices in 2 -> 3.
7668 IF(ISTSB.EQ.5) THEN
7669 VINT(201)=0D0
7670 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7671 VINT(206)=VINT(201)
7672 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7673 VINT(204)=PMAS(23,1)
7674 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7675 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7676 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7677 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7678 & VINT(204)=VINT(201)
7679 VINT(209)=VINT(204)
7680 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7681 ENDIF
7682
7683C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7684 IPEAK7=0
7685 NPTS(1)=2+2*MINT(72)
7686 IF(MINT(47).EQ.1) THEN
7687 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7688 ELSEIF(MINT(47).GE.5) THEN
7689 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7690 NPTS(1)=NPTS(1)+1
7691 IPEAK7=1
7692 ENDIF
7693 ENDIF
7694 NPTS(2)=1
7695 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7696 IF(MINT(47).GE.2) NPTS(2)=2
7697 IF(MINT(47).GE.5) NPTS(2)=3
7698 ENDIF
7699 NPTS(3)=1
7700 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7701 NPTS(3)=3
7702 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7703 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7704 ENDIF
7705 NPTS(4)=1
7706 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7707 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7708
7709C...Reset coefficients of cross-section weighting.
7710 DO 120 J=1,20
7711 COEF(ISUB,J)=0D0
7712 120 CONTINUE
7713 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7714 & .AND.ISUB.LE.380)) THEN
7715 DO 125 J=1,2
7716 COEFX(ISUB,J)=0D0
7717 125 CONTINUE
7718 ENDIF
7719 COEF(ISUB,1)=1D0
7720 COEF(ISUB,8)=0.5D0
7721 COEF(ISUB,9)=0.5D0
7722 COEF(ISUB,13)=1D0
7723 COEF(ISUB,18)=1D0
7724 MCTH=0
7725 MTAUP=0
7726 METAUP=0
7727 VINT(23)=0D0
7728 VINT(26)=0D0
7729 SIGSAM=0D0
7730
7731C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7732C...in grid of phase space points.
7733 CALL PYKLIM(1)
7734 METAU=MINT(51)
7735 NACC=0
7736 DO 150 ITRY=1,NTRY
7737 MINT(51)=0
7738 IF(METAU.EQ.1) GOTO 150
7739 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7740 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7741 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7742 MTAU=7
7743 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7744 MTAU=MTAU+1
7745 ENDIF
7746 RTAU=0.5D0
7747C...Special case when both resonances have same mass,
7748C...as is often the case in process 194.
7749c IF(MINT(72).GE.2) THEN
7750c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7751c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7752c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7753c RTAU=0.4D0
7754c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7755c RTAU=0.6D0
7756c ENDIF
7757c ENDIF
7758c ENDIF
7759 CALL PYKMAP(1,MTAU,RTAU)
7760 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7761 METAUP=MINT(51)
7762 ENDIF
7763 IF(METAUP.EQ.1) GOTO 150
7764 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7765 & .EQ.0) THEN
7766 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7767 CALL PYKMAP(4,MTAUP,0.5D0)
7768 ENDIF
7769 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7770 CALL PYKLIM(2)
7771 MEYST=MINT(51)
7772 ENDIF
7773 IF(MEYST.EQ.1) GOTO 150
7774 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7775 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7776 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7777 CALL PYKMAP(2,MYST,0.5D0)
7778 CALL PYKLIM(3)
7779 MECTH=MINT(51)
7780 ENDIF
7781 IF(MECTH.EQ.1) GOTO 150
7782 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7783 MCTH=1+MOD(ITRY-1,NPTS(4))
7784 CALL PYKMAP(3,MCTH,0.5D0)
7785 ENDIF
7786 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7787
7788C...Store position and limits.
7789 MINT(51)=0
7790 CALL PYKLIM(0)
7791 IF(MINT(51).EQ.1) GOTO 150
7792 NACC=NACC+1
7793 MVARPT(NACC,1)=MTAU
7794 MVARPT(NACC,2)=MTAUP
7795 MVARPT(NACC,3)=MYST
7796 MVARPT(NACC,4)=MCTH
7797 DO 130 J=1,30
7798 VINTPT(NACC,J)=VINT(10+J)
7799 130 CONTINUE
7800
7801C...Normal case: calculate cross-section.
7802 IF(ISTSB.NE.5) THEN
7803 CALL PYSIGH(NCHN,SIGS)
7804 IF(MWTXS.EQ.1) THEN
7805 CALL PYEVWT(WTXS)
7806 SIGS=WTXS*SIGS
7807 ENDIF
7808
7809C..2 -> 3: find highest value out of a number of tries.
7810 ELSE
7811 SIGS=0D0
7812 DO 140 IKIN3=1,MSTP(129)
7813 CALL PYKMAP(5,0,0D0)
7814 IF(MINT(51).EQ.1) GOTO 140
7815 CALL PYSIGH(NCHN,SIGTMP)
7816 IF(MWTXS.EQ.1) THEN
7817 CALL PYEVWT(WTXS)
7818 SIGTMP=WTXS*SIGTMP
7819 ENDIF
7820 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7821 140 CONTINUE
7822 ENDIF
7823
7824C...Store cross-section.
7825 SIGSPT(NACC)=SIGS
7826 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7827 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7828 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7829 150 CONTINUE
7830 IF(NACC.EQ.0) THEN
7831 WRITE(MSTU(11),5100) ISUB
7832 MSUB(ISUB)=0
7833 GOTO 460
7834 ELSEIF(SIGSAM.EQ.0D0) THEN
7835 WRITE(MSTU(11),5300) ISUB
7836 MSUB(ISUB)=0
7837 GOTO 460
7838 ENDIF
7839 IF(ISUB.NE.96) NPOSI=NPOSI+1
7840
7841C...Calculate integrals in tau over maximal phase space limits.
7842 TAUMIN=VINT(11)
7843 TAUMAX=VINT(31)
7844 ATAU1=LOG(TAUMAX/TAUMIN)
7845 IF(NPTS(1).GE.2) THEN
7846 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7847 ENDIF
7848 IF(NPTS(1).GE.4) THEN
7849 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7850 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7851 & GAMR1
7852 ENDIF
7853 IF(NPTS(1).GE.6) THEN
7854 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7855 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7856 & GAMR2
7857 ENDIF
7858 IF(NPTS(1).GE.8) THEN
7859 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7860 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7861 & GAMR3
7862 ENDIF
7863 IF(IPEAK7.EQ.1) THEN
7864 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7865 ENDIF
7866
7867C...Reset. Sum up cross-sections in points calculated.
7868 DO 320 IVAR=1,4
7869 IF(NPTS(IVAR).EQ.1) GOTO 320
7870 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7871 NBIN=NPTS(IVAR)
7872 DO 170 J1=1,NBIN
7873 NAREL(J1)=0
7874 WTREL(J1)=0D0
7875 COEFU(J1)=0D0
7876 DO 160 J2=1,NBIN
7877 WTMAT(J1,J2)=0D0
7878 160 CONTINUE
7879 170 CONTINUE
7880 DO 180 IACC=1,NACC
7881 IBIN=MVARPT(IACC,IVAR)
7882 IF(IVAR.EQ.1) THEN
7883 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7884 IBIN=IBIN-1
7885 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7886 IBIN=3+2*MINT(72)
7887 ENDIF
7888 ENDIF
7889 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7890 NAREL(IBIN)=NAREL(IBIN)+1
7891 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7892
7893C...Sum up tau cross-section pieces in points used.
7894 IF(IVAR.EQ.1) THEN
7895 TAU=VINTPT(IACC,11)
7896 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7897 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7898 IF(NBIN.GE.4) THEN
7899 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7900 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7901 & ((TAU-TAUR1)**2+GAMR1**2)
7902 ENDIF
7903 IF(NBIN.GE.6) THEN
7904 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7905 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7906 & ((TAU-TAUR2)**2+GAMR2**2)
7907 ENDIF
7908 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7909 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7910 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7911 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
7912 WTMAT(IBIN,7)=WTMAT(IBIN,7)
7913 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
7914 ENDIF
7915 IF(MINT(72).EQ.3) THEN
7916 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
7917 & +(ATAU1/ATAU8)/(TAU+TAUR3)
7918 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
7919 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
7920 ENDIF
7921C...Sum up tau' cross-section pieces in points used.
7922 ELSEIF(IVAR.EQ.2) THEN
7923 TAU=VINTPT(IACC,11)
7924 TAUP=VINTPT(IACC,16)
7925 TAUPMN=VINTPT(IACC,6)
7926 TAUPMX=VINTPT(IACC,26)
7927 ATAUP1=LOG(TAUPMX/TAUPMN)
7928 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
7929 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7930 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
7931 & (1D0-TAU/TAUP)**3/TAUP
7932 IF(NBIN.GE.3) THEN
7933 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
7934 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
7935 & TAUP/MAX(2D-10,1D0-TAUP)
7936 ENDIF
7937
7938C...Sum up y* cross-section pieces in points used.
7939 ELSEIF(IVAR.EQ.3) THEN
7940 YST=VINTPT(IACC,12)
7941 YSTMIN=VINTPT(IACC,2)
7942 YSTMAX=VINTPT(IACC,22)
7943 AYST0=YSTMAX-YSTMIN
7944 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
7945 AYST2=AYST1
7946 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
7947 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
7948 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
7949 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
7950 IF(MINT(45).EQ.3) THEN
7951 TAUE=VINTPT(IACC,11)
7952 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7953 YST0=-0.5D0*LOG(TAUE)
7954 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
7955 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
7956 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
7957 & MAX(1D-10,1D0-EXP(YST-YST0))
7958 ENDIF
7959 IF(MINT(46).EQ.3) THEN
7960 TAUE=VINTPT(IACC,11)
7961 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
7962 YST0=-0.5D0*LOG(TAUE)
7963 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
7964 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
7965 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
7966 & MAX(1D-10,1D0-EXP(-YST-YST0))
7967 ENDIF
7968
7969C...Sum up cos(theta-hat) cross-section pieces in points used.
7970 ELSE
7971 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
7972 RSQM=1D0+RM34
7973 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
7974 CTHMIN=-CTHMAX
7975 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
7976 & (TAUMAX*VINT(2)))
7977 ACTH1=CTHMAX-CTHMIN
7978 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
7979 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
7980 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
7981 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
7982 CTH=VINTPT(IACC,13)
7983 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7984 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
7985 & MAX(RM34,RSQM-CTH)
7986 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
7987 & MAX(RM34,RSQM+CTH)
7988 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
7989 & MAX(RM34,RSQM-CTH)**2
7990 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
7991 & MAX(RM34,RSQM+CTH)**2
7992 ENDIF
7993 180 CONTINUE
7994
7995C...Check that equation system solvable.
7996 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
7997 MSOLV=1
7998 WTRELS=0D0
7999 DO 190 IBIN=1,NBIN
8000 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8001 & IRED=1,NBIN),WTREL(IBIN)
8002 IF(NAREL(IBIN).EQ.0) MSOLV=0
8003 WTRELS=WTRELS+WTREL(IBIN)
8004 190 CONTINUE
8005 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8006
8007C...Solve to find relative importance of cross-section pieces.
8008 IF(MSOLV.EQ.1) THEN
8009 DO 200 IBIN=1,NBIN
8010 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8011 WTRSAV(IBIN)=WTREL(IBIN)
8012 200 CONTINUE
8013C...Auxiliary vectors to record order of permutations
8014 DO I=1,NBIN
8015 IP(I) = I
8016 IQ(I) = I
8017 ENDDO
8018 DO 230 IRED=1,NBIN-1
8019 MROW=IRED
8020 RESMAX=ABS(WTREL(MROW))
8021C...Find row with largest residual
8022 DO JBIN=IRED+1,NBIN
8023 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8024 MROW=JBIN
8025 RESMAX=ABS(WTREL(MROW))
8026 ENDIF
8027 ENDDO
8028 IF(RESMAX.LT.1D-20) THEN
8029 MSOLV=0
8030 GOTO 260
8031 ENDIF
8032 MCOL = IRED
8033 AMAX = ABS(WTMAT(MROW,MCOL))
8034C...Find column with largest entry
8035 DO JBIN=IRED+1,NBIN
8036 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8037 MCOL = JBIN
8038 AMAX = ABS(WTMAT(MROW,MCOL))
8039 ENDIF
8040 ENDDO
8041C...Swap rows if necessary
8042 IF(MROW.NE.IRED) THEN
8043 DO JBIN=1,NBIN
8044 TMPE=WTMAT(IRED,JBIN)
8045 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8046 WTMAT(MROW,JBIN)=TMPE
8047 ENDDO
8048 TMPE=WTREL(IRED)
8049 WTREL(IRED)=WTREL(MROW)
8050 WTREL(MROW)=TMPE
8051 MTMP=IQ(IRED)
8052 IQ(IRED)=IQ(MROW)
8053 IQ(MROW)=MTMP
8054 ENDIF
8055C...Swap columns if necessary
8056 IF(MCOL.NE.IRED) THEN
8057 DO JBIN=1,NBIN
8058 TMPE=WTMAT(JBIN,IRED)
8059 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8060 WTMAT(JBIN,MCOL)=TMPE
8061 ENDDO
8062 MTMP=IP(IRED)
8063 IP(IRED)=IP(MCOL)
8064 IP(MCOL)=MTMP
8065 ENDIF
8066C...Begin eliminating equations
8067 DO 220 IBIN=IRED+1,NBIN
8068 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8069 MSOLV=0
8070 GOTO 260
8071 ENDIF
8072C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8073 RQTU=WTMAT(IBIN,IRED)
8074 RQTL=WTMAT(IRED,IRED)
8075C...Switch order of operations
8076 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8077 $ (WTREL(IRED)/RQTL)
8078 DO 210 ICOE=IRED,NBIN
8079 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8080 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8081 210 CONTINUE
8082 220 CONTINUE
8083 230 CONTINUE
8084 DO 250 IRED=NBIN,1,-1
8085 DO 240 ICOE=IRED+1,NBIN
8086 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8087 240 CONTINUE
8088 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8089 MSOLV=0
8090 GOTO 260
8091 ENDIF
8092 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8093 TEMPC(IRED)=COEFU(IRED)
8094 250 CONTINUE
8095C...Return to original order
8096 DO IBIN=1,NBIN
8097 MTMP=IP(IBIN)
8098 COEFU(MTMP)=TEMPC(IBIN)
8099 ENDDO
8100 ENDIF
8101
8102C...Share evenly if failure.
8103 260 IF(MSOLV.EQ.0) THEN
8104 DO 270 IBIN=1,NBIN
8105 COEFU(IBIN)=1D0
8106 WTRELN(IBIN)=0.1D0
8107 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8108 & WTRSAV(IBIN)/WTRELS)
8109 270 CONTINUE
8110 ENDIF
8111
8112C...Normalize coefficients, with piece shared democratically.
8113 COEFSU=0D0
8114 WTRELS=0D0
8115 DO 280 IBIN=1,NBIN
8116 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8117 COEFSU=COEFSU+COEFU(IBIN)
8118 WTRELS=WTRELS+WTRELN(IBIN)
8119 280 CONTINUE
8120 IF(COEFSU.GT.0D0) THEN
8121 DO 290 IBIN=1,NBIN
8122 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8123 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8124 290 CONTINUE
8125 ELSE
8126 DO 300 IBIN=1,NBIN
8127 COEFO(IBIN)=1D0/NBIN
8128 300 CONTINUE
8129 ENDIF
8130 IF(IVAR.EQ.1) IOFF=0
8131 IF(IVAR.EQ.2) IOFF=17
8132 IF(IVAR.EQ.3) IOFF=7
8133 IF(IVAR.EQ.4) IOFF=12
8134 DO 310 IBIN=1,NBIN
8135 ICOF=IOFF+IBIN
8136 IF(IVAR.EQ.1) THEN
8137 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8138 ICOF=7
8139 ENDIF
8140 ENDIF
8141 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8142 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8143 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8144 ELSE
8145 COEF(ISUB,ICOF)=COEFO(IBIN)
8146 ENDIF
8147 310 CONTINUE
8148
8149 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8150 & (COEFO(IBIN),IBIN=1,NBIN)
8151
8152 320 CONTINUE
8153
8154C...Find two most promising maxima among points previously determined.
8155 DO 330 J=1,4
8156 IACCMX(J)=0
8157 SIGSMX(J)=0D0
8158 330 CONTINUE
8159 NMAX=0
8160 DO 390 IACC=1,NACC
8161 DO 340 J=1,30
8162 VINT(10+J)=VINTPT(IACC,J)
8163 340 CONTINUE
8164 IF(ISTSB.NE.5) THEN
8165 CALL PYSIGH(NCHN,SIGS)
8166 IF(MWTXS.EQ.1) THEN
8167 CALL PYEVWT(WTXS)
8168 SIGS=WTXS*SIGS
8169 ENDIF
8170 ELSE
8171 SIGS=0D0
8172 DO 350 IKIN3=1,MSTP(129)
8173 CALL PYKMAP(5,0,0D0)
8174 IF(MINT(51).EQ.1) GOTO 350
8175 CALL PYSIGH(NCHN,SIGTMP)
8176 IF(MWTXS.EQ.1) THEN
8177 CALL PYEVWT(WTXS)
8178 SIGTMP=WTXS*SIGTMP
8179 ENDIF
8180 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8181 350 CONTINUE
8182 ENDIF
8183 IEQ=0
8184 DO 360 IMV=1,NMAX
8185 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8186 360 CONTINUE
8187 IF(IEQ.EQ.0) THEN
8188 DO 370 IMV=NMAX,1,-1
8189 IIN=IMV+1
8190 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8191 IACCMX(IMV+1)=IACCMX(IMV)
8192 SIGSMX(IMV+1)=SIGSMX(IMV)
8193 370 CONTINUE
8194 IIN=1
8195 380 IACCMX(IIN)=IACC
8196 SIGSMX(IIN)=SIGS
8197 IF(NMAX.LE.1) NMAX=NMAX+1
8198 ENDIF
8199 390 CONTINUE
8200
8201C...Read out starting position for search.
8202 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8203 SIGSAM=SIGSMX(1)
8204 DO 440 IMAX=1,NMAX
8205 IACC=IACCMX(IMAX)
8206 MTAU=MVARPT(IACC,1)
8207 MTAUP=MVARPT(IACC,2)
8208 MYST=MVARPT(IACC,3)
8209 MCTH=MVARPT(IACC,4)
8210 VTAU=0.5D0
8211 VYST=0.5D0
8212 VCTH=0.5D0
8213 VTAUP=0.5D0
8214
8215C...Starting point and step size in parameter space.
8216 DO 430 IRPT=1,2
8217 DO 420 IVAR=1,4
8218 IF(NPTS(IVAR).EQ.1) GOTO 420
8219 IF(IVAR.EQ.1) VVAR=VTAU
8220 IF(IVAR.EQ.2) VVAR=VTAUP
8221 IF(IVAR.EQ.3) VVAR=VYST
8222 IF(IVAR.EQ.4) VVAR=VCTH
8223 IF(IVAR.EQ.1) MVAR=MTAU
8224 IF(IVAR.EQ.2) MVAR=MTAUP
8225 IF(IVAR.EQ.3) MVAR=MYST
8226 IF(IVAR.EQ.4) MVAR=MCTH
8227 IF(IRPT.EQ.1) VDEL=0.1D0
8228 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8229 & 0.98D0-VVAR))
8230 IF(IRPT.EQ.1) VMAR=0.02D0
8231 IF(IRPT.EQ.2) VMAR=0.002D0
8232 IMOV0=1
8233 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8234 DO 410 IMOV=IMOV0,8
8235
8236C...Define new point in parameter space.
8237 IF(IMOV.EQ.0) THEN
8238 INEW=2
8239 VNEW=VVAR
8240 ELSEIF(IMOV.EQ.1) THEN
8241 INEW=3
8242 VNEW=VVAR+VDEL
8243 ELSEIF(IMOV.EQ.2) THEN
8244 INEW=1
8245 VNEW=VVAR-VDEL
8246 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8247 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8248 VVAR=VVAR+VDEL
8249 SIGSSM(1)=SIGSSM(2)
8250 SIGSSM(2)=SIGSSM(3)
8251 INEW=3
8252 VNEW=VVAR+VDEL
8253 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8254 & VVAR-2D0*VDEL.GT.VMAR) THEN
8255 VVAR=VVAR-VDEL
8256 SIGSSM(3)=SIGSSM(2)
8257 SIGSSM(2)=SIGSSM(1)
8258 INEW=1
8259 VNEW=VVAR-VDEL
8260 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8261 VDEL=0.5D0*VDEL
8262 VVAR=VVAR+VDEL
8263 SIGSSM(1)=SIGSSM(2)
8264 INEW=2
8265 VNEW=VVAR
8266 ELSE
8267 VDEL=0.5D0*VDEL
8268 VVAR=VVAR-VDEL
8269 SIGSSM(3)=SIGSSM(2)
8270 INEW=2
8271 VNEW=VVAR
8272 ENDIF
8273
8274C...Convert to relevant variables and find derived new limits.
8275 ILERR=0
8276 IF(IVAR.EQ.1) THEN
8277 VTAU=VNEW
8278 CALL PYKMAP(1,MTAU,VTAU)
8279 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8280 CALL PYKLIM(4)
8281 IF(MINT(51).EQ.1) ILERR=1
8282 ENDIF
8283 ENDIF
8284 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8285 & ILERR.EQ.0) THEN
8286 IF(IVAR.EQ.2) VTAUP=VNEW
8287 CALL PYKMAP(4,MTAUP,VTAUP)
8288 ENDIF
8289 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8290 CALL PYKLIM(2)
8291 IF(MINT(51).EQ.1) ILERR=1
8292 ENDIF
8293 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8294 IF(IVAR.EQ.3) VYST=VNEW
8295 CALL PYKMAP(2,MYST,VYST)
8296 CALL PYKLIM(3)
8297 IF(MINT(51).EQ.1) ILERR=1
8298 ENDIF
8299 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8300 & ILERR.EQ.0) THEN
8301 IF(IVAR.EQ.4) VCTH=VNEW
8302 CALL PYKMAP(3,MCTH,VCTH)
8303 ENDIF
8304 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8305
8306C...Evaluate cross-section. Save new maximum. Final maximum.
8307 IF(ILERR.NE.0) THEN
8308 SIGS=0.
8309 ELSEIF(ISTSB.NE.5) THEN
8310 CALL PYSIGH(NCHN,SIGS)
8311 IF(MWTXS.EQ.1) THEN
8312 CALL PYEVWT(WTXS)
8313 SIGS=WTXS*SIGS
8314 ENDIF
8315 ELSE
8316 SIGS=0D0
8317 DO 400 IKIN3=1,MSTP(129)
8318 CALL PYKMAP(5,0,0D0)
8319 IF(MINT(51).EQ.1) GOTO 400
8320 CALL PYSIGH(NCHN,SIGTMP)
8321 IF(MWTXS.EQ.1) THEN
8322 CALL PYEVWT(WTXS)
8323 SIGTMP=WTXS*SIGTMP
8324 ENDIF
8325 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8326 400 CONTINUE
8327 ENDIF
8328 SIGSSM(INEW)=SIGS
8329 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8330 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8331 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8332 410 CONTINUE
8333 420 CONTINUE
8334 430 CONTINUE
8335 440 CONTINUE
8336 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8337 XSEC(ISUB,1)=1.05D0*SIGSAM
8338C...Add extra headroom for UED
8339 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8340 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8341 & WTGAGA*XSEC(ISUB,1)
8342 450 CONTINUE
8343 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8344 & PARP(174)*XSEC(ISUB,1)
8345 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8346 460 CONTINUE
8347 MINT(51)=0
8348
8349C...Print summary table.
8350 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8351 IF(MSTP(127).NE.1) THEN
8352 WRITE(MSTU(11),5900)
8353 CALL PYSTOP(1)
8354 ELSE
8355 WRITE(MSTU(11),6400)
8356 MSTI(53)=1
8357 ENDIF
8358 ENDIF
8359 IF(MSTP(122).GE.1) THEN
8360 WRITE(MSTU(11),6000)
8361 WRITE(MSTU(11),6100)
8362 DO 470 ISUB=1,500
8363 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8364 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8365 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8366 & GOTO 470
8367 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8368 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8369 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8370 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8371 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8372 470 CONTINUE
8373 WRITE(MSTU(11),6300)
8374 ENDIF
8375
8376C...Format statements for maximization results.
8377 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8378 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8379 &'cth',9X,'tau''',7X,'sigma')
8380 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8381 &'phase space.'/1X,'Process switched off!')
8382 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8383 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8384 &'cross-section.'/1X,'Process switched off!')
8385 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8386 5500 FORMAT(1X,1P,10D11.3)
8387 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8388 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8389 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8390 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8391 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8392 &'cross-section.'/1X,'Execution stopped!')
8393 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8394 &'cross-section maximum search',1X,8('*'))
8395 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8396 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8397 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8398 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8399 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8400 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8401 &'cross-section.'/
8402 &1X,'Execution will stop if you try to generate events.')
8403
8404 RETURN
8405 END
8406
8407C*********************************************************************
8408
8409C...PYPILE
8410C...Initializes multiplicity distribution and selects mutliplicity
8411C...of pileup events, i.e. several events occuring at the same
8412C...beam crossing.
8413
8414 SUBROUTINE PYPILE(MPILE)
8415
8416C...Double precision and integer declarations.
8417 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8418 IMPLICIT INTEGER(I-N)
8419 INTEGER PYK,PYCHGE,PYCOMP
8420C...Commonblocks.
8421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8422 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8423 COMMON/PYINT1/MINT(400),VINT(400)
8424 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8425 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8426C...Local arrays and saved variables.
8427 DIMENSION WTI(0:200)
8428 SAVE IMIN,IMAX,WTI,WTS
8429
8430C...Sum of allowed cross-sections for pileup events.
8431 IF(MPILE.EQ.1) THEN
8432 VINT(131)=SIGT(0,0,5)
8433 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8434 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8435 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8436 IF(MSTP(133).LE.0) RETURN
8437
8438C...Initialize multiplicity distribution at maximum.
8439 XNAVE=VINT(131)*PARP(131)
8440 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8441 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8442 WTI(INAVE)=1D0
8443 WTS=WTI(INAVE)
8444 WTN=WTI(INAVE)*INAVE
8445
8446C...Find shape of multiplicity distribution below maximum.
8447 IMIN=INAVE
8448 DO 100 I=INAVE-1,1,-1
8449 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8450 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8451 IF(WTI(I).LT.1D-6) GOTO 110
8452 WTS=WTS+WTI(I)
8453 WTN=WTN+WTI(I)*I
8454 IMIN=I
8455 100 CONTINUE
8456
8457C...Find shape of multiplicity distribution above maximum.
8458 110 IMAX=INAVE
8459 DO 120 I=INAVE+1,200
8460 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8461 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8462 IF(WTI(I).LT.1D-6) GOTO 130
8463 WTS=WTS+WTI(I)
8464 WTN=WTN+WTI(I)*I
8465 IMAX=I
8466 120 CONTINUE
8467 130 VINT(132)=XNAVE
8468 VINT(133)=WTN/WTS
8469 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8470 & WTS/(WTS+WTI(1)/XNAVE)
8471 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8472 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8473
8474C...Pick multiplicity of pileup events.
8475 ELSE
8476 IF(MSTP(133).LE.0) THEN
8477 MINT(81)=MAX(1,MSTP(134))
8478 ELSE
8479 WTR=WTS*PYR(0)
8480 DO 140 I=IMIN,IMAX
8481 MINT(81)=I
8482 WTR=WTR-WTI(I)
8483 IF(WTR.LE.0D0) GOTO 150
8484 140 CONTINUE
8485 150 CONTINUE
8486 ENDIF
8487 ENDIF
8488
8489C...Format statement for error message.
8490 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8491 &'crossing too large, ',1P,D12.4)
8492
8493 RETURN
8494 END
8495
8496C*********************************************************************
8497
8498C...PYSAVE
8499C...Saves and restores parameter and cross section values for the
8500C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8501C...Also makes random choice between alternatives.
8502
8503 SUBROUTINE PYSAVE(ISAVE,IGA)
8504
8505C...Double precision and integer declarations.
8506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8507 IMPLICIT INTEGER(I-N)
8508 INTEGER PYK,PYCHGE,PYCOMP
8509C...Commonblocks.
8510 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8512 COMMON/PYINT1/MINT(400),VINT(400)
8513 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8514 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8515 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8516 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8517C...Local arrays and saved variables.
8518 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8519 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8520 &INTCP(15,20),RECP(15,20)
8521 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8522
8523C...Save list of subprocesses and cross-section information.
8524 IF(ISAVE.EQ.1) THEN
8525 ICP=0
8526 DO 120 I=1,500
8527 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8528 ICP=ICP+1
8529 NSUBCP(IGA,ICP)=I
8530 MSUBCP(IGA,ICP)=MSUB(I)
8531 DO 100 J=1,20
8532 COEFCP(IGA,ICP,J)=COEF(I,J)
8533 100 CONTINUE
8534 DO 110 J=1,3
8535 NGENCP(IGA,ICP,J)=NGEN(I,J)
8536 XSECCP(IGA,ICP,J)=XSEC(I,J)
8537 110 CONTINUE
8538 120 CONTINUE
8539 NCP(IGA)=ICP
8540 DO 130 J=1,3
8541 NGENCP(IGA,0,J)=NGEN(0,J)
8542 XSECCP(IGA,0,J)=XSEC(0,J)
8543 130 CONTINUE
8544 DO 160 I1=0,6
8545 DO 150 I2=0,6
8546 DO 140 J=0,5
8547 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8548 140 CONTINUE
8549 150 CONTINUE
8550 160 CONTINUE
8551
8552C...Save various common process variables.
8553 DO 170 J=1,10
8554 INTCP(IGA,J)=MINT(40+J)
8555 170 CONTINUE
8556 INTCP(IGA,11)=MINT(101)
8557 INTCP(IGA,12)=MINT(102)
8558 INTCP(IGA,13)=MINT(107)
8559 INTCP(IGA,14)=MINT(108)
8560 INTCP(IGA,15)=MINT(123)
8561 RECP(IGA,1)=CKIN(3)
8562 RECP(IGA,2)=VINT(318)
8563
8564C...Save cross-section information only.
8565 ELSEIF(ISAVE.EQ.2) THEN
8566 DO 190 ICP=1,NCP(IGA)
8567 I=NSUBCP(IGA,ICP)
8568 DO 180 J=1,3
8569 NGENCP(IGA,ICP,J)=NGEN(I,J)
8570 XSECCP(IGA,ICP,J)=XSEC(I,J)
8571 180 CONTINUE
8572 190 CONTINUE
8573 DO 200 J=1,3
8574 NGENCP(IGA,0,J)=NGEN(0,J)
8575 XSECCP(IGA,0,J)=XSEC(0,J)
8576 200 CONTINUE
8577
8578C...Choose between allowed alternatives.
8579 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8580 IF(ISAVE.EQ.4) THEN
8581 XSUMCP=0D0
8582 DO 210 IG=1,MINT(121)
8583 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8584 210 CONTINUE
8585 XSUMCP=XSUMCP*PYR(0)
8586 DO 220 IG=1,MINT(121)
8587 IGA=IG
8588 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8589 IF(XSUMCP.LE.0D0) GOTO 230
8590 220 CONTINUE
8591 230 CONTINUE
8592 ENDIF
8593
8594C...Restore cross-section information.
8595 DO 240 I=1,500
8596 MSUB(I)=0
8597 240 CONTINUE
8598 DO 270 ICP=1,NCP(IGA)
8599 I=NSUBCP(IGA,ICP)
8600 MSUB(I)=MSUBCP(IGA,ICP)
8601 DO 250 J=1,20
8602 COEF(I,J)=COEFCP(IGA,ICP,J)
8603 250 CONTINUE
8604 DO 260 J=1,3
8605 NGEN(I,J)=NGENCP(IGA,ICP,J)
8606 XSEC(I,J)=XSECCP(IGA,ICP,J)
8607 260 CONTINUE
8608 270 CONTINUE
8609 DO 280 J=1,3
8610 NGEN(0,J)=NGENCP(IGA,0,J)
8611 XSEC(0,J)=XSECCP(IGA,0,J)
8612 280 CONTINUE
8613 DO 310 I1=0,6
8614 DO 300 I2=0,6
8615 DO 290 J=0,5
8616 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8617 290 CONTINUE
8618 300 CONTINUE
8619 310 CONTINUE
8620
8621C...Restore various common process variables.
8622 DO 320 J=1,10
8623 MINT(40+J)=INTCP(IGA,J)
8624 320 CONTINUE
8625 MINT(101)=INTCP(IGA,11)
8626 MINT(102)=INTCP(IGA,12)
8627 MINT(107)=INTCP(IGA,13)
8628 MINT(108)=INTCP(IGA,14)
8629 MINT(123)=INTCP(IGA,15)
8630 CKIN(3)=RECP(IGA,1)
8631 CKIN(1)=2D0*CKIN(3)
8632 VINT(318)=RECP(IGA,2)
8633
8634C...Sum up cross-section info (for PYSTAT).
8635 ELSEIF(ISAVE.EQ.5) THEN
8636 DO 330 I=1,500
8637 MSUB(I)=0
8638 NGEN(I,1)=0
8639 NGEN(I,3)=0
8640 XSEC(I,3)=0D0
8641 330 CONTINUE
8642 NGEN(0,1)=0
8643 NGEN(0,2)=0
8644 NGEN(0,3)=0
8645 XSEC(0,3)=0
8646 DO 350 IG=1,MINT(121)
8647 DO 340 ICP=1,NCP(IG)
8648 I=NSUBCP(IG,ICP)
8649 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8650 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8651 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8652 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8653 340 CONTINUE
8654 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8655 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8656 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8657 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8658 350 CONTINUE
8659 ENDIF
8660
8661 RETURN
8662 END
8663
8664C*********************************************************************
8665
8666C...PYGAGA
8667C...For lepton beams it gives photon-hadron or photon-photon systems
8668C...to be treated with the ordinary machinery and combines this with a
8669C...description of the lepton -> lepton + photon branching.
8670
8671 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8672
8673C...Double precision and integer declarations.
8674 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8675 IMPLICIT INTEGER(I-N)
8676 INTEGER PYK,PYCHGE,PYCOMP
8677C...Commonblocks.
8678 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8679 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8680 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8681 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8682 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8683 COMMON/PYINT1/MINT(400),VINT(400)
8684 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8685 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8686 &/PYINT5/
8687C...Local variables and data statement.
8688 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8689 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8690 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8691 DATA EPS/1D-4/
8692
8693C...Initialize generation of photons inside leptons.
8694 IF(IGAGA.EQ.1) THEN
8695
8696C...Save quantities on incoming lepton system.
8697 VINT(301)=VINT(1)
8698 VINT(302)=VINT(2)
8699 PMS(1)=VINT(303)**2
8700 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8701 PMS(2)=VINT(304)**2
8702 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8703 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8704 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8705
8706C...Calculate range of x and Q2 values allowed in generation.
8707 DO 100 I=1,2
8708 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8709 IF(MINT(140+I).NE.0) THEN
8710 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8711 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8712 & PMC(I),1D0-EPS)
8713 YMIN=MAX(CKIN(71+2*I),EPS)
8714 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8715 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8716 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8717 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8718 THEMIN=MAX(CKIN(67+2*I),0D0)
8719 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8720 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8721 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8722 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8723 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8724 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8725 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8726 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8727 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8728C...W limits when lepton on one side only.
8729 IF(MINT(143-I).EQ.0) THEN
8730 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8731 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8732 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8733 ENDIF
8734 ENDIF
8735 100 CONTINUE
8736
8737C...W limits when lepton on both sides.
8738 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8739 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8740 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8741 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8742 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8743 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8744 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8745 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8746 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8747 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8748 ELSE
8749 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8750 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8751 ENDIF
8752 ENDIF
8753
8754C...Q2 and W values and photon flux weight factors for initialization.
8755 ELSEIF(IGAGA.EQ.2) THEN
8756 ISUB=MINT(1)
8757 MINT(15)=0
8758 MINT(16)=0
8759
8760C...W value for photon on one or both sides, and for processes
8761C...with gamma-gamma cross section peaked at small shat.
8762 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8763 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8764 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8765 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8766 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8767 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8768 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8769 ELSE
8770 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8771 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8772 ENDIF
8773 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8774
8775C...Upper estimate of photon flux weight factor.
8776C...Initialization Q2 scale. Flag incoming unresolved photon.
8777 WTGAGA=1D0
8778 DO 110 I=1,2
8779 IF(MINT(140+I).NE.0) THEN
8780 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8781 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8782 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8783 & THEN
8784 Q2INIT=5D0+Q2MIN(3-I)
8785 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8786 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8787 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8788 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8789 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8790 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8791 Q2INIT=VINT(2)/3D0
8792 ELSEIF(ISUB.EQ.140) THEN
8793 Q2INIT=VINT(2)/2D0
8794 ELSE
8795 Q2INIT=Q2MIN(I)
8796 ENDIF
8797 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8798 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8799 & MINT(14+I)=22
8800 VINT(306+I)=VINT(2+I)**2
8801 ENDIF
8802 110 CONTINUE
8803 VINT(320)=WTGAGA
8804
8805C...Update pTmin and cross section information.
8806 IF(MSTP(82).LE.1) THEN
8807 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8808 ELSE
8809 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8810 ENDIF
8811 VINT(149)=4D0*PTMN**2/VINT(2)
8812 VINT(154)=PTMN
8813 CALL PYXTOT
8814 VINT(318)=VINT(317)
8815
8816C...Generate photons inside leptons and
8817C...calculate photon flux weight factors.
8818 ELSEIF(IGAGA.EQ.3) THEN
8819 ISUB=MINT(1)
8820 MINT(15)=0
8821 MINT(16)=0
8822
8823C...Generate phase space point and check against cuts.
8824 LOOP=0
8825 120 LOOP=LOOP+1
8826 DO 130 I=1,2
8827 IF(MINT(140+I).NE.0) THEN
8828C...Pick x and Q2
8829 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8830 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8831C...Cuts on internal consistency in x and Q2.
8832 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8833 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8834 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8835C...Cuts on y and theta.
8836 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8837 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8838 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8839 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8840 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8841 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8842 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8843 & GOTO 120
8844
8845C...Phi angle isotropic. Reconstruct pT.
8846 PHI(I)=PARU(2)*PYR(0)
8847 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8848 & PMS(I))*SIN(THETA(I))
8849
8850C...Store info on variables selected, for documentation purposes.
8851 VINT(2+I)=-SQRT(Q2(I))
8852 VINT(304+I)=X(I)
8853 VINT(306+I)=Q2(I)
8854 VINT(308+I)=Y(I)
8855 VINT(310+I)=THETA(I)
8856 VINT(312+I)=PHI(I)
8857 ELSE
8858 VINT(304+I)=1D0
8859 VINT(306+I)=0D0
8860 VINT(308+I)=1D0
8861 VINT(310+I)=0D0
8862 VINT(312+I)=0D0
8863 ENDIF
8864 130 CONTINUE
8865
8866C...Cut on W combines info from two sides.
8867 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8868 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8869 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8870 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8871 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8872 IF(W2.LT.W2MIN) GOTO 120
8873 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8874 PMS1=-Q2(1)
8875 PMS2=-Q2(2)
8876 ELSEIF(MINT(141).NE.0) THEN
8877 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8878 PMS1=-Q2(1)
8879 PMS2=PMS(2)
8880 ELSEIF(MINT(142).NE.0) THEN
8881 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8882 PMS1=PMS(1)
8883 PMS2=-Q2(2)
8884 ENDIF
8885
8886C...Store kinematics info for photon(s) in subsystem cm frame.
8887 VINT(2)=W2
8888 VINT(1)=SQRT(W2)
8889 VINT(291)=0D0
8890 VINT(292)=0D0
8891 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8892 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8893 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8894 VINT(296)=0D0
8895 VINT(297)=0D0
8896 VINT(298)=-VINT(293)
8897 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8898 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8899
8900C...Assign weight for photon flux; different for transverse and
8901C...longitudinal photons. Flag incoming unresolved photon.
8902 WTGAGA=1D0
8903 DO 140 I=1,2
8904 IF(MINT(140+I).NE.0) THEN
8905 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8906 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8907 IF(MSTP(16).EQ.0) THEN
8908 XY=X(I)
8909 ELSE
8910 WTGAGA=WTGAGA*X(I)/Y(I)
8911 XY=Y(I)
8912 ENDIF
8913 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8914 WTGAGA=WTGAGA*(1D0-XY)
8915 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
8916 WTGAGA=WTGAGA*(1D0-XY)
8917 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
8918 WTGAGA=WTGAGA*(1D0-XY)
8919 ELSE
8920 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
8921 & PMS(I)*XY**2/Q2(I))
8922 ENDIF
8923 IF(MINT(106+I).EQ.0) MINT(14+I)=22
8924 ENDIF
8925 140 CONTINUE
8926 VINT(319)=WTGAGA
8927 MINT(143)=LOOP
8928
8929C...Update pTmin and cross section information.
8930 IF(MSTP(82).LE.1) THEN
8931 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8932 ELSE
8933 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8934 ENDIF
8935 VINT(149)=4D0*PTMN**2/VINT(2)
8936 VINT(154)=PTMN
8937 CALL PYXTOT
8938
8939C...Reconstruct kinematics of photons inside leptons.
8940 ELSEIF(IGAGA.EQ.4) THEN
8941
8942C...Make place for incoming particles and scattered leptons.
8943 MOVE=3
8944 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
8945 MINT(4)=MINT(4)+MOVE
8946 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
8947 IF(K(I,1).EQ.21) THEN
8948 DO 150 J=1,5
8949 K(I+MOVE,J)=K(I,J)
8950 P(I+MOVE,J)=P(I,J)
8951 V(I+MOVE,J)=V(I,J)
8952 150 CONTINUE
8953 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8954 & K(I+MOVE,3)=K(I,3)+MOVE
8955 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
8956 & K(I+MOVE,4)=K(I,4)+MOVE
8957 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
8958 & K(I+MOVE,5)=K(I,5)+MOVE
8959 ENDIF
8960 160 CONTINUE
8961 DO 170 I=MINT(84)+1,N
8962 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
8963 & K(I,3)=K(I,3)+MOVE
8964 170 CONTINUE
8965
8966C...Fill in incoming particles.
8967 DO 190 I=MINT(83)+1,MINT(83)+MOVE
8968 DO 180 J=1,5
8969 K(I,J)=0
8970 P(I,J)=0D0
8971 V(I,J)=0D0
8972 180 CONTINUE
8973 190 CONTINUE
8974 DO 200 I=1,2
8975 K(MINT(83)+I,1)=21
8976 IF(MINT(140+I).NE.0) THEN
8977 K(MINT(83)+I,2)=MINT(140+I)
8978 P(MINT(83)+I,5)=VINT(302+I)
8979 ELSE
8980 K(MINT(83)+I,2)=MINT(10+I)
8981 P(MINT(83)+I,5)=VINT(2+I)
8982 ENDIF
8983 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
8984 & VINT(302))*(-1D0)**(I+1)
8985 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
8986 200 CONTINUE
8987
8988C...New mother-daughter relations in documentation section.
8989 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8990 K(MINT(83)+1,4)=MINT(83)+3
8991 K(MINT(83)+1,5)=MINT(83)+5
8992 K(MINT(83)+2,4)=MINT(83)+4
8993 K(MINT(83)+2,5)=MINT(83)+6
8994 K(MINT(83)+3,3)=MINT(83)+1
8995 K(MINT(83)+5,3)=MINT(83)+1
8996 K(MINT(83)+4,3)=MINT(83)+2
8997 K(MINT(83)+6,3)=MINT(83)+2
8998 ELSEIF(MINT(141).NE.0) THEN
8999 K(MINT(83)+1,4)=MINT(83)+3
9000 K(MINT(83)+1,5)=MINT(83)+4
9001 K(MINT(83)+2,4)=MINT(83)+5
9002 K(MINT(83)+3,3)=MINT(83)+1
9003 K(MINT(83)+4,3)=MINT(83)+1
9004 K(MINT(83)+5,3)=MINT(83)+2
9005 ELSEIF(MINT(142).NE.0) THEN
9006 K(MINT(83)+1,4)=MINT(83)+4
9007 K(MINT(83)+2,4)=MINT(83)+3
9008 K(MINT(83)+2,5)=MINT(83)+5
9009 K(MINT(83)+3,3)=MINT(83)+2
9010 K(MINT(83)+4,3)=MINT(83)+1
9011 K(MINT(83)+5,3)=MINT(83)+2
9012 ENDIF
9013
9014C...Fill scattered lepton(s).
9015 DO 210 I=1,2
9016 IF(MINT(140+I).NE.0) THEN
9017 LSC=MINT(83)+MIN(I+2,MOVE)
9018 K(LSC,1)=21
9019 K(LSC,2)=MINT(140+I)
9020 P(LSC,1)=PT(I)*COS(PHI(I))
9021 P(LSC,2)=PT(I)*SIN(PHI(I))
9022 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9023 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9024 & (-1D0)**(I-1)
9025 P(LSC,5)=VINT(302+I)
9026 ENDIF
9027 210 CONTINUE
9028
9029C...Find incoming four-vectors to subprocess.
9030 K(N+1,1)=21
9031 IF(MINT(141).NE.0) THEN
9032 DO 220 J=1,4
9033 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9034 220 CONTINUE
9035 ELSE
9036 DO 230 J=1,4
9037 P(N+1,J)=P(MINT(83)+1,J)
9038 230 CONTINUE
9039 ENDIF
9040 K(N+2,1)=21
9041 IF(MINT(142).NE.0) THEN
9042 DO 240 J=1,4
9043 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9044 240 CONTINUE
9045 ELSE
9046 DO 250 J=1,4
9047 P(N+2,J)=P(MINT(83)+2,J)
9048 250 CONTINUE
9049 ENDIF
9050
9051C...Define boost and rotation between hadronic subsystem and
9052C...collision rest frame; boost hadronic subsystem to this frame.
9053 DO 260 J=1,3
9054 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9055 260 CONTINUE
9056 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9057 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9058 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9059 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9060 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9061 & BETA(3))
9062
9063C...Add on scattered leptons to final state.
9064 DO 280 I=1,2
9065 IF(MINT(140+I).NE.0) THEN
9066 LSC=MINT(83)+MIN(I+2,MOVE)
9067 N=N+1
9068 DO 270 J=1,5
9069 K(N,J)=K(LSC,J)
9070 P(N,J)=P(LSC,J)
9071 V(N,J)=V(LSC,J)
9072 270 CONTINUE
9073 K(N,1)=1
9074 K(N,3)=LSC
9075 ENDIF
9076 280 CONTINUE
9077 ENDIF
9078
9079 RETURN
9080 END
9081
9082C*********************************************************************
9083
9084C...PYRAND
9085C...Generates quantities characterizing the high-pT scattering at the
9086C...parton level according to the matrix elements. Chooses incoming,
9087C...reacting partons, their momentum fractions and one of the possible
9088C...subprocesses.
9089
9090 SUBROUTINE PYRAND
9091
9092C...Double precision and integer declarations.
9093 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9094 IMPLICIT INTEGER(I-N)
9095 INTEGER PYK,PYCHGE,PYCOMP
9096C...Parameter statement to help give large particle numbers.
9097 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9098 &KEXCIT=4000000,KDIMEN=5000000)
9099
9100C...User process initialization and event commonblocks.
9101 INTEGER MAXPUP
9102 PARAMETER (MAXPUP=100)
9103 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9104 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9105 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9106 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9107 &LPRUP(MAXPUP)
9108 INTEGER MAXNUP
9109 PARAMETER (MAXNUP=500)
9110 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9111 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9112 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9113 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9114 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9115 SAVE /HEPRUP/,/HEPEUP/
9116
9117C...Commonblocks.
9118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9120 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9121 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9122 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9123 COMMON/PYINT1/MINT(400),VINT(400)
9124 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9125 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9126 COMMON/PYINT4/MWID(500),WIDS(500,5)
9127 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9128 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9129 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9130 COMMON/PYTCCO/COEFX(194:380,2)
9131 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9132 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9133 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9134 &/TCPARA/
9135C...Local arrays.
9136 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9137
9138C...Parameters and data used in elastic/diffractive treatment.
9139 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9140 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9141
9142C...Initial values, specifically for (first) semihard interaction.
9143 MINT(10)=0
9144 MINT(17)=0
9145 MINT(18)=0
9146 VINT(143)=1D0
9147 VINT(144)=1D0
9148 VINT(157)=0D0
9149 VINT(158)=0D0
9150 MFAIL=0
9151 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9152 ISUB=0
9153 ISTSB=0
9154 LOOP=0
9155 100 LOOP=LOOP+1
9156 MINT(51)=0
9157 MINT(143)=1
9158 VINT(97)=1D0
9159
9160C...Start by assuming incoming photon is entering subprocess.
9161 IF(MINT(11).EQ.22) THEN
9162 MINT(15)=22
9163 VINT(307)=VINT(3)**2
9164 ENDIF
9165 IF(MINT(12).EQ.22) THEN
9166 MINT(16)=22
9167 VINT(308)=VINT(4)**2
9168 ENDIF
9169 MINT(103)=MINT(11)
9170 MINT(104)=MINT(12)
9171
9172C...Choice of process type - first event of pileup.
9173 INMULT=0
9174 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9175 ELSEIF(MINT(82).EQ.1) THEN
9176
9177C...For gamma-p or gamma-gamma first pick between alternatives.
9178 IGA=0
9179 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9180 MINT(122)=IGA
9181
9182C...For real gamma + gamma with different nature, flip at random.
9183 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9184 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9185 MINTSV=MINT(41)
9186 MINT(41)=MINT(42)
9187 MINT(42)=MINTSV
9188 MINTSV=MINT(45)
9189 MINT(45)=MINT(46)
9190 MINT(46)=MINTSV
9191 MINTSV=MINT(107)
9192 MINT(107)=MINT(108)
9193 MINT(108)=MINTSV
9194 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9195 ENDIF
9196
9197C...Pick process type, possibly by user process machinery.
9198C...(If the latter, also event will be picked here.)
9199 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9200 CALL UPEVNT
9201 CALL PYUPRE
9202 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9203 CALL UPEVNT
9204 CALL PYUPRE
9205 ISUB=0
9206 110 ISUB=ISUB+1
9207 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9208 & ISUB.LT.500) GOTO 110
9209 ELSE
9210 RSUB=XSEC(0,1)*PYR(0)
9211 DO 120 I=1,500
9212 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9213 ISUB=I
9214 RSUB=RSUB-XSEC(I,1)
9215 IF(RSUB.LE.0D0) GOTO 130
9216 120 CONTINUE
9217 130 IF(ISUB.EQ.95) ISUB=96
9218 IF(ISUB.EQ.96) INMULT=1
9219 IF(ISET(ISUB).EQ.11) THEN
9220 IDPRUP=KFPR(ISUB,2)
9221 CALL UPEVNT
9222 CALL PYUPRE
9223 ENDIF
9224 ENDIF
9225
9226C...Choice of inclusive process type - pileup events.
9227 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9228 RSUB=VINT(131)*PYR(0)
9229 ISUB=96
9230 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9231 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9232 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9233 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9234 & ISUB=91
9235 IF(ISUB.EQ.96) INMULT=1
9236 ENDIF
9237
9238C...Choice of photon energy and flux factor inside lepton.
9239 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9240 CALL PYGAGA(3,WTGAGA)
9241 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9242 CKIN(3)=MAX(VINT(285),VINT(154))
9243 CKIN(1)=2D0*CKIN(3)
9244 ENDIF
9245C...When necessary set direct/resolved photon by hand.
9246 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9247 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9248 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9249 ENDIF
9250
9251C...Restrict direct*resolved processes to pTmin >= Q,
9252C...to avoid doublecounting with DIS.
9253 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9254 IF(MINT(15).EQ.22) THEN
9255 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9256 ELSE
9257 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9258 ENDIF
9259 CKIN(1)=2D0*CKIN(3)
9260 ENDIF
9261
9262C...Set up for multiple interactions (may include impact parameter).
9263 IF(INMULT.EQ.1) THEN
9264 IF(MINT(35).LE.1) CALL PYMULT(2)
9265 IF(MINT(35).GE.2) CALL PYMIGN(2)
9266 ENDIF
9267
9268C...Loopback point for minimum bias in photon physics.
9269 LOOP2=0
9270 140 LOOP2=LOOP2+1
9271 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9272 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9273 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9274 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9275 MINT(1)=ISUB
9276 ISTSB=ISET(ISUB)
9277
9278C...Random choice of flavour for some SUSY processes.
9279 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9280C...~e_L ~nu_e or ~mu_L ~nu_mu.
9281 IF(ISUB.EQ.210) THEN
9282 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9283 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9284C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9285 ELSEIF(ISUB.EQ.213) THEN
9286 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9287 KFPR(ISUB,2)=KFPR(ISUB,1)
9288C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9289 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9290 & ISUB.NE.257) THEN
9291 IF(ISUB.GE.258) THEN
9292 RKF=4D0
9293 ELSE
9294 RKF=5D0
9295 ENDIF
9296 IF(MOD(ISUB,2).EQ.0) THEN
9297 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9298 ELSE
9299 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9300 ENDIF
9301C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9302 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9303 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9304 KSU1=KSUSY1
9305 KSU2=KSUSY1
9306 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9307 KSU1=KSUSY2
9308 KSU2=KSUSY2
9309 ELSEIF(PYR(0).LT.0.5D0) THEN
9310 KSU1=KSUSY1
9311 KSU2=KSUSY2
9312 ELSE
9313 KSU1=KSUSY2
9314 KSU2=KSUSY1
9315 ENDIF
9316 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9317 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9318C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9319 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9320 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9321 KFPR(ISUB,2)=KFPR(ISUB,1)
9322 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9323 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9324 KFPR(ISUB,2)=KFPR(ISUB,1)
9325C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9326 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9327 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9328 KSU1=KSUSY1
9329 KSU2=KSUSY1
9330 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9331 KSU1=KSUSY2
9332 KSU2=KSUSY2
9333 ELSEIF(PYR(0).LT.0.5D0) THEN
9334 KSU1=KSUSY1
9335 KSU2=KSUSY2
9336 ELSE
9337 KSU1=KSUSY2
9338 KSU2=KSUSY1
9339 ENDIF
9340 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9341 RKF=5D0
9342 ELSE
9343 RKF=4D0
9344 ENDIF
9345 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9346 ENDIF
9347 ENDIF
9348
9349C...Random choice of flavours for some UED processes
9350c...The production processes can generate a doublet pair,
9351c...a singlet pair, or a doublet + singlet.
9352 IF(ISUB.EQ.313)THEN
9353C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9354 IF(PYR(0).LE.0.1)THEN
9355 KFPR(ISUB,1)=5100001
9356 ELSE
9357 KFPR(ISUB,1)=5100002
9358 ENDIF
9359 KFPR(ISUB,2)=KFPR(ISUB,1)
9360 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9361C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9362C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9363 IF(PYR(0).LE.0.1)THEN
9364 KFPR(ISUB,1)=5100001
9365 ELSE
9366 KFPR(ISUB,1)=5100002
9367 ENDIF
9368 KFPR(ISUB,2)=-KFPR(ISUB,1)
9369 ELSEIF(ISUB.EQ.316)THEN
9370C...qi + qbarj -> q*_Di + q*_Sbarj
9371 IF(PYR(0).LE.0.5)THEN
9372 KFPR(ISUB,1)=5100001
9373c Changed from private pythia6410_ued code
9374c KFPR(ISUB,2)=-5010001
9375 KFPR(ISUB,2)=-6100002
9376 ELSE
9377 KFPR(ISUB,1)=5100002
9378c Changed from private pythia6410_ued code
9379c KFPR(ISUB,2)=-5010002
9380 KFPR(ISUB,2)=-6100001
9381 ENDIF
9382 ELSEIF(ISUB.EQ.317)THEN
9383C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9384 IF(PYR(0).LE.0.5)THEN
9385 KFPR(ISUB,1)=5100001
9386 KFPR(ISUB,2)=-5100002
9387 ELSE
9388 KFPR(ISUB,1)=5100002
9389 KFPR(ISUB,2)=-5100001
9390 ENDIF
9391 ELSEIF(ISUB.EQ.318)THEN
9392C...qi + qj -> q*_Di + q*_Sj
9393 IF(PYR(0).LE.0.5)THEN
9394 KFPR(ISUB,1)=5100001
9395 KFPR(ISUB,2)=6100002
9396 ELSE
9397 KFPR(ISUB,1)=5100002
9398 KFPR(ISUB,2)=6100001
9399 ENDIF
9400 ENDIF
9401
9402C...Find resonances (explicit or implicit in cross-section).
9403 MINT(72)=0
9404 KFR1=0
9405 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9406 KFR1=KFPR(ISUB,1)
9407 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9408 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9409 KFR1=23
9410 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9411 & ISUB.EQ.177) THEN
9412 KFR1=24
9413 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9414 KFR1=25
9415 IF(MSTP(46).EQ.5) THEN
9416 KFR1=89
9417 PMAS(89,1)=PARP(45)
9418 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9419 ENDIF
9420 ENDIF
9421 CKMX=CKIN(2)
9422 IF(CKMX.LE.0D0) CKMX=VINT(1)
9423 KCR1=PYCOMP(KFR1)
9424 IF(KFR1.NE.0) THEN
9425 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9426 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9427 ENDIF
9428 IF(KFR1.NE.0) THEN
9429 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9430 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9431 MINT(72)=1
9432 MINT(73)=KFR1
9433 VINT(73)=TAUR1
9434 VINT(74)=GAMR1
9435 ENDIF
9436 KFR2=0
9437 KFR3=0
9438 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9439 $(ISUB.GE.361.AND.ISUB.LE.380))
9440 $THEN
9441 KFR2=23
9442 IF(ISUB.EQ.141) THEN
9443 KCR2=PYCOMP(KFR2)
9444 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9445 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9446 KFR2=0
9447 ELSE
9448 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9449 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9450 MINT(72)=2
9451 MINT(74)=KFR2
9452 VINT(75)=TAUR2
9453 VINT(76)=GAMR2
9454 ENDIF
9455C...3 resonances at work: rho, omega, a
9456 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9457 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9458 MINT(72)=IRES
9459 IF(IRES.GE.1) THEN
9460 VINT(73)=XMAS(1)**2/VINT(2)
9461 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9462 TAUR1=VINT(73)
9463 GAMR1=VINT(74)
9464 KFR1=1
9465 ENDIF
9466 IF(IRES.GE.2) THEN
9467 VINT(75)=XMAS(2)**2/VINT(2)
9468 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9469 TAUR2=VINT(75)
9470 GAMR2=VINT(76)
9471 KFR2=2
9472 ENDIF
9473 IF(IRES.EQ.3) THEN
9474 VINT(77)=XMAS(3)**2/VINT(2)
9475 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9476 TAUR3=VINT(77)
9477 GAMR3=VINT(78)
9478 KFR3=3
9479 ENDIF
9480C...Charged current: rho+- and a+-
9481 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9482 MINT(72)=IRES
9483 IF(JRES.GE.1) THEN
9484 VINT(73)=YMAS(1)**2/VINT(2)
9485 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9486 KFR1=1
9487 TAUR1=VINT(73)
9488 GAMR1=VINT(74)
9489 ENDIF
9490 IF(JRES.GE.2) THEN
9491 VINT(75)=YMAS(2)**2/VINT(2)
9492 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9493 KFR2=2
9494 TAUR2=VINT(73)
9495 GAMR2=VINT(74)
9496 ENDIF
9497 KFR3=0
9498 ENDIF
9499 IF(ISUB.NE.141) THEN
9500 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9501
9502 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9503 MINT(72)=2
9504 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9505 MINT(72)=2
9506 MINT(74)=KFR3
9507 VINT(75)=TAUR3
9508 VINT(76)=GAMR3
9509 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9510 MINT(72)=2
9511 MINT(73)=KFR2
9512 VINT(73)=TAUR2
9513 VINT(74)=GAMR2
9514 MINT(74)=KFR3
9515 VINT(75)=TAUR3
9516 VINT(76)=GAMR3
9517 ELSEIF(KFR1.NE.0) THEN
9518 MINT(72)=1
9519 ELSEIF(KFR2.NE.0) THEN
9520 MINT(72)=1
9521 MINT(73)=KFR2
9522 VINT(73)=TAUR2
9523 VINT(74)=GAMR2
9524 ELSEIF(KFR3.NE.0) THEN
9525 MINT(72)=1
9526 MINT(73)=KFR3
9527 VINT(73)=TAUR3
9528 VINT(74)=GAMR3
9529 ELSE
9530 MINT(72)=0
9531 ENDIF
9532 ELSE
9533 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9534
9535 ELSEIF(KFR2.NE.0) THEN
9536 KFR1=KFR2
9537 TAUR1=TAUR2
9538 GAMR1=GAMR2
9539 MINT(72)=1
9540 MINT(73)=KFR1
9541 VINT(73)=TAUR1
9542 VINT(74)=GAMR1
9543 KFR2=0
9544 ELSE
9545 MINT(72)=0
9546 ENDIF
9547 ENDIF
9548 ENDIF
9549
9550C...Find product masses and minimum pT of process,
9551C...optionally with broadening according to a truncated Breit-Wigner.
9552 VINT(63)=0D0
9553 VINT(64)=0D0
9554 MINT(71)=0
9555 VINT(71)=CKIN(3)
9556 IF(MINT(82).GE.2) VINT(71)=0D0
9557 VINT(80)=1D0
9558 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9559 NBW=0
9560 DO 160 I=1,2
9561 PMMN(I)=0D0
9562 IF(KFPR(ISUB,I).EQ.0) THEN
9563 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9564 & PARP(41)) THEN
9565 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9566 ELSE
9567 NBW=NBW+1
9568C...This prevents SUSY/t particles from becoming too light.
9569 KFLW=KFPR(ISUB,I)
9570 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9571 KCW=PYCOMP(KFLW)
9572 PMMN(I)=PMAS(KCW,1)
9573 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9574 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9575 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9576 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9577 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9578 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9579 PMMN(I)=MIN(PMMN(I),PMSUM)
9580 ENDIF
9581 150 CONTINUE
9582 ELSEIF(KFLW.EQ.6) THEN
9583 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9584 ENDIF
9585 ENDIF
9586 160 CONTINUE
9587 IF(NBW.GE.1) THEN
9588 CKIN41=CKIN(41)
9589 CKIN43=CKIN(43)
9590 CKIN(41)=MAX(PMMN(1),CKIN(41))
9591 CKIN(43)=MAX(PMMN(2),CKIN(43))
9592 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9593 CKIN(41)=CKIN41
9594 CKIN(43)=CKIN43
9595 IF(MINT(51).EQ.1) THEN
9596 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9597 IF(MFAIL.EQ.1) THEN
9598 MSTI(61)=1
9599 RETURN
9600 ENDIF
9601 GOTO 100
9602 ENDIF
9603 VINT(63)=PQM3**2
9604 VINT(64)=PQM4**2
9605 ENDIF
9606 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9607 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9608 ENDIF
9609
9610C...Prepare for additional variable choices in 2 -> 3.
9611 IF(ISTSB.EQ.5) THEN
9612 VINT(201)=0D0
9613 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9614 VINT(206)=VINT(201)
9615 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9616 VINT(204)=PMAS(23,1)
9617 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9618 & VINT(204)=PMAS(24,1)
9619 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9620 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9621 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9622 & VINT(204)=VINT(201)
9623 VINT(209)=VINT(204)
9624 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9625 ENDIF
9626
9627C...Select incoming VDM particle (rho/omega/phi/J/psi).
9628 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9629 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9630 VRN=PYR(0)*SIGT(0,0,5)
9631 IF(MINT(101).LE.1) THEN
9632 I1MN=0
9633 I1MX=0
9634 ELSE
9635 I1MN=1
9636 I1MX=MINT(101)
9637 ENDIF
9638 IF(MINT(102).LE.1) THEN
9639 I2MN=0
9640 I2MX=0
9641 ELSE
9642 I2MN=1
9643 I2MX=MINT(102)
9644 ENDIF
9645 DO 180 I1=I1MN,I1MX
9646 KFV1=110*I1+3
9647 DO 170 I2=I2MN,I2MX
9648 KFV2=110*I2+3
9649 VRN=VRN-SIGT(I1,I2,5)
9650 IF(VRN.LE.0D0) GOTO 190
9651 170 CONTINUE
9652 180 CONTINUE
9653 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9654 IF(MINT(102).GE.2) MINT(104)=KFV2
9655 ENDIF
9656
9657 IF(ISTSB.EQ.0) THEN
9658C...Elastic scattering or single or double diffractive scattering.
9659
9660C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9661 MINT(103)=MINT(11)
9662 MINT(104)=MINT(12)
9663 PMM(1)=VINT(3)
9664 PMM(2)=VINT(4)
9665 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9666 JJ=ISUB-90
9667 VRN=PYR(0)*SIGT(0,0,JJ)
9668 IF(MINT(101).LE.1) THEN
9669 I1MN=0
9670 I1MX=0
9671 ELSE
9672 I1MN=1
9673 I1MX=MINT(101)
9674 ENDIF
9675 IF(MINT(102).LE.1) THEN
9676 I2MN=0
9677 I2MX=0
9678 ELSE
9679 I2MN=1
9680 I2MX=MINT(102)
9681 ENDIF
9682 DO 210 I1=I1MN,I1MX
9683 KFV1=110*I1+3
9684 DO 200 I2=I2MN,I2MX
9685 KFV2=110*I2+3
9686 VRN=VRN-SIGT(I1,I2,JJ)
9687 IF(VRN.LE.0D0) GOTO 220
9688 200 CONTINUE
9689 210 CONTINUE
9690 220 IF(MINT(101).GE.2) THEN
9691 MINT(103)=KFV1
9692 PMM(1)=PYMASS(KFV1)
9693 ENDIF
9694 IF(MINT(102).GE.2) THEN
9695 MINT(104)=KFV2
9696 PMM(2)=PYMASS(KFV2)
9697 ENDIF
9698 ENDIF
9699 VINT(67)=PMM(1)
9700 VINT(68)=PMM(2)
9701
9702C...Select mass for GVMD states (rejecting previous assignment).
9703 Q0S=4D0*PARP(15)**2
9704 Q1S=4D0*VINT(154)**2
9705 LOOP3=0
9706 230 LOOP3=LOOP3+1
9707 DO 240 JT=1,2
9708 IF(MINT(106+JT).EQ.3) THEN
9709 PS=VINT(2+JT)**2
9710 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9711 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9712 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9713 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9714 ENDIF
9715 240 CONTINUE
9716 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9717 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9718 & GOTO 230
9719 GOTO 100
9720 ENDIF
9721
9722C...Side/sides of diffractive system.
9723 MINT(17)=0
9724 MINT(18)=0
9725 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9726 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9727
9728C...Find masses of particles and minimal masses of diffractive states.
9729 DO 250 JT=1,2
9730 PDIF(JT)=PMM(JT)
9731 VINT(68+JT)=PDIF(JT)
9732 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9733 250 CONTINUE
9734 SH=VINT(2)
9735 SQM1=PMM(1)**2
9736 SQM2=PMM(2)**2
9737 SQM3=PDIF(1)**2
9738 SQM4=PDIF(2)**2
9739 SMRES1=(PMM(1)+PMRC)**2
9740 SMRES2=(PMM(2)+PMRC)**2
9741
9742C...Find elastic slope and lower limit diffractive slope.
9743 IHA=MAX(2,IABS(MINT(103))/110)
9744 IF(IHA.GE.5) IHA=1
9745 IHB=MAX(2,IABS(MINT(104))/110)
9746 IF(IHB.GE.5) IHB=1
9747 IF(ISUB.EQ.91) THEN
9748 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9749 ELSEIF(ISUB.EQ.92) THEN
9750 BMN=MAX(2D0,2D0*BHAD(IHB))
9751 ELSEIF(ISUB.EQ.93) THEN
9752 BMN=MAX(2D0,2D0*BHAD(IHA))
9753 ELSEIF(ISUB.EQ.94) THEN
9754 BMN=2D0*ALP*4D0
9755 ENDIF
9756
9757C...Determine maximum possible t range and coefficient of generation.
9758 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9759 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9760 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9761 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9762 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9763 & (SQM1*SQM4-SQM2*SQM3)/SH
9764 THL=-0.5D0*(THA+THB)
9765 THU=THC/THL
9766 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9767
9768C...Select diffractive mass/masses according to dm^2/m^2.
9769 LOOP3=0
9770 260 LOOP3=LOOP3+1
9771 DO 270 JT=1,2
9772 IF(MINT(16+JT).EQ.0) THEN
9773 PDIF(2+JT)=PDIF(JT)
9774 ELSE
9775 PMMIN=PDIF(JT)
9776 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9777 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9778 ENDIF
9779 270 CONTINUE
9780 SQM3=PDIF(3)**2
9781 SQM4=PDIF(4)**2
9782
9783C..Additional mass factors, including resonance enhancement.
9784 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9785 IF(LOOP3.LT.100) GOTO 260
9786 GOTO 100
9787 ENDIF
9788 IF(ISUB.EQ.92) THEN
9789 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9790 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9791 ELSEIF(ISUB.EQ.93) THEN
9792 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9793 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9794 ELSEIF(ISUB.EQ.94) THEN
9795 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9796 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9797 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9798 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9799 ENDIF
9800
9801C...Select t according to exp(Bmn*t) and correct to right slope.
9802 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9803 IF(ISUB.GE.92) THEN
9804 IF(ISUB.EQ.92) THEN
9805 BADD=2D0*ALP*LOG(SH/SQM3)
9806 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9807 ELSEIF(ISUB.EQ.93) THEN
9808 BADD=2D0*ALP*LOG(SH/SQM4)
9809 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9810 ELSEIF(ISUB.EQ.94) THEN
9811 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9812 ENDIF
9813 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9814 ENDIF
9815
9816C...Check whether m^2 and t choices are consistent.
9817 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9818 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9819 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9820 IF(THB.LE.1D-8) GOTO 260
9821 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9822 & (SQM1*SQM4-SQM2*SQM3)/SH
9823 THLM=-0.5D0*(THA+THB)
9824 THUM=THC/THLM
9825 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9826
9827C...Information to output.
9828 VINT(21)=1D0
9829 VINT(22)=0D0
9830 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9831 VINT(45)=TH
9832 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9833 VINT(63)=PDIF(3)**2
9834 VINT(64)=PDIF(4)**2
9835 VINT(283)=PMM(1)**2/4D0
9836 VINT(284)=PMM(2)**2/4D0
9837
9838C...Note: in the following, by In is meant the integral over the
9839C...quantity multiplying coefficient cn.
9840C...Choose tau according to h1(tau)/tau, where
9841C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9842C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9843C...I1/I5*c5*1/(tau+tau_R') +
9844C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9845C...I1/I7*c7*tau/(1.-tau), and
9846C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9847 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9848 CALL PYKLIM(1)
9849 IF(MINT(51).NE.0) THEN
9850 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9851 IF(MFAIL.EQ.1) THEN
9852 MSTI(61)=1
9853 RETURN
9854 ENDIF
9855 GOTO 100
9856 ENDIF
9857 RTAU=PYR(0)
9858 MTAU=1
9859 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9860 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9861 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9862 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9863 & MTAU=5
9864 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9865 & COEF(ISUB,5)) MTAU=6
9866 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9867 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9868C...Additional check to handle techni-processes with extra resonance
9869C....Only modify tau treatment
9870 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9871 & THEN
9872 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9873 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9874 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9875 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9876 & +COEFX(ISUB,1)) MTAU=9
9877 ENDIF
9878 CALL PYKMAP(1,MTAU,PYR(0))
9879
9880C...2 -> 3, 4 processes:
9881C...Choose tau' according to h4(tau,tau')/tau', where
9882C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9883C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9884 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9885 CALL PYKLIM(4)
9886 IF(MINT(51).NE.0) THEN
9887 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9888 IF(MFAIL.EQ.1) THEN
9889 MSTI(61)=1
9890 RETURN
9891 ENDIF
9892 GOTO 100
9893 ENDIF
9894 RTAUP=PYR(0)
9895 MTAUP=1
9896 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9897 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9898 CALL PYKMAP(4,MTAUP,PYR(0))
9899 ENDIF
9900
9901C...Choose y* according to h2(y*), where
9902C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9903C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9904C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9905C...and c1 + c2 + c3 + c4 + c5 = 1.
9906 CALL PYKLIM(2)
9907 IF(MINT(51).NE.0) THEN
9908 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9909 IF(MFAIL.EQ.1) THEN
9910 MSTI(61)=1
9911 RETURN
9912 ENDIF
9913 GOTO 100
9914 ENDIF
9915 RYST=PYR(0)
9916 MYST=1
9917 IF(RYST.GT.COEF(ISUB,8)) MYST=2
9918 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
9919 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
9920 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
9921 & COEF(ISUB,11)) MYST=5
9922 CALL PYKMAP(2,MYST,PYR(0))
9923
9924C...2 -> 2 processes:
9925C...Choose cos(theta-hat) (cth) according to h3(cth), where
9926C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
9927C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
9928C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
9929C...and c0 + c1 + c2 + c3 + c4 = 1.
9930 CALL PYKLIM(3)
9931 IF(MINT(51).NE.0) THEN
9932 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9933 IF(MFAIL.EQ.1) THEN
9934 MSTI(61)=1
9935 RETURN
9936 ENDIF
9937 GOTO 100
9938 ENDIF
9939 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9940 RCTH=PYR(0)
9941 MCTH=1
9942 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
9943 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
9944 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
9945 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
9946 & COEF(ISUB,16)) MCTH=5
9947 CALL PYKMAP(3,MCTH,PYR(0))
9948 ENDIF
9949
9950C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
9951 IF(ISTSB.EQ.5) THEN
9952 CALL PYKMAP(5,0,0D0)
9953 IF(MINT(51).NE.0) THEN
9954 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9955 IF(MFAIL.EQ.1) THEN
9956 MSTI(61)=1
9957 RETURN
9958 ENDIF
9959 GOTO 100
9960 ENDIF
9961 ENDIF
9962
9963C...DIS as f + gamma* -> f process: set dummy values.
9964 ELSEIF(ISTSB.EQ.8) THEN
9965 VINT(21)=0.9D0
9966 VINT(22)=0D0
9967 VINT(23)=0D0
9968 VINT(47)=0D0
9969 VINT(48)=0D0
9970
9971C...Low-pT or multiple interactions (first semihard interaction).
9972 ELSEIF(ISTSB.EQ.9) THEN
9973 IF(MINT(35).LE.1) CALL PYMULT(3)
9974 IF(MINT(35).GE.2) CALL PYMIGN(3)
9975 ISUB=MINT(1)
9976
9977C...Study user-defined process: kinematics plus weight.
9978 ELSEIF(ISTSB.EQ.11) THEN
9979 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
9980 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
9981 MSTI(51)=0
9982 IF(NUP.LE.0) THEN
9983 MINT(51)=2
9984 MSTI(51)=1
9985 IF(MINT(82).EQ.1) THEN
9986 NGEN(0,1)=NGEN(0,1)-1
9987 NGEN(ISUB,1)=NGEN(ISUB,1)-1
9988 ENDIF
9989 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9990 RETURN
9991 ENDIF
9992
9993C...Extract cross section event weight.
9994 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
9995 SIGS=1D-9*XWGTUP
9996 ELSE
9997 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
9998 ENDIF
9999 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10000 VINT(97)=SIGN(1D0,XWGTUP)
10001 ELSE
10002 VINT(97)=1D-9*XWGTUP
10003 ENDIF
10004
10005C...Construct 'trivial' kinematical variables needed.
10006 KFL1=IDUP(1)
10007 KFL2=IDUP(2)
10008 VINT(41)=PUP(4,1)/EBMUP(1)
10009 VINT(42)=PUP(4,2)/EBMUP(2)
10010 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10011 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10012 & '(listing follows):')
10013 CALL PYLIST(7)
10014 ENDIF
10015 VINT(21)=VINT(41)*VINT(42)
10016 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10017 VINT(44)=VINT(21)*VINT(2)
10018 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10019 VINT(55)=SCALUP
10020 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10021 VINT(56)=VINT(55)**2
10022 VINT(57)=AQEDUP
10023 VINT(58)=AQCDUP
10024
10025C...Construct other kinematical variables needed (approximately).
10026 VINT(23)=0D0
10027 VINT(26)=VINT(21)
10028 VINT(45)=-0.5D0*VINT(44)
10029 VINT(46)=-0.5D0*VINT(44)
10030 VINT(49)=VINT(43)
10031 VINT(50)=VINT(44)
10032 VINT(51)=VINT(55)
10033 VINT(52)=VINT(56)
10034 VINT(53)=VINT(55)
10035 VINT(54)=VINT(56)
10036 VINT(25)=0D0
10037 VINT(48)=0D0
10038 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10039 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10040 DO 280 IUP=3,NUP
10041 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10042 & '(PYRAND:) unacceptable ISTUP code for particles')
10043 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10044 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10045 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10046 & PUP(2,IUP)**2)
10047 280 CONTINUE
10048 VINT(47)=SQRT(VINT(48))
10049 ENDIF
10050
10051C...Choose azimuthal angle.
10052 VINT(24)=0D0
10053 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10054
10055C...Check against user cuts on kinematics at parton level.
10056 MINT(51)=0
10057 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10058 IF(MINT(51).NE.0) THEN
10059 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10060 IF(MFAIL.EQ.1) THEN
10061 MSTI(61)=1
10062 RETURN
10063 ENDIF
10064 GOTO 100
10065 ENDIF
10066 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10067 MCUT=0
10068 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10069 & CALL PYKCUT(MCUT)
10070 IF(MCUT.NE.0) THEN
10071 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10072 IF(MFAIL.EQ.1) THEN
10073 MSTI(61)=1
10074 RETURN
10075 ENDIF
10076 GOTO 100
10077 ENDIF
10078 ENDIF
10079
10080 IF(ISTSB.LE.10) THEN
10081C... If internal process, call PYSIGH
10082 CALL PYSIGH(NCHN,SIGS)
10083 ELSE
10084C... If external process, still have to set MI starting scale
10085 IF (MSTP(86).EQ.1) THEN
10086C... Limit phase space by xT2 of hard interaction
10087C... (gives undercounting of MI when ext proc != dijets)
10088 XT2GMX = VINT(25)
10089 ELSE
10090C... All accessible phase space allowed
10091C... (gives double counting of MI when ext proc = dijets)
10092 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10093 ENDIF
10094 VINT(62)=0.25D0*XT2GMX*VINT(2)
10095 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10096 ENDIF
10097
10098 SIGSOR=SIGS
10099 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10100
10101C...Multiply cross section by lepton -> photon flux factor.
10102 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10103 SIGS=WTGAGA*SIGS
10104 DO 290 ICHN=1,NCHN
10105 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10106 290 CONTINUE
10107 SIGLPT=WTGAGA*SIGLPT
10108 ENDIF
10109
10110C...Multiply cross-section by user-defined weights.
10111 IF(MSTP(173).EQ.1) THEN
10112 SIGS=PARP(173)*SIGS
10113 DO 300 ICHN=1,NCHN
10114 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10115 300 CONTINUE
10116 SIGLPT=PARP(173)*SIGLPT
10117 ENDIF
10118 WTXS=1D0
10119 SIGSWT=SIGS
10120 VINT(99)=1D0
10121 VINT(100)=1D0
10122 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10123 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10124 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10125 SIGSWT=WTXS*SIGS
10126 VINT(99)=WTXS
10127 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10128 ENDIF
10129
10130C...Calculations for Monte Carlo estimate of all cross-sections.
10131 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10132 IF(MSTP(142).LE.1) THEN
10133 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10134 ELSE
10135 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10136 ENDIF
10137 ELSEIF(MINT(82).EQ.1) THEN
10138 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10139 ENDIF
10140 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10141 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10142
10143C...Multiple interactions: store results of cross-section calculation.
10144 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10145 VINT(153)=SIGSOR
10146 IF(MINT(35).LE.1) CALL PYMULT(4)
10147 IF(MINT(35).GE.2) CALL PYMIGN(4)
10148 ENDIF
10149
10150C...Ratio of actual to maximum cross section.
10151 IF(ISTSB.NE.11) THEN
10152 VIOL=SIGSWT/XSEC(ISUB,1)
10153 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10154 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10155 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10156 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10157 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10158 ELSE
10159 VIOL=1D0
10160 ENDIF
10161
10162C...Check that weight not negative.
10163 IF(MSTP(123).LE.0) THEN
10164 IF(VIOL.LT.-1D-3) THEN
10165 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10166 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10167 & VINT(22),VINT(23),VINT(26)
10168 CALL PYSTOP(2)
10169 ENDIF
10170 ELSE
10171 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10172 VINT(109)=VIOL
10173 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10174 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10175 & VINT(22),VINT(23),VINT(26)
10176 ENDIF
10177 ENDIF
10178
10179C...Weighting using estimate of maximum of differential cross-section.
10180 RATND=1D0
10181 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10182 IF(VIOL.LT.PYR(0)) THEN
10183 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10184 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10185 GOTO 100
10186 ENDIF
10187 ELSEIF(MFAIL.EQ.0) THEN
10188 RATND=SIGLPT/XSEC(95,1)
10189 VIOL=VIOL/RATND
10190 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10191 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10192 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10193 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10194 ISUB=0
10195 GOTO 100
10196 ENDIF
10197 IF(VIOL.LT.PYR(0)) THEN
10198 GOTO 140
10199 ENDIF
10200 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10201 IF(VIOL.LT.PYR(0)) THEN
10202 MSTI(61)=1
10203 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10204 RETURN
10205 ENDIF
10206 ELSE
10207 RATND=SIGLPT/XSEC(95,1)
10208 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10209 MSTI(61)=1
10210 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10211 RETURN
10212 ENDIF
10213 VIOL=VIOL/RATND
10214 IF(VIOL.LT.PYR(0)) THEN
10215 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10216 GOTO 100
10217 ENDIF
10218 ENDIF
10219
10220C...Check for possible violation of estimated maximum of differential
10221C...cross-section used in weighting.
10222 IF(MSTP(123).LE.0) THEN
10223 IF(VIOL.GT.1D0) THEN
10224 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10225 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10226 & VINT(22),VINT(23),VINT(26)
10227 CALL PYSTOP(2)
10228 ENDIF
10229 ELSEIF(MSTP(123).EQ.1) THEN
10230 IF(VIOL.GT.VINT(108)) THEN
10231 VINT(108)=VIOL
10232 IF(VIOL.GT.1.0001D0) THEN
10233 MINT(10)=1
10234 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10235 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10236 & VINT(22),VINT(23),VINT(26)
10237 ENDIF
10238 ENDIF
10239 ELSEIF(VIOL.GT.VINT(108)) THEN
10240 VINT(108)=VIOL
10241 IF(VIOL.GT.1D0) THEN
10242 MINT(10)=1
10243 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10244 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10245 & THEN
10246 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10247 IF(KFPR(ISUB,1).LE.9) THEN
10248 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10249 & XMAXUP(KFPR(ISUB,1))
10250 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10251 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10252 & XMAXUP(KFPR(ISUB,1))
10253 ELSE
10254 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10255 & XMAXUP(KFPR(ISUB,1))
10256 ENDIF
10257 ENDIF
10258 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10259 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10260 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10261 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10262 & XSEC(0,1)=XSEC(0,1)+XDIF
10263 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10264 & VINT(22),VINT(23),VINT(26)
10265 IF(ISUB.LE.9) THEN
10266 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10267 ELSEIF(ISUB.LE.99) THEN
10268 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10269 ELSE
10270 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10271 ENDIF
10272 ENDIF
10273 VINT(108)=1D0
10274 ENDIF
10275 ENDIF
10276
10277C...Multiple interactions: choose impact parameter (if not already done).
10278 IF(MINT(39).EQ.0) VINT(148)=1D0
10279 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10280 &MSTP(82).GE.3) THEN
10281 IF(MINT(35).LE.1) CALL PYMULT(5)
10282 IF(MINT(35).GE.2) CALL PYMIGN(5)
10283 IF(VINT(150).LT.PYR(0)) THEN
10284 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10285 IF(MFAIL.EQ.1) THEN
10286 MSTI(61)=1
10287 RETURN
10288 ENDIF
10289 GOTO 100
10290 ENDIF
10291 ENDIF
10292 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10293 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10294 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10295 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10296 ENDIF
10297 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10298
10299C...Choose flavour of reacting partons (and subprocess).
10300 IF(ISTSB.GE.11) GOTO 320
10301 RSIGS=SIGS*PYR(0)
10302 QT2=VINT(48)
10303 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10304 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10305 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10306 &PYR(0).GT.RQQBAR)) THEN
10307 DO 310 ICHN=1,NCHN
10308 KFL1=ISIG(ICHN,1)
10309 KFL2=ISIG(ICHN,2)
10310 MINT(2)=ISIG(ICHN,3)
10311 RSIGS=RSIGS-SIGH(ICHN)
10312 IF(RSIGS.LE.0D0) GOTO 320
10313 310 CONTINUE
10314
10315C...Multiple interactions: choose qqbar preferentially at small pT.
10316 ELSEIF(ISUB.EQ.96) THEN
10317 MINT(105)=MINT(103)
10318 MINT(109)=MINT(107)
10319 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10320 MINT(105)=MINT(104)
10321 MINT(109)=MINT(108)
10322 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10323 MINT(1)=11
10324 MINT(2)=1
10325 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10326
10327C...Low-pT: choose string drawing configuration.
10328 ELSE
10329 KFL1=21
10330 KFL2=21
10331 RSIGS=6D0*PYR(0)
10332 MINT(2)=1
10333 IF(RSIGS.GT.1D0) MINT(2)=2
10334 IF(RSIGS.GT.2D0) MINT(2)=3
10335 ENDIF
10336
10337C...Reassign QCD process. Partons before initial state radiation.
10338 320 IF(MINT(2).GT.10) THEN
10339 MINT(1)=MINT(2)/10
10340 MINT(2)=MOD(MINT(2),10)
10341 ENDIF
10342 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10343 &NGEN(MINT(1),2)+1
10344 MINT(15)=KFL1
10345 MINT(16)=KFL2
10346 MINT(13)=MINT(15)
10347 MINT(14)=MINT(16)
10348 VINT(141)=VINT(41)
10349 VINT(142)=VINT(42)
10350 VINT(151)=0D0
10351 VINT(152)=0D0
10352
10353C...Calculate x value of photon for parton inside photon inside e.
10354 DO 350 JT=1,2
10355 MINT(18+JT)=0
10356 VINT(154+JT)=0D0
10357 MSPLI=0
10358 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10359 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10360 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10361 IF(MSPLI.EQ.2) THEN
10362 KFLH=MINT(14+JT)
10363 XHRD=VINT(140+JT)
10364 Q2HRD=VINT(54)
10365 MINT(105)=MINT(102+JT)
10366 MINT(109)=MINT(106+JT)
10367 VINT(120)=VINT(2+JT)
10368C.... ALICE
10369C.... Store side in MINT(124)
10370 MINT(124) = JT
10371C....
10372 IF(MSTP(57).LE.1) THEN
10373 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10374 ELSE
10375 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10376 ENDIF
10377 WTMX=4D0*XPQ(KFLH)
10378 IF(MSTP(13).EQ.2) THEN
10379 Q2PMS=Q2HRD/PMAS(11,1)**2
10380 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10381 ENDIF
10382 330 XE=XHRD**PYR(0)
10383 XG=MIN(1D0-1D-10,XHRD/XE)
10384 IF(MSTP(57).LE.1) THEN
10385 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10386 ELSE
10387 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10388 ENDIF
10389 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10390 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10391 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10392 MINT(18+JT)=1
10393 VINT(154+JT)=XE
10394 DO 340 KFLS=-25,25
10395 XSFX(JT,KFLS)=XPQ(KFLS)
10396 340 CONTINUE
10397 ENDIF
10398 350 CONTINUE
10399
10400C...Pick scale where photon is resolved.
10401 Q0S=PARP(15)**2
10402 Q1S=VINT(154)**2
10403 VINT(283)=0D0
10404 IF(MINT(107).EQ.3) THEN
10405 IF(MSTP(66).EQ.1) THEN
10406 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10407 ELSEIF(MSTP(66).EQ.2) THEN
10408 PS=VINT(3)**2
10409 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10410 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10411 Q2INT=SQRT(Q0S*Q2EFF)
10412 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10413 ELSEIF(MSTP(66).EQ.3) THEN
10414 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10415 ELSEIF(MSTP(66).GE.4) THEN
10416 PS=0.25D0*VINT(3)**2
10417 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10418 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10419 ENDIF
10420 ENDIF
10421 VINT(284)=0D0
10422 IF(MINT(108).EQ.3) THEN
10423 IF(MSTP(66).EQ.1) THEN
10424 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10425 ELSEIF(MSTP(66).EQ.2) THEN
10426 PS=VINT(4)**2
10427 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10428 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10429 Q2INT=SQRT(Q0S*Q2EFF)
10430 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10431 ELSEIF(MSTP(66).EQ.3) THEN
10432 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10433 ELSEIF(MSTP(66).GE.4) THEN
10434 PS=0.25D0*VINT(4)**2
10435 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10436 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10437 ENDIF
10438 ENDIF
10439 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10440
10441C...Format statements for differential cross-section maximum violations.
10442 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10443 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10444 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10445 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10446 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10447 &'in event',1X,I7)
10448 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10449 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10450 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10451 &'in event',1X,I7)
10452 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10453 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10454 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10455 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10456 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10457 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10458
10459 RETURN
10460 END
10461
10462C*********************************************************************
10463
10464C...PYSCAT
10465C...Finds outgoing flavours and event type; sets up the kinematics
10466C...and colour flow of the hard scattering
10467
10468 SUBROUTINE PYSCAT
10469
10470C...Double precision and integer declarations
10471 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10472 IMPLICIT INTEGER(I-N)
10473 INTEGER PYK,PYCHGE,PYCOMP
10474C...Parameter statement to help give large particle numbers.
10475 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10476 &KEXCIT=4000000,KDIMEN=5000000)
10477C...Parameter statement for maximum size of showers.
10478 PARAMETER (MAXNUR=1000)
10479
10480C...User process event common block.
10481 INTEGER MAXNUP
10482 PARAMETER (MAXNUP=500)
10483 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10484 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10485 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10486 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10487 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10488 SAVE /HEPEUP/
10489
10490C...Commonblocks.
10491 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10492 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10494 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10495 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10496 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10497 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10498 COMMON/PYINT1/MINT(400),VINT(400)
10499 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10500 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10501 COMMON/PYINT4/MWID(500),WIDS(500,5)
10502 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10503 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10504 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10505 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10506 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10507 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10508 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10509 &/PYTCSM/,/PYPUED/
10510C...Local arrays and saved variables
10511 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10512 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10513 INTEGER IOKFLA(6),IIFLAV
10514C...UED related declarations:
10515C...equivalences between ordered particles (451->475)
10516C...and UED particle code (5 000 000 + id)
10517 DIMENSION IUEDEQ(475),MUED(2)
10518 DATA (IUEDEQ(I),I=451,475)/
10519 & 6100001,6100002,6100003,6100004,6100005,6100006,
10520 & 5100001,5100002,5100003,5100004,5100005,5100006,
10521 & 6100011,6100013,6100015,
10522 & 5100012,5100011,5100014,5100013,5100016,5100015,
10523 & 5100021,5100022,5100023,5100024/
10524 SAVE VINTSV
10525
10526C...Read out process
10527 ISUB=MINT(1)
10528 ISUBSV=ISUB
10529
10530C...Restore information for low-pT processes
10531 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10532 DO 100 J=41,66
10533 100 VINT(J)=VINTSV(J)
10534 ENDIF
10535
10536C...Convert H' or A process into equivalent H one
10537 IHIGG=1
10538 KFHIGG=25
10539 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10540 &ISUB.LE.190)) THEN
10541 IHIGG=2
10542 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10543 KFHIGG=33+IHIGG
10544 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10545 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10546 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10547 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10548 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10549 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10550 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10551 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10552 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10553 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10554 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10555 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10556 ENDIF
10557
10558 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10559
10560C...Convert bottomonium process into equivalent charmonium ones.
10561 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10562
10563C...Choice of subprocess, number of documentation lines
10564 IDOC=6+ISET(ISUB)
10565 IF(ISUB.EQ.95) IDOC=8
10566 IF(ISET(ISUB).EQ.5) IDOC=9
10567 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10568 MINT(3)=IDOC-6
10569 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10570 MINT(4)=IDOC
10571 IPU1=MINT(84)+1
10572 IPU2=MINT(84)+2
10573 IPU3=MINT(84)+3
10574 IPU4=MINT(84)+4
10575 IPU5=MINT(84)+5
10576 IPU6=MINT(84)+6
10577
10578C...Reset K, P and V vectors. Store incoming particles
10579 DO 120 JT=1,MSTP(126)+100
10580 I=MINT(83)+JT
10581 IF(I.GT.MSTU(4)) GOTO 120
10582 DO 110 J=1,5
10583 K(I,J)=0
10584 P(I,J)=0D0
10585 V(I,J)=0D0
10586 110 CONTINUE
10587 120 CONTINUE
10588 DO 140 JT=1,2
10589 I=MINT(83)+JT
10590 K(I,1)=21
10591 K(I,2)=MINT(10+JT)
10592 DO 130 J=1,5
10593 P(I,J)=VINT(285+5*JT+J)
10594 130 CONTINUE
10595 140 CONTINUE
10596 MINT(6)=2
10597 KFRES=0
10598
10599C...Store incoming partons in their CM-frame. Save pdf value.
10600 SH=VINT(44)
10601 SHR=SQRT(SH)
10602 SHP=VINT(26)*VINT(2)
10603 SHPR=SQRT(SHP)
10604 SHUSER=SHR
10605 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10606 DO 150 JT=1,2
10607 I=MINT(84)+JT
10608 K(I,1)=14
10609 K(I,2)=MINT(14+JT)
10610 K(I,3)=MINT(83)+2+JT
10611 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10612 P(I,4)=0.5D0*SHUSER
10613 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10614 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10615 ELSE
10616 VINT(38+JT)=1D0
10617 ENDIF
10618 150 CONTINUE
10619
10620C...Copy incoming partons to documentation lines
10621 DO 170 JT=1,2
10622 I1=MINT(83)+4+JT
10623 I2=MINT(84)+JT
10624 K(I1,1)=21
10625 K(I1,2)=K(I2,2)
10626 K(I1,3)=I1-2
10627 DO 160 J=1,5
10628 P(I1,J)=P(I2,J)
10629 160 CONTINUE
10630 170 CONTINUE
10631
10632C...Choose new quark/lepton flavour for relevant annihilation graphs
10633 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10634 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10635 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10636 IGLGA=21
10637 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10638 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10639 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10640 DO 190 I=1,MDCY(IGLGA,3)
10641 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10642 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10643 IF(RKFL.LE.0D0) GOTO 200
10644 190 CONTINUE
10645 200 CONTINUE
10646 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10647 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10648 IF(KFLF.GE.4) GOTO 180
10649 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10650 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10651 KFLF=4
10652 MINT(2)=MINT(2)-2
10653 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10654 & OR.ISUB.EQ.316) THEN
10655 KFLF=5
10656 MINT(2)=MINT(2)-4
10657 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10658 & .AND.IABS(KFLF).GE.3) THEN
10659 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10660 & VINT(44)**2
10661 FACCIB=VINT(46)**2/RTCM(41)**4
10662 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10663 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10664 KFLF=5
10665 MINT(2)=1
10666 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10667 IF(KFLF.EQ.5) GOTO 180
10668 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10669 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10670 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10671 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10672 ENDIF
10673 ENDIF
10674
10675C...Final state flavours and colour flow: default values
10676 JS=1
10677 MINT(21)=MINT(15)
10678 MINT(22)=MINT(16)
10679 MINT(23)=0
10680 MINT(24)=0
10681 KCC=20
10682 KCS=ISIGN(1,MINT(15))
10683
10684 IF(ISET(ISUB).EQ.11) THEN
10685C...User-defined processes: find products
10686 MINT(3)=0
10687 DO 210 IUP=3,NUP
10688 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10689 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10690 MINT(21+IUP)=IDUP(IUP)
10691 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10692 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10693 ELSEIF(IDUP(IUP).EQ.0) THEN
10694 ELSE
10695 MINT(3)=MINT(3)+1
10696 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10697 ENDIF
10698 210 CONTINUE
10699
10700 ELSEIF(ISUB.LE.10) THEN
10701 IF(ISUB.EQ.1) THEN
10702C...f + fbar -> gamma*/Z0
10703 KFRES=23
10704
10705 ELSEIF(ISUB.EQ.2) THEN
10706C...f + fbar' -> W+/-
10707 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10708 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10709 KFRES=ISIGN(24,KCH1+KCH2)
10710
10711 ELSEIF(ISUB.EQ.3) THEN
10712C...f + fbar -> h0 (or H0, or A0)
10713 KFRES=KFHIGG
10714
10715 ELSEIF(ISUB.EQ.4) THEN
10716C...gamma + W+/- -> W+/-
10717
10718 ELSEIF(ISUB.EQ.5) THEN
10719C...Z0 + Z0 -> h0
10720 XH=SH/SHP
10721 MINT(21)=MINT(15)
10722 MINT(22)=MINT(16)
10723 PMQ(1)=PYMASS(MINT(21))
10724 PMQ(2)=PYMASS(MINT(22))
10725 220 JT=INT(1.5D0+PYR(0))
10726 ZMIN=2D0*PMQ(JT)/SHPR
10727 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10728 & (SHPR*(SHPR-PMQ(3-JT)))
10729 ZMAX=MIN(1D0-XH,ZMAX)
10730 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10731 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10732 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10733 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10734 IF(SQC1.LT.1D-8) GOTO 220
10735 C1=SQRT(SQC1)
10736 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10737 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10738 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10739 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10740 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10741 IF(SQC1.LT.1D-8) GOTO 220
10742 C1=SQRT(SQC1)
10743 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10744 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10745 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10746 PHIR=PARU(2)*PYR(0)
10747 CPHI=COS(PHIR)
10748 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10749 & SQRT(1D0-CTHE(2)**2)*CPHI
10750 Z1=2D0-Z(JT)
10751 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10752 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10753 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10754 & PMQ(3-JT)**2/SHP))
10755 ZMIN=2D0*PMQ(3-JT)/SHPR
10756 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10757 ZMAX=MIN(1D0-XH,ZMAX)
10758 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10759 KCC=22
10760 KFRES=25
10761
10762 ELSEIF(ISUB.EQ.6) THEN
10763C...Z0 + W+/- -> W+/-
10764
10765 ELSEIF(ISUB.EQ.7) THEN
10766C...W+ + W- -> Z0
10767
10768 ELSEIF(ISUB.EQ.8) THEN
10769C...W+ + W- -> h0
10770 XH=SH/SHP
10771 230 DO 260 JT=1,2
10772 I=MINT(14+JT)
10773 IA=IABS(I)
10774 IF(IA.LE.10) THEN
10775 RVCKM=VINT(180+I)*PYR(0)
10776 DO 240 J=1,MSTP(1)
10777 IB=2*J-1+MOD(IA,2)
10778 IPM=(5-ISIGN(1,I))/2
10779 IDC=J+MDCY(IA,2)+2
10780 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10781 MINT(20+JT)=ISIGN(IB,I)
10782 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10783 IF(RVCKM.LE.0D0) GOTO 250
10784 240 CONTINUE
10785 ELSE
10786 IB=2*((IA+1)/2)-1+MOD(IA,2)
10787 MINT(20+JT)=ISIGN(IB,I)
10788 ENDIF
10789 250 PMQ(JT)=PYMASS(MINT(20+JT))
10790 260 CONTINUE
10791 JT=INT(1.5D0+PYR(0))
10792 ZMIN=2D0*PMQ(JT)/SHPR
10793 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10794 & (SHPR*(SHPR-PMQ(3-JT)))
10795 ZMAX=MIN(1D0-XH,ZMAX)
10796 IF(ZMIN.GE.ZMAX) GOTO 230
10797 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10798 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10799 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10800 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10801 IF(SQC1.LT.1D-8) GOTO 230
10802 C1=SQRT(SQC1)
10803 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10804 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10805 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10806 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10807 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10808 IF(SQC1.LT.1D-8) GOTO 230
10809 C1=SQRT(SQC1)
10810 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10811 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10812 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10813 PHIR=PARU(2)*PYR(0)
10814 CPHI=COS(PHIR)
10815 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10816 & SQRT(1D0-CTHE(2)**2)*CPHI
10817 Z1=2D0-Z(JT)
10818 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10819 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10820 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10821 & PMQ(3-JT)**2/SHP))
10822 ZMIN=2D0*PMQ(3-JT)/SHPR
10823 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10824 ZMAX=MIN(1D0-XH,ZMAX)
10825 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10826 KCC=22
10827 KFRES=25
10828
10829 ELSEIF(ISUB.EQ.10) THEN
10830C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10831 IF(MINT(2).EQ.1) THEN
10832 KCC=22
10833 ELSE
10834C...W exchange: need to mix flavours according to CKM matrix
10835 DO 280 JT=1,2
10836 I=MINT(14+JT)
10837 IA=IABS(I)
10838 IF(IA.LE.10) THEN
10839 RVCKM=VINT(180+I)*PYR(0)
10840 DO 270 J=1,MSTP(1)
10841 IB=2*J-1+MOD(IA,2)
10842 IPM=(5-ISIGN(1,I))/2
10843 IDC=J+MDCY(IA,2)+2
10844 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10845 MINT(20+JT)=ISIGN(IB,I)
10846 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10847 IF(RVCKM.LE.0D0) GOTO 280
10848 270 CONTINUE
10849 ELSE
10850 IB=2*((IA+1)/2)-1+MOD(IA,2)
10851 MINT(20+JT)=ISIGN(IB,I)
10852 ENDIF
10853 280 CONTINUE
10854 KCC=22
10855 ENDIF
10856 ENDIF
10857
10858 ELSEIF(ISUB.LE.20) THEN
10859 IF(ISUB.EQ.11) THEN
10860C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10861 KCC=MINT(2)
10862 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10863
10864 ELSEIF(ISUB.EQ.12) THEN
10865C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10866 MINT(21)=ISIGN(KFLF,MINT(15))
10867 MINT(22)=-MINT(21)
10868 KCC=4
10869
10870 ELSEIF(ISUB.EQ.13) THEN
10871C...f + fbar -> g + g; th arbitrary
10872 MINT(21)=21
10873 MINT(22)=21
10874 KCC=MINT(2)+4
10875
10876 ELSEIF(ISUB.EQ.14) THEN
10877C...f + fbar -> g + gamma; th arbitrary
10878 IF(PYR(0).GT.0.5D0) JS=2
10879 MINT(20+JS)=21
10880 MINT(23-JS)=22
10881 KCC=17+JS
10882
10883 ELSEIF(ISUB.EQ.15) THEN
10884C...f + fbar -> g + Z0; th arbitrary
10885 IF(PYR(0).GT.0.5D0) JS=2
10886 MINT(20+JS)=21
10887 MINT(23-JS)=23
10888 KCC=17+JS
10889
10890 ELSEIF(ISUB.EQ.16) THEN
10891C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10892 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10893 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10894 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10895 MINT(20+JS)=21
10896 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10897 KCC=17+JS
10898
10899 ELSEIF(ISUB.EQ.17) THEN
10900C...f + fbar -> g + h0; th arbitrary
10901 IF(PYR(0).GT.0.5D0) JS=2
10902 MINT(20+JS)=21
10903 MINT(23-JS)=25
10904 KCC=17+JS
10905
10906 ELSEIF(ISUB.EQ.18) THEN
10907C...f + fbar -> gamma + gamma; th arbitrary
10908 MINT(21)=22
10909 MINT(22)=22
10910
10911 ELSEIF(ISUB.EQ.19) THEN
10912C...f + fbar -> gamma + Z0; th arbitrary
10913 IF(PYR(0).GT.0.5D0) JS=2
10914 MINT(20+JS)=22
10915 MINT(23-JS)=23
10916
10917 ELSEIF(ISUB.EQ.20) THEN
10918C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
10919C...(p(fbar')-p(W+))**2
10920 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10921 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10922 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10923 MINT(20+JS)=22
10924 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10925 ENDIF
10926
10927 ELSEIF(ISUB.LE.30) THEN
10928 IF(ISUB.EQ.21) THEN
10929C...f + fbar -> gamma + h0; th arbitrary
10930 IF(PYR(0).GT.0.5D0) JS=2
10931 MINT(20+JS)=22
10932 MINT(23-JS)=25
10933
10934 ELSEIF(ISUB.EQ.22) THEN
10935C...f + fbar -> Z0 + Z0; th arbitrary
10936 MINT(21)=23
10937 MINT(22)=23
10938
10939 ELSEIF(ISUB.EQ.23) THEN
10940C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10941 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10942 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10943 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10944 MINT(20+JS)=23
10945 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10946
10947 ELSEIF(ISUB.EQ.24) THEN
10948C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
10949 IF(PYR(0).GT.0.5D0) JS=2
10950 MINT(20+JS)=23
10951 MINT(23-JS)=KFHIGG
10952
10953 ELSEIF(ISUB.EQ.25) THEN
10954C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
10955 MINT(21)=-ISIGN(24,MINT(15))
10956 MINT(22)=-MINT(21)
10957
10958 ELSEIF(ISUB.EQ.26) THEN
10959C...f + fbar' -> W+/- + h0 (or H0, or A0);
10960C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10961 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10962 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10963 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
10964 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
10965 MINT(23-JS)=KFHIGG
10966
10967 ELSEIF(ISUB.EQ.27) THEN
10968C...f + fbar -> h0 + h0
10969
10970 ELSEIF(ISUB.EQ.28) THEN
10971C...f + g -> f + g; th = (p(f)-p(f))**2
10972 IF(MINT(15).EQ.21) JS=2
10973 KCC=MINT(2)+6
10974 IF(MINT(15).EQ.21) KCC=KCC+2
10975 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
10976 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
10977
10978 ELSEIF(ISUB.EQ.29) THEN
10979C...f + g -> f + gamma; th = (p(f)-p(f))**2
10980 IF(MINT(15).EQ.21) JS=2
10981 MINT(23-JS)=22
10982 KCC=15+JS
10983 KCS=ISIGN(1,MINT(14+JS))
10984
10985 ELSEIF(ISUB.EQ.30) THEN
10986C...f + g -> f + Z0; th = (p(f)-p(f))**2
10987 IF(MINT(15).EQ.21) JS=2
10988 MINT(23-JS)=23
10989 KCC=15+JS
10990 KCS=ISIGN(1,MINT(14+JS))
10991 ENDIF
10992
10993 ELSEIF(ISUB.LE.40) THEN
10994 IF(ISUB.EQ.31) THEN
10995C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
10996 IF(MINT(15).EQ.21) JS=2
10997 I=MINT(14+JS)
10998 IA=IABS(I)
10999 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11000 RVCKM=VINT(180+I)*PYR(0)
11001 DO 290 J=1,MSTP(1)
11002 IB=2*J-1+MOD(IA,2)
11003 IPM=(5-ISIGN(1,I))/2
11004 IDC=J+MDCY(IA,2)+2
11005 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11006 MINT(20+JS)=ISIGN(IB,I)
11007 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11008 IF(RVCKM.LE.0D0) GOTO 300
11009 290 CONTINUE
11010 300 KCC=15+JS
11011 KCS=ISIGN(1,MINT(14+JS))
11012
11013 ELSEIF(ISUB.EQ.32) THEN
11014C...f + g -> f + h0; th = (p(f)-p(f))**2
11015 IF(MINT(15).EQ.21) JS=2
11016 MINT(23-JS)=25
11017 KCC=15+JS
11018 KCS=ISIGN(1,MINT(14+JS))
11019
11020 ELSEIF(ISUB.EQ.33) THEN
11021C...f + gamma -> f + g; th=(p(f)-p(f))**2
11022 IF(MINT(15).EQ.22) JS=2
11023 MINT(23-JS)=21
11024 KCC=24+JS
11025 KCS=ISIGN(1,MINT(14+JS))
11026
11027 ELSEIF(ISUB.EQ.34) THEN
11028C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11029 IF(MINT(15).EQ.22) JS=2
11030 KCC=22
11031 KCS=ISIGN(1,MINT(14+JS))
11032
11033 ELSEIF(ISUB.EQ.35) THEN
11034C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11035 IF(MINT(15).EQ.22) JS=2
11036 MINT(23-JS)=23
11037 KCC=22
11038
11039 ELSEIF(ISUB.EQ.36) THEN
11040C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11041 IF(MINT(15).EQ.22) JS=2
11042 I=MINT(14+JS)
11043 IA=IABS(I)
11044 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11045 IF(IA.LE.10) THEN
11046 RVCKM=VINT(180+I)*PYR(0)
11047 DO 310 J=1,MSTP(1)
11048 IB=2*J-1+MOD(IA,2)
11049 IPM=(5-ISIGN(1,I))/2
11050 IDC=J+MDCY(IA,2)+2
11051 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11052 MINT(20+JS)=ISIGN(IB,I)
11053 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11054 IF(RVCKM.LE.0D0) GOTO 320
11055 310 CONTINUE
11056 ELSE
11057 IB=2*((IA+1)/2)-1+MOD(IA,2)
11058 MINT(20+JS)=ISIGN(IB,I)
11059 ENDIF
11060 320 KCC=22
11061
11062 ELSEIF(ISUB.EQ.37) THEN
11063C...f + gamma -> f + h0
11064
11065 ELSEIF(ISUB.EQ.38) THEN
11066C...f + Z0 -> f + g
11067
11068 ELSEIF(ISUB.EQ.39) THEN
11069C...f + Z0 -> f + gamma
11070
11071 ELSEIF(ISUB.EQ.40) THEN
11072C...f + Z0 -> f + Z0
11073 ENDIF
11074
11075 ELSEIF(ISUB.LE.50) THEN
11076 IF(ISUB.EQ.41) THEN
11077C...f + Z0 -> f' + W+/-
11078
11079 ELSEIF(ISUB.EQ.42) THEN
11080C...f + Z0 -> f + h0
11081
11082 ELSEIF(ISUB.EQ.43) THEN
11083C...f + W+/- -> f' + g
11084
11085 ELSEIF(ISUB.EQ.44) THEN
11086C...f + W+/- -> f' + gamma
11087
11088 ELSEIF(ISUB.EQ.45) THEN
11089C...f + W+/- -> f' + Z0
11090
11091 ELSEIF(ISUB.EQ.46) THEN
11092C...f + W+/- -> f' + W+/-
11093
11094 ELSEIF(ISUB.EQ.47) THEN
11095C...f + W+/- -> f' + h0
11096
11097 ELSEIF(ISUB.EQ.48) THEN
11098C...f + h0 -> f + g
11099
11100 ELSEIF(ISUB.EQ.49) THEN
11101C...f + h0 -> f + gamma
11102
11103 ELSEIF(ISUB.EQ.50) THEN
11104C...f + h0 -> f + Z0
11105 ENDIF
11106
11107 ELSEIF(ISUB.LE.60) THEN
11108 IF(ISUB.EQ.51) THEN
11109C...f + h0 -> f' + W+/-
11110
11111 ELSEIF(ISUB.EQ.52) THEN
11112C...f + h0 -> f + h0
11113
11114 ELSEIF(ISUB.EQ.53) THEN
11115C...g + g -> f + fbar; th arbitrary
11116 KCS=(-1)**INT(1.5D0+PYR(0))
11117 MINT(21)=ISIGN(KFLF,KCS)
11118 MINT(22)=-MINT(21)
11119 KCC=MINT(2)+10
11120
11121 ELSEIF(ISUB.EQ.54) THEN
11122C...g + gamma -> f + fbar; th arbitrary
11123 KCS=(-1)**INT(1.5D0+PYR(0))
11124 MINT(21)=ISIGN(KFLF,KCS)
11125 MINT(22)=-MINT(21)
11126 KCC=27
11127 IF(MINT(16).EQ.21) KCC=28
11128
11129 ELSEIF(ISUB.EQ.55) THEN
11130C...g + Z0 -> f + fbar
11131
11132 ELSEIF(ISUB.EQ.56) THEN
11133C...g + W+/- -> f + fbar'
11134
11135 ELSEIF(ISUB.EQ.57) THEN
11136C...g + h0 -> f + fbar
11137
11138 ELSEIF(ISUB.EQ.58) THEN
11139C...gamma + gamma -> f + fbar; th arbitrary
11140 KCS=(-1)**INT(1.5D0+PYR(0))
11141 MINT(21)=ISIGN(KFLF,KCS)
11142 MINT(22)=-MINT(21)
11143 KCC=21
11144
11145 ELSEIF(ISUB.EQ.59) THEN
11146C...gamma + Z0 -> f + fbar
11147
11148 ELSEIF(ISUB.EQ.60) THEN
11149C...gamma + W+/- -> f + fbar'
11150 ENDIF
11151
11152 ELSEIF(ISUB.LE.70) THEN
11153 IF(ISUB.EQ.61) THEN
11154C...gamma + h0 -> f + fbar
11155
11156 ELSEIF(ISUB.EQ.62) THEN
11157C...Z0 + Z0 -> f + fbar
11158
11159 ELSEIF(ISUB.EQ.63) THEN
11160C...Z0 + W+/- -> f + fbar'
11161
11162 ELSEIF(ISUB.EQ.64) THEN
11163C...Z0 + h0 -> f + fbar
11164
11165 ELSEIF(ISUB.EQ.65) THEN
11166C...W+ + W- -> f + fbar
11167
11168 ELSEIF(ISUB.EQ.66) THEN
11169C...W+/- + h0 -> f + fbar'
11170
11171 ELSEIF(ISUB.EQ.67) THEN
11172C...h0 + h0 -> f + fbar
11173
11174 ELSEIF(ISUB.EQ.68) THEN
11175C...g + g -> g + g; th arbitrary
11176 KCC=MINT(2)+12
11177 KCS=(-1)**INT(1.5D0+PYR(0))
11178
11179 ELSEIF(ISUB.EQ.69) THEN
11180C...gamma + gamma -> W+ + W-; th arbitrary
11181 MINT(21)=24
11182 MINT(22)=-24
11183 KCC=21
11184
11185 ELSEIF(ISUB.EQ.70) THEN
11186C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11187 IF(MINT(15).EQ.22) MINT(21)=23
11188 IF(MINT(16).EQ.22) MINT(22)=23
11189 KCC=21
11190 ENDIF
11191
11192 ELSEIF(ISUB.LE.80) THEN
11193 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11194C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11195 XH=SH/SHP
11196 MINT(21)=MINT(15)
11197 MINT(22)=MINT(16)
11198 PMQ(1)=PYMASS(MINT(21))
11199 PMQ(2)=PYMASS(MINT(22))
11200 330 JT=INT(1.5D0+PYR(0))
11201 ZMIN=2D0*PMQ(JT)/SHPR
11202 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11203 & (SHPR*(SHPR-PMQ(3-JT)))
11204 ZMAX=MIN(1D0-XH,ZMAX)
11205 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11206 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11207 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11208 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11209 IF(SQC1.LT.1D-8) GOTO 330
11210 C1=SQRT(SQC1)
11211 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11212 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11213 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11214 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11215 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11216 IF(SQC1.LT.1D-8) GOTO 330
11217 C1=SQRT(SQC1)
11218 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11219 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11220 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11221 PHIR=PARU(2)*PYR(0)
11222 CPHI=COS(PHIR)
11223 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11224 & SQRT(1D0-CTHE(2)**2)*CPHI
11225 Z1=2D0-Z(JT)
11226 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11227 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11228 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11229 & PMQ(3-JT)**2/SHP))
11230 ZMIN=2D0*PMQ(3-JT)/SHPR
11231 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11232 ZMAX=MIN(1D0-XH,ZMAX)
11233 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11234 KCC=22
11235
11236 ELSEIF(ISUB.EQ.73) THEN
11237C...Z0 + W+/- -> Z0 + W+/-
11238 JS=MINT(2)
11239 XH=SH/SHP
11240 340 JT=3-MINT(2)
11241 I=MINT(14+JT)
11242 IA=IABS(I)
11243 IF(IA.LE.10) THEN
11244 RVCKM=VINT(180+I)*PYR(0)
11245 DO 350 J=1,MSTP(1)
11246 IB=2*J-1+MOD(IA,2)
11247 IPM=(5-ISIGN(1,I))/2
11248 IDC=J+MDCY(IA,2)+2
11249 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11250 MINT(20+JT)=ISIGN(IB,I)
11251 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11252 IF(RVCKM.LE.0D0) GOTO 360
11253 350 CONTINUE
11254 ELSE
11255 IB=2*((IA+1)/2)-1+MOD(IA,2)
11256 MINT(20+JT)=ISIGN(IB,I)
11257 ENDIF
11258 360 PMQ(JT)=PYMASS(MINT(20+JT))
11259 MINT(23-JT)=MINT(17-JT)
11260 PMQ(3-JT)=PYMASS(MINT(23-JT))
11261 JT=INT(1.5D0+PYR(0))
11262 ZMIN=2D0*PMQ(JT)/SHPR
11263 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11264 & (SHPR*(SHPR-PMQ(3-JT)))
11265 ZMAX=MIN(1D0-XH,ZMAX)
11266 IF(ZMIN.GE.ZMAX) GOTO 340
11267 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11268 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11269 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11270 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11271 IF(SQC1.LT.1D-8) GOTO 340
11272 C1=SQRT(SQC1)
11273 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11274 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11275 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11276 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11277 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11278 IF(SQC1.LT.1D-8) GOTO 340
11279 C1=SQRT(SQC1)
11280 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11281 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11282 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11283 PHIR=PARU(2)*PYR(0)
11284 CPHI=COS(PHIR)
11285 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11286 & SQRT(1D0-CTHE(2)**2)*CPHI
11287 Z1=2D0-Z(JT)
11288 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11289 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11290 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11291 & PMQ(3-JT)**2/SHP))
11292 ZMIN=2D0*PMQ(3-JT)/SHPR
11293 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11294 ZMAX=MIN(1D0-XH,ZMAX)
11295 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11296 KCC=22
11297
11298 ELSEIF(ISUB.EQ.74) THEN
11299C...Z0 + h0 -> Z0 + h0
11300
11301 ELSEIF(ISUB.EQ.75) THEN
11302C...W+ + W- -> gamma + gamma
11303
11304 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11305C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11306 XH=SH/SHP
11307 370 DO 400 JT=1,2
11308 I=MINT(14+JT)
11309 IA=IABS(I)
11310 IF(IA.LE.10) THEN
11311 RVCKM=VINT(180+I)*PYR(0)
11312 DO 380 J=1,MSTP(1)
11313 IB=2*J-1+MOD(IA,2)
11314 IPM=(5-ISIGN(1,I))/2
11315 IDC=J+MDCY(IA,2)+2
11316 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11317 MINT(20+JT)=ISIGN(IB,I)
11318 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11319 IF(RVCKM.LE.0D0) GOTO 390
11320 380 CONTINUE
11321 ELSE
11322 IB=2*((IA+1)/2)-1+MOD(IA,2)
11323 MINT(20+JT)=ISIGN(IB,I)
11324 ENDIF
11325 390 PMQ(JT)=PYMASS(MINT(20+JT))
11326 400 CONTINUE
11327 JT=INT(1.5D0+PYR(0))
11328 ZMIN=2D0*PMQ(JT)/SHPR
11329 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11330 & (SHPR*(SHPR-PMQ(3-JT)))
11331 ZMAX=MIN(1D0-XH,ZMAX)
11332 IF(ZMIN.GE.ZMAX) GOTO 370
11333 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11334 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11335 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11336 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11337 IF(SQC1.LT.1D-8) GOTO 370
11338 C1=SQRT(SQC1)
11339 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11340 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11341 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11342 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11343 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11344 IF(SQC1.LT.1D-8) GOTO 370
11345 C1=SQRT(SQC1)
11346 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11347 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11348 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11349 PHIR=PARU(2)*PYR(0)
11350 CPHI=COS(PHIR)
11351 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11352 & SQRT(1D0-CTHE(2)**2)*CPHI
11353 Z1=2D0-Z(JT)
11354 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11355 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11356 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11357 & PMQ(3-JT)**2/SHP))
11358 ZMIN=2D0*PMQ(3-JT)/SHPR
11359 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11360 ZMAX=MIN(1D0-XH,ZMAX)
11361 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11362 KCC=22
11363
11364 ELSEIF(ISUB.EQ.78) THEN
11365C...W+/- + h0 -> W+/- + h0
11366
11367 ELSEIF(ISUB.EQ.79) THEN
11368C...h0 + h0 -> h0 + h0
11369
11370 ELSEIF(ISUB.EQ.80) THEN
11371C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11372 IF(MINT(15).EQ.22) JS=2
11373 I=MINT(14+JS)
11374 IA=IABS(I)
11375 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11376 IB=3-IA
11377 MINT(20+JS)=ISIGN(IB,I)
11378 KCC=22
11379 ENDIF
11380
11381 ELSEIF(ISUB.LE.90) THEN
11382 IF(ISUB.EQ.81) THEN
11383C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11384 MINT(21)=ISIGN(MINT(55),MINT(15))
11385 MINT(22)=-MINT(21)
11386 KCC=4
11387
11388 ELSEIF(ISUB.EQ.82) THEN
11389C...g + g -> Q + Qbar; th arbitrary
11390 KCS=(-1)**INT(1.5D0+PYR(0))
11391 MINT(21)=ISIGN(MINT(55),KCS)
11392 MINT(22)=-MINT(21)
11393 KCC=MINT(2)+10
11394
11395 ELSEIF(ISUB.EQ.83) THEN
11396C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11397 KFOLD=MINT(16)
11398 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11399 KFAOLD=IABS(KFOLD)
11400 IF(KFAOLD.GT.10) THEN
11401 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11402 ELSE
11403 RCKM=VINT(180+KFOLD)*PYR(0)
11404 IPM=(5-ISIGN(1,KFOLD))/2
11405 KFANEW=-MOD(KFAOLD+1,2)
11406 410 KFANEW=KFANEW+2
11407 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11408 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11409 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11410 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11411 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11412 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11413 ENDIF
11414 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11415 ENDIF
11416 IF(MINT(2).EQ.1) THEN
11417 MINT(21)=ISIGN(MINT(55),MINT(15))
11418 MINT(22)=ISIGN(KFANEW,MINT(16))
11419 ELSE
11420 MINT(21)=ISIGN(KFANEW,MINT(15))
11421 MINT(22)=ISIGN(MINT(55),MINT(16))
11422 JS=2
11423 ENDIF
11424 KCC=22
11425
11426 ELSEIF(ISUB.EQ.84) THEN
11427C...g + gamma -> Q + Qbar; th arbitary
11428 KCS=(-1)**INT(1.5D0+PYR(0))
11429 MINT(21)=ISIGN(MINT(55),KCS)
11430 MINT(22)=-MINT(21)
11431 KCC=27
11432 IF(MINT(16).EQ.21) KCC=28
11433
11434 ELSEIF(ISUB.EQ.85) THEN
11435C...gamma + gamma -> F + Fbar; th arbitary
11436 KCS=(-1)**INT(1.5D0+PYR(0))
11437 MINT(21)=ISIGN(MINT(56),KCS)
11438 MINT(22)=-MINT(21)
11439 KCC=21
11440
11441 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11442C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11443 MINT(21)=KFPR(ISUB,1)
11444 MINT(22)=KFPR(ISUB,2)
11445 KCC=24
11446 KCS=(-1)**INT(1.5D0+PYR(0))
11447 ENDIF
11448
11449 ELSEIF(ISUB.LE.100) THEN
11450 IF(ISUB.EQ.95) THEN
11451C...Low-pT ( = energyless g + g -> g + g)
11452 KCC=MINT(2)+12
11453 KCS=(-1)**INT(1.5D0+PYR(0))
11454
11455 ELSEIF(ISUB.EQ.96) THEN
11456C...Multiple interactions (should be reassigned to QCD process)
11457 ENDIF
11458
11459 ELSEIF(ISUB.LE.110) THEN
11460 IF(ISUB.EQ.101) THEN
11461C...g + g -> gamma*/Z0
11462 KCC=21
11463 KFRES=22
11464
11465 ELSEIF(ISUB.EQ.102) THEN
11466C...g + g -> h0 (or H0, or A0)
11467 KCC=21
11468 KFRES=KFHIGG
11469
11470 ELSEIF(ISUB.EQ.103) THEN
11471C...gamma + gamma -> h0 (or H0, or A0)
11472 KCC=21
11473 KFRES=KFHIGG
11474
11475 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11476C...g + g -> chi_0c or chi_2c.
11477 KCC=21
11478 KFRES=KFPR(ISUB,1)
11479
11480 ELSEIF(ISUB.EQ.106) THEN
11481C...g + g -> J/Psi + gamma
11482 MINT(21)=KFPR(ISUB,1)
11483 MINT(22)=KFPR(ISUB,2)
11484 KCC=21
11485
11486 ELSEIF(ISUB.EQ.107) THEN
11487C...g + gamma -> J/Psi + g
11488 MINT(21)=KFPR(ISUB,1)
11489 MINT(22)=KFPR(ISUB,2)
11490 KCC=22
11491 IF(MINT(16).EQ.22) KCC=33
11492
11493 ELSEIF(ISUB.EQ.108) THEN
11494C...gamma + gamma -> J/Psi + gamma
11495 MINT(21)=KFPR(ISUB,1)
11496 MINT(22)=KFPR(ISUB,2)
11497
11498 ELSEIF(ISUB.EQ.110) THEN
11499C...f + fbar -> gamma + h0; th arbitrary
11500 IF(PYR(0).GT.0.5D0) JS=2
11501 MINT(20+JS)=22
11502 MINT(23-JS)=KFHIGG
11503 ENDIF
11504
11505 ELSEIF(ISUB.LE.120) THEN
11506 IF(ISUB.EQ.111) THEN
11507C...f + fbar -> g + h0; th arbitrary
11508 IF(PYR(0).GT.0.5D0) JS=2
11509 MINT(20+JS)=21
11510 MINT(23-JS)=KFHIGG
11511 KCC=17+JS
11512
11513 ELSEIF(ISUB.EQ.112) THEN
11514C...f + g -> f + h0; th = (p(f) - p(f))**2
11515 IF(MINT(15).EQ.21) JS=2
11516 MINT(23-JS)=KFHIGG
11517 KCC=15+JS
11518 KCS=ISIGN(1,MINT(14+JS))
11519
11520 ELSEIF(ISUB.EQ.113) THEN
11521C...g + g -> g + h0; th arbitrary
11522 IF(PYR(0).GT.0.5D0) JS=2
11523 MINT(23-JS)=KFHIGG
11524 KCC=22+JS
11525 KCS=(-1)**INT(1.5D0+PYR(0))
11526
11527 ELSEIF(ISUB.EQ.114) THEN
11528C...g + g -> gamma + gamma; th arbitrary
11529 IF(PYR(0).GT.0.5D0) JS=2
11530 MINT(21)=22
11531 MINT(22)=22
11532 KCC=21
11533
11534 ELSEIF(ISUB.EQ.115) THEN
11535C...g + g -> g + gamma; th arbitrary
11536 IF(PYR(0).GT.0.5D0) JS=2
11537 MINT(23-JS)=22
11538 KCC=22+JS
11539 KCS=(-1)**INT(1.5D0+PYR(0))
11540
11541 ELSEIF(ISUB.EQ.116) THEN
11542C...g + g -> gamma + Z0
11543
11544 ELSEIF(ISUB.EQ.117) THEN
11545C...g + g -> Z0 + Z0
11546
11547 ELSEIF(ISUB.EQ.118) THEN
11548C...g + g -> W+ + W-
11549 ENDIF
11550
11551 ELSEIF(ISUB.LE.140) THEN
11552 IF(ISUB.EQ.121) THEN
11553C...g + g -> Q + Qbar + h0
11554 KCS=(-1)**INT(1.5D0+PYR(0))
11555 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11556 MINT(22)=-MINT(21)
11557 KCC=11+INT(0.5D0+PYR(0))
11558 KFRES=KFHIGG
11559
11560 ELSEIF(ISUB.EQ.122) THEN
11561C...q + qbar -> Q + Qbar + h0
11562 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11563 MINT(22)=-MINT(21)
11564 KCC=4
11565 KFRES=KFHIGG
11566
11567 ELSEIF(ISUB.EQ.123) THEN
11568C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11569C...inner process)
11570 KCC=22
11571 KFRES=KFHIGG
11572
11573 ELSEIF(ISUB.EQ.124) THEN
11574C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11575C...inner process)
11576 DO 430 JT=1,2
11577 I=MINT(14+JT)
11578 IA=IABS(I)
11579 IF(IA.LE.10) THEN
11580 RVCKM=VINT(180+I)*PYR(0)
11581 DO 420 J=1,MSTP(1)
11582 IB=2*J-1+MOD(IA,2)
11583 IPM=(5-ISIGN(1,I))/2
11584 IDC=J+MDCY(IA,2)+2
11585 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11586 MINT(20+JT)=ISIGN(IB,I)
11587 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11588 IF(RVCKM.LE.0D0) GOTO 430
11589 420 CONTINUE
11590 ELSE
11591 IB=2*((IA+1)/2)-1+MOD(IA,2)
11592 MINT(20+JT)=ISIGN(IB,I)
11593 ENDIF
11594 430 CONTINUE
11595 KCC=22
11596 KFRES=KFHIGG
11597
11598 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11599C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11600 IF(MINT(15).EQ.22) JS=2
11601 MINT(23-JS)=21
11602 KCC=24+JS
11603 KCS=ISIGN(1,MINT(14+JS))
11604
11605 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11606C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11607 IF(MINT(15).EQ.22) JS=2
11608 KCC=22
11609 KCS=ISIGN(1,MINT(14+JS))
11610
11611 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11612C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11613 KCS=(-1)**INT(1.5D0+PYR(0))
11614 MINT(21)=ISIGN(KFLF,KCS)
11615 MINT(22)=-MINT(21)
11616 KCC=27
11617 IF(MINT(16).EQ.21) KCC=28
11618
11619 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11620C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11621 KCS=(-1)**INT(1.5D0+PYR(0))
11622 MINT(21)=ISIGN(KFLF,KCS)
11623 MINT(22)=-MINT(21)
11624 KCC=21
11625
11626 ENDIF
11627
11628 ELSEIF(ISUB.LE.160) THEN
11629 IF(ISUB.EQ.141) THEN
11630C...f + fbar -> gamma*/Z0/Z'0
11631 KFRES=32
11632
11633 ELSEIF(ISUB.EQ.142) THEN
11634C...f + fbar' -> W'+/-
11635 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11636 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11637 KFRES=ISIGN(34,KCH1+KCH2)
11638
11639 ELSEIF(ISUB.EQ.143) THEN
11640C...f + fbar' -> H+/-
11641 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11642 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11643 KFRES=ISIGN(37,KCH1+KCH2)
11644
11645 ELSEIF(ISUB.EQ.144) THEN
11646C...f + fbar' -> R
11647 KFRES=ISIGN(41,MINT(15)+MINT(16))
11648
11649 ELSEIF(ISUB.EQ.145) THEN
11650C...q + l -> LQ (leptoquark)
11651 IF(IABS(MINT(16)).LE.8) JS=2
11652 KFRES=ISIGN(42,MINT(14+JS))
11653 KCC=28+JS
11654 KCS=ISIGN(1,MINT(14+JS))
11655
11656 ELSEIF(ISUB.EQ.146) THEN
11657C...e + gamma -> e* (excited lepton)
11658 IF(MINT(15).EQ.22) JS=2
11659 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11660 KCC=22
11661
11662 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11663C...q + g -> q* (excited quark)
11664 IF(MINT(15).EQ.21) JS=2
11665 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11666 KCC=30+JS
11667 KCS=ISIGN(1,MINT(14+JS))
11668
11669 ELSEIF(ISUB.EQ.149) THEN
11670C...g + g -> eta_tc
11671 KFRES=KTECHN+331
11672 KCC=23
11673 KCS=(-1)**INT(1.5D0+PYR(0))
11674 ENDIF
11675
11676 ELSEIF(ISUB.LE.200) THEN
11677 IF(ISUB.EQ.161) THEN
11678C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11679 IF(MINT(15).EQ.21) JS=2
11680 I=MINT(14+JS)
11681 IA=IABS(I)
11682 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11683 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11684 MINT(20+JS)=ISIGN(IB,I)
11685 KCC=15+JS
11686 KCS=ISIGN(1,MINT(14+JS))
11687
11688 ELSEIF(ISUB.EQ.162) THEN
11689C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11690 IF(MINT(15).EQ.21) JS=2
11691 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11692 KFLQL=KFDP(MDCY(42,2),2)
11693 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11694 KCC=15+JS
11695 KCS=ISIGN(1,MINT(14+JS))
11696
11697 ELSEIF(ISUB.EQ.163) THEN
11698C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11699 KCS=(-1)**INT(1.5D0+PYR(0))
11700 MINT(21)=ISIGN(42,KCS)
11701 MINT(22)=-MINT(21)
11702 KCC=MINT(2)+10
11703
11704 ELSEIF(ISUB.EQ.164) THEN
11705C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11706 MINT(21)=ISIGN(42,MINT(15))
11707 MINT(22)=-MINT(21)
11708 KCC=4
11709
11710 ELSEIF(ISUB.EQ.165) THEN
11711C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11712 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11713 MINT(22)=-MINT(21)
11714
11715 ELSEIF(ISUB.EQ.166) THEN
11716C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11717 IF(MOD(MINT(15),2).EQ.0) THEN
11718 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11719 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11720 ELSE
11721 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11722 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11723 ENDIF
11724
11725 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11726C...q + q' -> q" + q* (excited quark)
11727 KFQSTR=KFPR(ISUB,2)
11728 KFQEXC=MOD(KFQSTR,KEXCIT)
11729 JS=MINT(2)
11730 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11731 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11732 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11733 KCC=22
11734 JS=3-JS
11735
11736 ELSEIF(ISUB.EQ.169) THEN
11737C...q + qbar -> e + e* (excited lepton)
11738 KFQSTR=KFPR(ISUB,2)
11739 KFQEXC=MOD(KFQSTR,KEXCIT)
11740 JS=MINT(2)
11741 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11742 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11743 JS=3-JS
11744
11745 ELSEIF(ISUB.EQ.191) THEN
11746C...f + fbar -> rho_tc0.
11747 KFRES=KTECHN+113
11748
11749 ELSEIF(ISUB.EQ.192) THEN
11750C...f + fbar' -> rho_tc+/-
11751 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11752 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11753 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11754
11755 ELSEIF(ISUB.EQ.193) THEN
11756C...f + fbar -> omega_tc0.
11757 KFRES=KTECHN+223
11758
11759 ELSEIF(ISUB.EQ.194) THEN
11760C...f + fbar -> f' + fbar' via mixture of s-channel
11761C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11762 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11763 MINT(22)=-MINT(21)
11764
11765 ELSEIF(ISUB.EQ.195) THEN
11766C...f + fbar' -> f'' + fbar''' via s-channel
11767C...rho_tc+ th=(p(f)-p(f'))**2
11768C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11769 IF(MOD(MINT(15),2).EQ.0) THEN
11770 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11771 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11772 ELSE
11773 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11774 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11775 ENDIF
11776 ENDIF
11777
11778CMRENNA++
11779 ELSEIF(ISUB.LE.215) THEN
11780 IF(ISUB.EQ.201) THEN
11781C...f + fbar -> ~e_L + ~e_Lbar
11782 MINT(21)=ISIGN(KSUSY1+11,KCS)
11783 MINT(22)=-MINT(21)
11784
11785 ELSEIF(ISUB.EQ.202) THEN
11786C...f + fbar -> ~e_R + ~e_Rbar
11787 MINT(21)=ISIGN(KSUSY2+11,KCS)
11788 MINT(22)=-MINT(21)
11789
11790 ELSEIF(ISUB.EQ.203) THEN
11791C...f + fbar -> ~e_L + ~e_Rbar
11792 IF(MINT(15).LT.0) JS=2
11793 IF(MINT(2).EQ.1) THEN
11794 MINT(20+JS)=KFPR(ISUB,1)
11795 MINT(23-JS)=-KFPR(ISUB,2)
11796 ELSE
11797 MINT(20+JS)=-KFPR(ISUB,1)
11798 MINT(23-JS)=KFPR(ISUB,2)
11799 ENDIF
11800
11801 ELSEIF(ISUB.EQ.204) THEN
11802C...f + fbar -> ~mu_L + ~mu_Lbar
11803 MINT(21)=ISIGN(KSUSY1+13,KCS)
11804 MINT(22)=-MINT(21)
11805
11806 ELSEIF(ISUB.EQ.205) THEN
11807C...f + fbar -> ~mu_R + ~mu_Rbar
11808 MINT(21)=ISIGN(KSUSY2+13,KCS)
11809 MINT(22)=-MINT(21)
11810
11811 ELSEIF(ISUB.EQ.206) THEN
11812C...f + fbar -> ~mu_L + ~mu_Rbar
11813 IF(MINT(15).LT.0) JS=2
11814 IF(MINT(2).EQ.1) THEN
11815 MINT(20+JS)=KFPR(ISUB,1)
11816 MINT(23-JS)=-KFPR(ISUB,2)
11817 ELSE
11818 MINT(20+JS)=-KFPR(ISUB,1)
11819 MINT(23-JS)=KFPR(ISUB,2)
11820 ENDIF
11821
11822 ELSEIF(ISUB.EQ.207) THEN
11823C...f + fbar -> ~tau_1 + ~tau_1bar
11824 MINT(21)=ISIGN(KSUSY1+15,KCS)
11825 MINT(22)=-MINT(21)
11826
11827 ELSEIF(ISUB.EQ.208) THEN
11828C...f + fbar -> ~tau_2 + ~tau_2bar
11829 MINT(21)=ISIGN(KSUSY2+15,KCS)
11830 MINT(22)=-MINT(21)
11831
11832 ELSEIF(ISUB.EQ.209) THEN
11833C...f + fbar -> ~tau_1 + ~tau_2bar
11834 IF(MINT(15).LT.0) JS=2
11835 IF(MINT(2).EQ.1) THEN
11836 MINT(20+JS)=KFPR(ISUB,1)
11837 MINT(23-JS)=-KFPR(ISUB,2)
11838 ELSE
11839 MINT(20+JS)=-KFPR(ISUB,1)
11840 MINT(23-JS)=KFPR(ISUB,2)
11841 ENDIF
11842
11843 ELSEIF(ISUB.EQ.210) THEN
11844C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11845 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11846 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11847 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11848 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11849
11850 ELSEIF(ISUB.EQ.211) THEN
11851C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11852 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11853 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11854 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11855 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11856
11857 ELSEIF(ISUB.EQ.212) THEN
11858C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11859 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11860 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11861 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11862 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11863
11864 ELSEIF(ISUB.EQ.213) THEN
11865C...f + fbar -> ~nul + ~nulbar
11866 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11867 MINT(22)=-MINT(21)
11868
11869 ELSEIF(ISUB.EQ.214) THEN
11870C...f + fbar -> ~nutau + ~nutaubar
11871 MINT(21)=ISIGN(KSUSY1+16,KCS)
11872 MINT(22)=-MINT(21)
11873 ENDIF
11874
11875 ELSEIF(ISUB.LE.225) THEN
11876 IF(ISUB.EQ.216) THEN
11877C...f + fbar -> ~chi01 + ~chi01
11878 MINT(21)=KSUSY1+22
11879 MINT(22)=KSUSY1+22
11880
11881 ELSEIF(ISUB.EQ.217) THEN
11882C...f + fbar -> ~chi02 + ~chi02
11883 MINT(21)=KSUSY1+23
11884 MINT(22)=KSUSY1+23
11885
11886 ELSEIF(ISUB.EQ.218 ) THEN
11887C...f + fbar -> ~chi03 + ~chi03
11888 MINT(21)=KSUSY1+25
11889 MINT(22)=KSUSY1+25
11890
11891 ELSEIF(ISUB.EQ.219 ) THEN
11892C...f + fbar -> ~chi04 + ~chi04
11893 MINT(21)=KSUSY1+35
11894 MINT(22)=KSUSY1+35
11895
11896 ELSEIF(ISUB.EQ.220 ) THEN
11897C...f + fbar -> ~chi01 + ~chi02
11898 IF(MINT(15).LT.0) JS=2
11899C IF(PYR(0).GT.0.5D0) JS=2
11900 MINT(20+JS)=KSUSY1+22
11901 MINT(23-JS)=KSUSY1+23
11902
11903 ELSEIF(ISUB.EQ.221 ) THEN
11904C...f + fbar -> ~chi01 + ~chi03
11905 IF(MINT(15).LT.0) JS=2
11906C IF(PYR(0).GT.0.5D0) JS=2
11907 MINT(20+JS)=KSUSY1+22
11908 MINT(23-JS)=KSUSY1+25
11909
11910 ELSEIF(ISUB.EQ.222) THEN
11911C...f + fbar -> ~chi01 + ~chi04
11912 IF(MINT(15).LT.0) JS=2
11913C IF(PYR(0).GT.0.5D0) JS=2
11914 MINT(20+JS)=KSUSY1+22
11915 MINT(23-JS)=KSUSY1+35
11916
11917 ELSEIF(ISUB.EQ.223) THEN
11918C...f + fbar -> ~chi02 + ~chi03
11919 IF(MINT(15).LT.0) JS=2
11920C IF(PYR(0).GT.0.5D0) JS=2
11921 MINT(20+JS)=KSUSY1+23
11922 MINT(23-JS)=KSUSY1+25
11923
11924 ELSEIF(ISUB.EQ.224) THEN
11925C...f + fbar -> ~chi02 + ~chi04
11926 IF(MINT(15).LT.0) JS=2
11927C IF(PYR(0).GT.0.5D0) JS=2
11928 MINT(20+JS)=KSUSY1+23
11929 MINT(23-JS)=KSUSY1+35
11930
11931 ELSEIF(ISUB.EQ.225) THEN
11932C...f + fbar -> ~chi03 + ~chi04
11933 IF(MINT(15).LT.0) JS=2
11934C IF(PYR(0).GT.0.5D0) JS=2
11935 MINT(20+JS)=KSUSY1+25
11936 MINT(23-JS)=KSUSY1+35
11937 ENDIF
11938
11939 ELSEIF(ISUB.LE.236) THEN
11940 IF(ISUB.EQ.226) THEN
11941C...f + fbar -> ~chi+-1 + ~chi-+1
11942C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
11943 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11944 MINT(21)=ISIGN(KSUSY1+24,KCH1)
11945 MINT(22)=-MINT(21)
11946
11947 ELSEIF(ISUB.EQ.227) THEN
11948C...f + fbar -> ~chi+-2 + ~chi-+2
11949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11950 MINT(21)=ISIGN(KSUSY1+37,KCH1)
11951 MINT(22)=-MINT(21)
11952
11953 ELSEIF(ISUB.EQ.228) THEN
11954C...f + fbar -> ~chi+-1 + ~chi-+2
11955C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
11956C...js=1 if pyr<.5, js=2 if pyr>.5
11957C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
11958C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
11959C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
11960C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
11961 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11962 KCH2=INT(1-KCH1)/2
11963 IF(MINT(2).EQ.1) THEN
11964 MINT(21)= ISIGN(KSUSY1+24,KCH1)
11965 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
11966c IF(KCH2.EQ.0) JS=2
11967 ELSE
11968 MINT(21)= ISIGN(KSUSY1+37,KCH1)
11969 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
11970 JS=2
11971c IF(KCH2.EQ.1) JS=2
11972 ENDIF
11973
11974 ELSEIF(ISUB.EQ.229) THEN
11975C...q + qbar' -> ~chi01 + ~chi+-1
11976C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
11977 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11978 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11979C...CHECK THIS
11980 IF(MOD(MINT(15),2).EQ.0) JS=2
11981 MINT(20+JS)=KSUSY1+22
11982 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11983
11984 ELSEIF(ISUB.EQ.230) THEN
11985C...q + qbar' -> ~chi02 + ~chi+-1
11986 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11987 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11988 IF(MOD(MINT(15),2).EQ.0) JS=2
11989 MINT(20+JS)=KSUSY1+23
11990 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11991
11992 ELSEIF(ISUB.EQ.231) THEN
11993C...q + qbar' -> ~chi03 + ~chi+-1
11994 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11995 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11996 IF(MOD(MINT(15),2).EQ.0) JS=2
11997 MINT(20+JS)=KSUSY1+25
11998 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
11999
12000 ELSEIF(ISUB.EQ.232) THEN
12001C...q + qbar' -> ~chi04 + ~chi+-1
12002 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12003 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12004 IF(MOD(MINT(15),2).EQ.0) JS=2
12005 MINT(20+JS)=KSUSY1+35
12006 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12007
12008 ELSEIF(ISUB.EQ.233) THEN
12009C...q + qbar' -> ~chi01 + ~chi+-2
12010 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12011 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12012 IF(MOD(MINT(15),2).EQ.0) JS=2
12013 MINT(20+JS)=KSUSY1+22
12014 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12015
12016 ELSEIF(ISUB.EQ.234) THEN
12017C...q + qbar' -> ~chi02 + ~chi+-2
12018 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12019 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12020 IF(MOD(MINT(15),2).EQ.0) JS=2
12021 MINT(20+JS)=KSUSY1+23
12022 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12023
12024 ELSEIF(ISUB.EQ.235) THEN
12025C...q + qbar' -> ~chi03 + ~chi+-2
12026 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12027 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12028 IF(MOD(MINT(15),2).EQ.0) JS=2
12029 MINT(20+JS)=KSUSY1+25
12030 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12031
12032 ELSEIF(ISUB.EQ.236) THEN
12033C...q + qbar' -> ~chi04 + ~chi+-2
12034 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12035 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12036 IF(MOD(MINT(15),2).EQ.0) JS=2
12037 MINT(20+JS)=KSUSY1+35
12038 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12039 ENDIF
12040
12041 ELSEIF(ISUB.LE.245) THEN
12042 IF(ISUB.EQ.237) THEN
12043C...q + qbar -> ~chi01 + ~g
12044C...th arbitrary
12045 IF(PYR(0).GT.0.5D0) JS=2
12046 MINT(20+JS)=KSUSY1+21
12047 MINT(23-JS)=KSUSY1+22
12048 KCC=17+JS
12049
12050 ELSEIF(ISUB.EQ.238) THEN
12051C...q + qbar -> ~chi02 + ~g
12052C...th arbitrary
12053 IF(PYR(0).GT.0.5D0) JS=2
12054 MINT(20+JS)=KSUSY1+21
12055 MINT(23-JS)=KSUSY1+23
12056 KCC=17+JS
12057
12058 ELSEIF(ISUB.EQ.239) THEN
12059C...q + qbar -> ~chi03 + ~g
12060C...th arbitrary
12061 IF(PYR(0).GT.0.5D0) JS=2
12062 MINT(20+JS)=KSUSY1+21
12063 MINT(23-JS)=KSUSY1+25
12064 KCC=17+JS
12065
12066 ELSEIF(ISUB.EQ.240) THEN
12067C...q + qbar -> ~chi04 + ~g
12068C...th arbitrary
12069 IF(PYR(0).GT.0.5D0) JS=2
12070 MINT(20+JS)=KSUSY1+21
12071 MINT(23-JS)=KSUSY1+35
12072 KCC=17+JS
12073
12074 ELSEIF(ISUB.EQ.241) THEN
12075C...q + qbar' -> ~chi+-1 + ~g
12076C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12077C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12078C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12079C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12080C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12081 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12082 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12083 JS=1
12084 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12085 MINT(20+JS)=KSUSY1+21
12086 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12087 KCC=17+JS
12088
12089 ELSEIF(ISUB.EQ.242) THEN
12090C...q + qbar' -> ~chi+-2 + ~g
12091C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12092C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12093C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12094C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12095C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12096 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12097 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12098 JS=1
12099 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12100 MINT(20+JS)=KSUSY1+21
12101 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12102 KCC=17+JS
12103
12104 ELSEIF(ISUB.EQ.243) THEN
12105C...q + qbar -> ~g + ~g ; th arbitrary
12106 MINT(21)=KSUSY1+21
12107 MINT(22)=KSUSY1+21
12108 KCC=MINT(2)+4
12109
12110 ELSEIF(ISUB.EQ.244) THEN
12111C...g + g -> ~g + ~g ; th arbitrary
12112 KCC=MINT(2)+12
12113 KCS=(-1)**INT(1.5D0+PYR(0))
12114 MINT(21)=KSUSY1+21
12115 MINT(22)=KSUSY1+21
12116 ENDIF
12117
12118 ELSEIF(ISUB.LE.260) THEN
12119 IF(ISUB.EQ.246) THEN
12120C...qj + g -> ~qj_L + ~chi01
12121 IF(MINT(15).EQ.21) JS=2
12122 I=MINT(14+JS)
12123 IA=IABS(I)
12124 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12125 MINT(23-JS)=KSUSY1+22
12126 KCC=15+JS
12127 KCS=ISIGN(1,MINT(14+JS))
12128
12129 ELSEIF(ISUB.EQ.247) THEN
12130C...qj + g -> ~qj_R + ~chi01
12131 IF(MINT(15).EQ.21) JS=2
12132 I=MINT(14+JS)
12133 IA=IABS(I)
12134 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12135 MINT(23-JS)=KSUSY1+22
12136 KCC=15+JS
12137 KCS=ISIGN(1,MINT(14+JS))
12138
12139 ELSEIF(ISUB.EQ.248) THEN
12140C...qj + g -> ~qj_L + ~chi02
12141 IF(MINT(15).EQ.21) JS=2
12142 I=MINT(14+JS)
12143 IA=IABS(I)
12144 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12145 MINT(23-JS)=KSUSY1+23
12146 KCC=15+JS
12147 KCS=ISIGN(1,MINT(14+JS))
12148
12149 ELSEIF(ISUB.EQ.249) THEN
12150C...qj + g -> ~qj_R + ~chi02
12151 IF(MINT(15).EQ.21) JS=2
12152 I=MINT(14+JS)
12153 IA=IABS(I)
12154 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12155 MINT(23-JS)=KSUSY1+23
12156 KCC=15+JS
12157 KCS=ISIGN(1,MINT(14+JS))
12158
12159 ELSEIF(ISUB.EQ.250) THEN
12160C...qj + g -> ~qj_L + ~chi03
12161 IF(MINT(15).EQ.21) JS=2
12162 I=MINT(14+JS)
12163 IA=IABS(I)
12164 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12165 MINT(23-JS)=KSUSY1+25
12166 KCC=15+JS
12167 KCS=ISIGN(1,MINT(14+JS))
12168
12169 ELSEIF(ISUB.EQ.251) THEN
12170C...qj + g -> ~qj_R + ~chi03
12171 IF(MINT(15).EQ.21) JS=2
12172 I=MINT(14+JS)
12173 IA=IABS(I)
12174 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12175 MINT(23-JS)=KSUSY1+25
12176 KCC=15+JS
12177 KCS=ISIGN(1,MINT(14+JS))
12178
12179 ELSEIF(ISUB.EQ.252) THEN
12180C...qj + g -> ~qj_L + ~chi04
12181 IF(MINT(15).EQ.21) JS=2
12182 I=MINT(14+JS)
12183 IA=IABS(I)
12184 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12185 MINT(23-JS)=KSUSY1+35
12186 KCC=15+JS
12187 KCS=ISIGN(1,MINT(14+JS))
12188
12189 ELSEIF(ISUB.EQ.253) THEN
12190C...qj + g -> ~qj_R + ~chi04
12191 IF(MINT(15).EQ.21) JS=2
12192 I=MINT(14+JS)
12193 IA=IABS(I)
12194 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12195 MINT(23-JS)=KSUSY1+35
12196 KCC=15+JS
12197 KCS=ISIGN(1,MINT(14+JS))
12198
12199 ELSEIF(ISUB.EQ.254) THEN
12200C...qj + g -> ~qk_L + ~chi+-1
12201 IF(MINT(15).EQ.21) JS=2
12202 I=MINT(14+JS)
12203 IA=IABS(I)
12204 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12205 IB=-IA+INT((IA+1)/2)*4-1
12206 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12207 KCC=15+JS
12208 KCS=ISIGN(1,MINT(14+JS))
12209
12210 ELSEIF(ISUB.EQ.255) THEN
12211C...qj + g -> ~qk_L + ~chi+-1
12212 IF(MINT(15).EQ.21) JS=2
12213 I=MINT(14+JS)
12214 IA=IABS(I)
12215 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12216 IB=-IA+INT((IA+1)/2)*4-1
12217 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12218 KCC=15+JS
12219 KCS=ISIGN(1,MINT(14+JS))
12220
12221 ELSEIF(ISUB.EQ.256) THEN
12222C...qj + g -> ~qk_L + ~chi+-2
12223 IF(MINT(15).EQ.21) JS=2
12224 I=MINT(14+JS)
12225 IA=IABS(I)
12226 IB=-IA+INT((IA+1)/2)*4-1
12227 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12228 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12229 KCC=15+JS
12230 KCS=ISIGN(1,MINT(14+JS))
12231
12232 ELSEIF(ISUB.EQ.257) THEN
12233C...qj + g -> ~qk_R + ~chi+-2
12234 IF(MINT(15).EQ.21) JS=2
12235 I=MINT(14+JS)
12236 IA=IABS(I)
12237 IB=-IA+INT((IA+1)/2)*4-1
12238 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12239 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12240 KCC=15+JS
12241 KCS=ISIGN(1,MINT(14+JS))
12242
12243 ELSEIF(ISUB.EQ.258) THEN
12244C...qj + g -> ~qj_L + ~g
12245 IF(MINT(15).EQ.21) JS=2
12246 I=MINT(14+JS)
12247 IA=IABS(I)
12248 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12249 MINT(23-JS)=KSUSY1+21
12250 KCC=MINT(2)+6
12251 IF(JS.EQ.2) KCC=KCC+2
12252 KCS=ISIGN(1,I)
12253
12254 ELSEIF(ISUB.EQ.259) THEN
12255C...qj + g -> ~qj_R + ~g
12256 IF(MINT(15).EQ.21) JS=2
12257 I=MINT(14+JS)
12258 IA=IABS(I)
12259 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12260 MINT(23-JS)=KSUSY1+21
12261 KCC=MINT(2)+6
12262 IF(JS.EQ.2) KCC=KCC+2
12263 KCS=ISIGN(1,I)
12264 ENDIF
12265
12266 ELSEIF(ISUB.LE.270) THEN
12267 IF(ISUB.EQ.261) THEN
12268C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12269 ISGN=1
12270 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12271 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12272 MINT(22)=-MINT(21)
12273C...Correct color combination
12274 IF(MINT(43).EQ.4) KCC=4
12275
12276 ELSEIF(ISUB.EQ.262) THEN
12277C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12278 ISGN=1
12279 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12280 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12281 MINT(22)=-MINT(21)
12282C...Correct color combination
12283 IF(MINT(43).EQ.4) KCC=4
12284
12285 ELSEIF(ISUB.EQ.263) THEN
12286C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12287 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12288 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12289 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12290 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12291 ELSE
12292 JS=2
12293 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12294 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12295 ENDIF
12296C...Correct color combination
12297 IF(MINT(43).EQ.4) KCC=4
12298
12299 ELSEIF(ISUB.EQ.264) THEN
12300C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12301 KCS=(-1)**INT(1.5D0+PYR(0))
12302 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12303 MINT(22)=-MINT(21)
12304 KCC=MINT(2)+10
12305
12306 ELSEIF(ISUB.EQ.265) THEN
12307C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12308 KCS=(-1)**INT(1.5D0+PYR(0))
12309 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12310 MINT(22)=-MINT(21)
12311 KCC=MINT(2)+10
12312 ENDIF
12313
12314 ELSEIF(ISUB.LE.296) THEN
12315 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12316C...qi + qj -> ~qi_L + ~qj_L
12317 KCC=MINT(2)
12318 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12319 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12320 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12321
12322 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12323C...qi + qj -> ~qi_R + ~qj_R
12324 KCC=MINT(2)
12325 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12326 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12327 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12328
12329 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12330C...qi + qj -> ~qi_L + ~qj_R
12331 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12332 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12333 KCC=MINT(2)
12334 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12335
12336 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12337C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12338 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12339 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12340 KCC=MINT(2)
12341 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12342
12343 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12344C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12345 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12346 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12347 KCC=MINT(2)
12348 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12349
12350 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12351C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12352 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12353 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12354 KCC=MINT(2)
12355 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12356
12357 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12358C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12359 ISGN=1
12360 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12361 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12362 MINT(22)=-MINT(21)
12363 IF(MINT(43).EQ.4) KCC=4
12364
12365 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12366C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12367 ISGN=1
12368 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12369 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12370 MINT(22)=-MINT(21)
12371 IF(MINT(43).EQ.4) KCC=4
12372
12373 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12374C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12375C...pure LL + RR
12376 KCS=(-1)**INT(1.5D0+PYR(0))
12377 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12378 MINT(22)=-MINT(21)
12379 KCC=MINT(2)+10
12380
12381 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12382C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12383 KCS=(-1)**INT(1.5D0+PYR(0))
12384 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12385 MINT(22)=-MINT(21)
12386 KCC=MINT(2)+10
12387
12388 ELSEIF(ISUB.EQ.294) THEN
12389C...qj + g -> ~qj_L + ~g
12390 IF(MINT(15).EQ.21) JS=2
12391 I=MINT(14+JS)
12392 IA=IABS(I)
12393 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12394 MINT(23-JS)=KSUSY1+21
12395 KCC=MINT(2)+6
12396 IF(JS.EQ.2) KCC=KCC+2
12397 KCS=ISIGN(1,I)
12398
12399 ELSEIF(ISUB.EQ.295) THEN
12400C...qj + g -> ~qj_R + ~g
12401 IF(MINT(15).EQ.21) JS=2
12402 I=MINT(14+JS)
12403 IA=IABS(I)
12404 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12405 MINT(23-JS)=KSUSY1+21
12406 KCC=MINT(2)+6
12407 IF(JS.EQ.2) KCC=KCC+2
12408 KCS=ISIGN(1,I)
12409 ENDIF
12410
12411 ELSEIF(ISUB.LE.330) THEN
12412 IF(ISUB.EQ.311)THEN
12413C...g + g -> g* + g* (UED)
12414 KCC=MINT(2)+12
12415 KCS=(-1)**INT(1.5D0+PYR(0))
12416 MUED(1)=472
12417 MUED(2)=472
12418 MINT(21)=IUEDEQ(472)
12419 MINT(22)=IUEDEQ(472)
12420 ELSEIF(ISUB.EQ.312)THEN
12421C...q + g -> q*_D + g*, q*_S + g*
12422C...The two channels have the same cross section
12423 KKFLMI=450
12424 IF(PYR(0).GT.0.5)KKFLMI=456
12425 IF(MINT(15).EQ.21) JS=2
12426 KCC=MINT(2)+6
12427 IF(MINT(15).EQ.21)KCC=KCC+2
12428 IF(MINT(15).NE.21)THEN
12429 KCS=ISIGN(1,MINT(15))
12430 MUED(2)=472
12431 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12432 MINT(22)=IUEDEQ(472)
12433 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12434 ENDIF
12435 IF(MINT(16).NE.21)THEN
12436 KCS=ISIGN(1,MINT(16))
12437 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12438 MUED(1)=472
12439 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12440 MINT(21)=IUEDEQ(472)
12441 ENDIF
12442 ELSEIF(ISUB.EQ.313)THEN
12443C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12444C...The two channels have the same cross section
12445 KKFLMI=450
12446 IF(PYR(0).GT.0.5)KKFLMI=456
12447 KCC=MINT(2)
12448 IF(MINT(15).EQ.MINT(16))THEN
12449 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12450 MUED(2)=MINT(21)
12451 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12452 MINT(22)=MINT(21)
12453 ELSE
12454 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12455 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12456 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12457 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12458 ENDIF
12459 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12460 ELSEIF(ISUB.EQ.314)THEN
12461C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12462C...The two channels have the same cross section
12463 KKFLMI=450
12464 IF(PYR(0).GT.0.5)KKFLMI=456
12465 KCS=(-1)**INT(1.5D0+PYR(0))
12466 XFLAOUT=PYR(0)
12467 IF(XFLAOUT.LE.0.2)THEN
12468 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12469 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12470 ELSEIF(XFLAOUT.LE.0.4)THEN
12471 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12472 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12473 ELSEIF(XFLAOUT.LE.0.6)THEN
12474 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12475 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12476 ELSEIF(XFLAOUT.LE.0.8)THEN
12477 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12478 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12479 ELSE
12480 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12481 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12482 ENDIF
12483 MINT(22)=-MINT(21)
12484 MUED(2)=-MUED(1)
12485 KCC=MINT(2)+10
12486 ELSEIF(ISUB.EQ.315)THEN
12487C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12488C...The two channels have the same cross section
12489 KKFLMI=450
12490 IF(PYR(0).GT.0.5)KKFLMI=456
12491 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12492 MUED(2)=-MINT(21)
12493 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12494 MINT(22)=-MINT(21)
12495 KCC=4
12496 ELSEIF(ISUB.EQ.316)THEN
12497C...q + qbar' -> q*_D + q*_S_bar'
12498 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12499 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12500 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12501 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12502 KCC=MINT(2)+2
12503 ELSEIF(ISUB.EQ.317)THEN
12504C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12505C...The two channels have the same cross section
12506 KKFLMI=450
12507 IF(PYR(0).GT.0.5)KKFLMI=456
12508 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12509 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12510 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12511 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12512 KCC=MINT(2)+2
12513 ELSEIF(ISUB.EQ.318)THEN
12514C...q + q' -> q*_D + q*_S'
12515 KCC=MINT(2)
12516 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12517 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12518 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12519 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12520 ELSEIF(ISUB.EQ.319)THEN
12521C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12522C...The two channels have the same cross section
12523 KKFLMI=450
12524 IF(PYR(0).GT.0.5)KKFLMI=456
12525 XFLAOUT=PYR(0)
12526 IIFLAV=0
12527C...N.B. NFLAVOURS=IUED(3)
12528C DO I=1,NFLAVOURS
12529 DO 433 I=1,IUED(3)
12530 IF(I.NE.IABS(MINT(15)))THEN
12531 IIFLAV=IIFLAV+1
12532 IOKFLA(IIFLAV)=I
12533 ENDIF
12534 433 CONTINUE
12535 FLASTEP=1./(IUED(3)-1)
12536 DO I=1,IUED(3)-1
12537 FLAVV=FLASTEP*I
12538 IF(XFLAOUT.LE.FLAVV)THEN
12539 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12540 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12541 GOTO 435
12542 ENDIF
12543 ENDDO
12544 435 CONTINUE
12545 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12546 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12547 CALL PYSTOP(5000000)
12548 ENDIF
12549 MINT(22)=-MINT(21)
12550 KCC=4
12551 ENDIF
12552
12553 ELSEIF(ISUB.LE.340) THEN
12554
12555 IF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12556C...q + qbar' -> H+ + H0
12557 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12558 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12559 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12560 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12561 MINT(23-JS)=KFPR(ISUB,2)
12562 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12563C...f + fbar -> A0 + H0; th arbitrary
12564 IF(PYR(0).GT.0.5D0) JS=2
12565 MINT(20+JS)=KFPR(ISUB,1)
12566 MINT(23-JS)=KFPR(ISUB,2)
12567 ELSEIF(ISUB.EQ.301) THEN
12568C...f + fbar -> H+ H-
12569 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12570 MINT(22)=-MINT(21)
12571 ENDIF
12572CMRENNA--
12573
12574 ELSEIF(ISUB.LE.360) THEN
12575
12576 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12577C...l + l -> H_L++/--, H_R++/--
12578 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12579 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12580 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12581
12582 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12583C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12584 IF(MINT(15).EQ.22) JS=2
12585 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12586 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12587 KCC=22
12588
12589 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12590C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12591 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12592 MINT(22)=-MINT(21)
12593
12594 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12595C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12596C...as inner process).
12597 DO 450 JT=1,2
12598 I=MINT(14+JT)
12599 IA=IABS(I)
12600 IF(IA.LE.10) THEN
12601 RVCKM=VINT(180+I)*PYR(0)
12602 DO 440 J=1,MSTP(1)
12603 IB=2*J-1+MOD(IA,2)
12604 IPM=(5-ISIGN(1,I))/2
12605 IDC=J+MDCY(IA,2)+2
12606 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12607 MINT(20+JT)=ISIGN(IB,I)
12608 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12609 IF(RVCKM.LE.0D0) GOTO 450
12610 440 CONTINUE
12611 ELSE
12612 IB=2*((IA+1)/2)-1+MOD(IA,2)
12613 MINT(20+JT)=ISIGN(IB,I)
12614 ENDIF
12615 450 CONTINUE
12616 KCC=22
12617 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12618 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12619
12620 ELSEIF(ISUB.EQ.353) THEN
12621C...f + fbar -> Z_R0
12622 KFRES=KFPR(ISUB,1)
12623
12624 ELSEIF(ISUB.EQ.354) THEN
12625C...f + fbar' -> W+/-
12626 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12627 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12628 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12629
12630 ENDIF
12631
12632 ELSEIF(ISUB.LE.380) THEN
12633
12634 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12635C...f + fbar -> charged+ charged- technicolor
12636 KSW=(-1)**INT(1.5D0+PYR(0))
12637 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12638 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12639
12640 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12641C...f + fbar -> neutral neutral technicolor
12642 MINT(21)=KFPR(ISUB,1)
12643 MINT(22)=KFPR(ISUB,2)
12644
12645 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12646C...f + fbar' -> neutral charged technicolor
12647 IN=1
12648 IC=2
12649 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12650 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12651 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12652 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12653 MINT(20+JS)=KFPR(ISUB,IN)
12654
12655 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12656C...f + fbar' -> charged neutral technicolor
12657 IN=2
12658 IC=1
12659 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12660 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12661 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12662 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12663 MINT(23-JS)=KFPR(ISUB,IN)
12664 ENDIF
12665
12666 ELSEIF(ISUB.LE.400) THEN
12667 IF(ISUB.EQ.381) THEN
12668C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12669 KCC=MINT(2)
12670 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12671
12672 ELSEIF(ISUB.EQ.382) THEN
12673C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12674 MINT(21)=ISIGN(KFLF,MINT(15))
12675 MINT(22)=-MINT(21)
12676 KCC=4
12677
12678 ELSEIF(ISUB.EQ.383) THEN
12679C...f + fbar -> g + g; th arbitrary, TC extensions
12680 MINT(21)=21
12681 MINT(22)=21
12682 KCC=MINT(2)+4
12683
12684 ELSEIF(ISUB.EQ.384) THEN
12685C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12686 IF(MINT(15).EQ.21) JS=2
12687 KCC=MINT(2)+6
12688 IF(MINT(15).EQ.21) KCC=KCC+2
12689 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12690 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12691
12692 ELSEIF(ISUB.EQ.385) THEN
12693C...g + g -> f + fbar; th arbitrary, TC extensions
12694 KCS=(-1)**INT(1.5D0+PYR(0))
12695 MINT(21)=ISIGN(KFLF,KCS)
12696 MINT(22)=-MINT(21)
12697 KCC=MINT(2)+10
12698
12699 ELSEIF(ISUB.EQ.386) THEN
12700C...g + g -> g + g; th arbitrary, TC extensions
12701 KCC=MINT(2)+12
12702 KCS=(-1)**INT(1.5D0+PYR(0))
12703
12704 ELSEIF(ISUB.EQ.387) THEN
12705C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12706 MINT(21)=ISIGN(MINT(55),MINT(15))
12707 MINT(22)=-MINT(21)
12708 KCC=4
12709
12710 ELSEIF(ISUB.EQ.388) THEN
12711C...g + g -> Q + Qbar; th arbitrary, TC extensions
12712 KCS=(-1)**INT(1.5D0+PYR(0))
12713 MINT(21)=ISIGN(MINT(55),KCS)
12714 MINT(22)=-MINT(21)
12715 KCC=MINT(2)+10
12716
12717 ELSEIF(ISUB.EQ.391) THEN
12718C...f + fbar -> G*.
12719 KFRES=KFPR(ISUB,1)
12720
12721 ELSEIF(ISUB.EQ.392) THEN
12722C...g + g -> G*.
12723 KCC=21
12724 KFRES=KFPR(ISUB,1)
12725
12726 ELSEIF(ISUB.EQ.393) THEN
12727C...q + qbar -> g + G*; th arbitrary.
12728 IF(PYR(0).GT.0.5D0) JS=2
12729 MINT(20+JS)=KFPR(ISUB,1)
12730 MINT(23-JS)=KFPR(ISUB,2)
12731 KCC=17+JS
12732
12733 ELSEIF(ISUB.EQ.394) THEN
12734C...q + g -> q + G*; th = (p(f) - p(f))**2
12735 IF(MINT(15).EQ.21) JS=2
12736 MINT(23-JS)=KFPR(ISUB,2)
12737 KCC=15+JS
12738 KCS=ISIGN(1,MINT(14+JS))
12739
12740 ELSEIF(ISUB.EQ.395) THEN
12741C...g + g -> G* + g; th arbitrary.
12742 IF(PYR(0).GT.0.5D0) JS=2
12743 MINT(23-JS)=KFPR(ISUB,2)
12744 KCC=22+JS
12745 ENDIF
12746
12747 ELSEIF(ISUB.LE.420) THEN
12748 IF(ISUB.EQ.401) THEN
12749C...g + g -> t + b + H+/-
12750 KCS=(-1)**INT(1.5D0+PYR(0))
12751 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12752 MINT(22)=ISIGN(5,-KCS)
12753 KCC=11+INT(0.5D0+PYR(0))
12754 KFRES=ISIGN(KFHIGG,-KCS)
12755
12756 ELSEIF(ISUB.EQ.402) THEN
12757C...q + qbar -> t + b + H+/-
12758 KFL=(-1)**INT(1.5D0+PYR(0))
12759 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12760 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12761 KCC=4
12762 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12763 ENDIF
12764
12765C...QUARKONIA+++
12766C...Additional code by Stefan Wolf
12767 ELSEIF(ISUB.LE.430) THEN
12768 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12769C...g + g -> QQ~[n] + g
12770C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12771C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12772C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12773C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12774C...or from ISUB.EQ.68 (for ISUB.NE.421)
12775C...[g + g -> g + g; th arbitrary]
12776 MINT(21)=KFPR(ISUBSV,1)
12777 MINT(22)=KFPR(ISUBSV,2)
12778 IF(ISUB.EQ.421) THEN
12779 KCC=24
12780 KCS=(-1)**INT(1.5D0+PYR(0))
12781 ELSE
12782 KCC=MINT(2)+12
12783 KCS=(-1)**INT(1.5D0+PYR(0))
12784 ENDIF
12785
12786 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12787C...q + g -> q + QQ~[n]
12788C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12789C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12790C...KCC copied from ISUB.EQ.28
12791C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12792 IF(MINT(15).EQ.21) JS=2
12793 MINT(23-JS)=KFPR(ISUBSV,2)
12794 KCC=MINT(2)+6
12795 IF(MINT(15).EQ.21) KCC=KCC+2
12796 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12797 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12798
12799 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12800C...q + q~ -> g + QQ~[n]
12801C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12802C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12803C...KCC copied from ISUB.EQ.13
12804C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12805 IF(PYR(0).GT.0.5) JS=2
12806 MINT(20+JS)=21
12807 MINT(23-JS)=KFPR(ISUBSV,2)
12808 KCC=MINT(2)+4
12809 ENDIF
12810
12811 ELSEIF(ISUB.LE.440) THEN
12812 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12813C...g + g -> QQ~[n] + g
12814C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12815C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12816C...KCC and KCS copied from ISUB.EQ.86-89
12817C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12818 MINT(21)=KFPR(ISUBSV,1)
12819 MINT(22)=KFPR(ISUBSV,2)
12820 KCC=24
12821 KCS=(-1)**INT(1.5D0+PYR(0))
12822
12823 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12824C...q + g -> q + QQ~[n]
12825C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12826C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12827C...KCC and KCS copied from ISUB.EQ.112
12828C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12829 IF(MINT(15).EQ.21) JS=2
12830 MINT(23-JS)=KFPR(ISUBSV,2)
12831 KCC=15+JS
12832 KCS=ISIGN(1,MINT(14+JS))
12833
12834 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12835C...q + q~ -> g + QQ~[n]
12836C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12837C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12838C...KCC copied from ISUB.EQ.111
12839C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12840 IF(PYR(0).GT.0.5) JS=2
12841 MINT(20+JS)=21
12842 MINT(23-JS)=KFPR(ISUBSV,2)
12843 KCC=17+JS
12844 ENDIF
12845C...QUARKONIA---
12846
12847 ENDIF
12848
12849 IF(ISET(ISUB).EQ.11) THEN
12850C...Store documentation for user-defined processes
12851 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
12852 KUPPO(1)=MINT(83)+5
12853 KUPPO(2)=MINT(83)+6
12854 I=MINT(83)+6
12855 DO 470 IUP=3,NUP
12856 KUPPO(IUP)=0
12857 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
12858 IDOC=IDOC-1
12859 MINT(4)=MINT(4)-1
12860 GOTO 470
12861 ENDIF
12862 I=I+1
12863 KUPPO(IUP)=I
12864 K(I,1)=21
12865 K(I,2)=IDUP(IUP)
12866 IF(IDUP(IUP).EQ.0) K(I,2)=90
12867 K(I,3)=0
12868 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
12869 K(I,4)=0
12870 K(I,5)=0
12871 DO 460 J=1,5
12872 P(I,J)=PUP(J,IUP)
12873 460 CONTINUE
12874 V(I,5)=VTIMUP(IUP)
12875 470 CONTINUE
12876 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
12877 & -BEZUP)
12878
12879C...Store final state partons for user-defined processes
12880 N=IPU2
12881 DO 490 IUP=3,NUP
12882 N=N+1
12883 K(N,1)=1
12884 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
12885 K(N,2)=IDUP(IUP)
12886 IF(IDUP(IUP).EQ.0) K(N,2)=90
12887 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
12888 K(N,3)=KUPPO(IUP)
12889 ELSE
12890 K(N,3)=MINT(84)+MOTHUP(1,IUP)
12891 ENDIF
12892 K(N,4)=0
12893 K(N,5)=0
12894C...Search for daughters of intermediate colourless particles.
12895 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
12896 DO 475 IUPDAU=IUP+1,NUP
12897 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
12898 & N+IUPDAU-IUP
12899 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
12900 475 CONTINUE
12901 ENDIF
12902 DO 480 J=1,5
12903 P(N,J)=PUP(J,IUP)
12904 480 CONTINUE
12905 V(N,5)=VTIMUP(IUP)
12906 490 CONTINUE
12907 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
12908
12909C...Arrange colour flow for user-defined processes
12910 NLBL=0
12911 DO 540 IUP1=1,NUP
12912 I1=MINT(84)+IUP1
12913 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
12914 IF(K(I1,1).EQ.1) K(I1,1)=3
12915 IF(K(I1,1).EQ.11) K(I1,1)=14
12916C...Find a not yet considered colour/anticolour line.
12917 DO 530 ISDE1=1,2
12918 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
12919 NMAT=0
12920 DO 500 ILBL=1,NLBL
12921 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
12922 500 CONTINUE
12923 IF(NMAT.EQ.0) THEN
12924 NLBL=NLBL+1
12925 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
12926C...Find all others belonging to same line.
12927 I3=I1
12928 I4=0
12929 DO 520 IUP2=IUP1+1,NUP
12930 I2=MINT(84)+IUP2
12931 DO 510 ISDE2=1,2
12932 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
12933 IF(ISDE2.EQ.ISDE1) THEN
12934 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
12935 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
12936 I3=I2
12937 ELSEIF(I4.NE.0) THEN
12938 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
12939 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
12940 I4=I2
12941 ELSEIF(IUP2.LE.2) THEN
12942 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
12943 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
12944 I4=I2
12945 ELSE
12946 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
12947 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
12948 I4=I2
12949 ENDIF
12950 ENDIF
12951 510 CONTINUE
12952 520 CONTINUE
12953 ENDIF
12954 530 CONTINUE
12955 540 CONTINUE
12956
12957 ELSEIF(IDOC.EQ.7) THEN
12958C...Resonance not decaying; store kinematics
12959 I=MINT(83)+7
12960 K(IPU3,1)=1
12961 K(IPU3,2)=KFRES
12962 K(IPU3,3)=I
12963 P(IPU3,4)=SHUSER
12964 P(IPU3,5)=SHUSER
12965 K(I,1)=21
12966 K(I,2)=KFRES
12967 P(I,4)=SHUSER
12968 P(I,5)=SHUSER
12969 N=IPU3
12970 MINT(21)=KFRES
12971 MINT(22)=0
12972
12973C...Special cases: colour flow in coloured resonances
12974 KCRES=PYCOMP(KFRES)
12975 IF(KCHG(KCRES,2).NE.0) THEN
12976 K(IPU3,1)=3
12977 DO 550 J=1,2
12978 JC=J
12979 IF(KCS.EQ.-1) JC=3-J
12980 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
12981 & MINT(84)+ICOL(KCC,1,JC)
12982 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
12983 & MINT(84)+ICOL(KCC,2,JC)
12984 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
12985 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
12986 550 CONTINUE
12987 ELSE
12988 K(IPU1,4)=IPU2
12989 K(IPU1,5)=IPU2
12990 K(IPU2,4)=IPU1
12991 K(IPU2,5)=IPU1
12992 ENDIF
12993
12994 ELSEIF(IDOC.EQ.8) THEN
12995C...2 -> 2 processes: store outgoing partons in their CM-frame
12996 DO 560 JT=1,2
12997 I=MINT(84)+2+JT
12998 KCA=PYCOMP(MINT(20+JT))
12999 K(I,1)=1
13000 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13001 K(I,2)=MINT(20+JT)
13002 K(I,3)=MINT(83)+IDOC+JT-2
13003 KFAA=IABS(K(I,2))
13004 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13005 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13006 ELSE
13007 P(I,5)=PYMASS(K(I,2))
13008 ENDIF
13009 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13010 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13011 560 CONTINUE
13012 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13013 KFA1=IABS(MINT(21))
13014 KFA2=IABS(MINT(22))
13015 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13016 & THEN
13017 MINT(51)=1
13018 RETURN
13019 ENDIF
13020 P(IPU3,5)=0D0
13021 P(IPU4,5)=0D0
13022 ENDIF
13023 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13024 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13025 P(IPU4,4)=SHR-P(IPU3,4)
13026 P(IPU4,3)=-P(IPU3,3)
13027 N=IPU4
13028 MINT(7)=MINT(83)+7
13029 MINT(8)=MINT(83)+8
13030
13031C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13032 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13033
13034 ELSEIF(IDOC.EQ.9) THEN
13035C...2 -> 3 processes: store outgoing partons in their CM frame
13036 DO 570 JT=1,2
13037 I=MINT(84)+2+JT
13038 KCA=PYCOMP(MINT(20+JT))
13039 K(I,1)=1
13040 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13041 K(I,2)=MINT(20+JT)
13042 K(I,3)=MINT(83)+IDOC+JT-3
13043 JTA=JT
13044C...t and b in opposide order in event list as compared to
13045C...matrix element?
13046 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13047 IF(IABS(K(I,2)).LE.22) THEN
13048 P(I,5)=PYMASS(K(I,2))
13049 ELSE
13050 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13051 ENDIF
13052 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13053 P(I,1)=PT*COS(VINT(198+5*JTA))
13054 P(I,2)=PT*SIN(VINT(198+5*JTA))
13055 570 CONTINUE
13056 K(IPU5,1)=1
13057 K(IPU5,2)=KFRES
13058 K(IPU5,3)=MINT(83)+IDOC
13059 P(IPU5,5)=SHR
13060 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13061 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13062 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13063 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13064 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13065 PMT3=SQRT(PMS3)
13066 P(IPU5,3)=PMT3*SINH(VINT(211))
13067 P(IPU5,4)=PMT3*COSH(VINT(211))
13068 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13069 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13070 IF(SQL12.LE.0D0) THEN
13071 MINT(51)=1
13072 RETURN
13073 ENDIF
13074 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13075 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13076 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13077 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13078C...t and b in opposide order in event list as compared to
13079C...matrix element
13080 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13081 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13082 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13083 END IF
13084 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13085 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13086 MINT(23)=KFRES
13087 N=IPU5
13088 MINT(7)=MINT(83)+7
13089 MINT(8)=MINT(83)+8
13090
13091 ELSEIF(IDOC.EQ.11) THEN
13092C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13093 PHI(1)=PARU(2)*PYR(0)
13094 PHI(2)=PHI(1)-PHIR
13095 DO 580 JT=1,2
13096 I=MINT(84)+2+JT
13097 K(I,1)=1
13098 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13099 K(I,2)=MINT(20+JT)
13100 K(I,3)=MINT(83)+IDOC+JT-2
13101 P(I,5)=PYMASS(K(I,2))
13102 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13103 MINT(51)=1
13104 RETURN
13105 ENDIF
13106 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13107 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13108 P(I,1)=PTABS*COS(PHI(JT))
13109 P(I,2)=PTABS*SIN(PHI(JT))
13110 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13111 P(I,4)=0.5D0*SHPR*Z(JT)
13112 IZW=MINT(83)+6+JT
13113 K(IZW,1)=21
13114 K(IZW,2)=23
13115 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13116 K(IZW,3)=IZW-2
13117 P(IZW,1)=-P(I,1)
13118 P(IZW,2)=-P(I,2)
13119 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13120 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13121 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13122 580 CONTINUE
13123 I=MINT(83)+9
13124 K(IPU5,1)=1
13125 K(IPU5,2)=KFRES
13126 K(IPU5,3)=I
13127 P(IPU5,5)=SHR
13128 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13129 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13130 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13131 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13132 K(I,1)=21
13133 K(I,2)=KFRES
13134 DO 590 J=1,5
13135 P(I,J)=P(IPU5,J)
13136 590 CONTINUE
13137 N=IPU5
13138 MINT(23)=KFRES
13139
13140 ELSEIF(IDOC.EQ.12) THEN
13141C...Z0 and W+/- scattering: store bosons and outgoing partons
13142 PHI(1)=PARU(2)*PYR(0)
13143 PHI(2)=PHI(1)-PHIR
13144 JTRAN=INT(1.5D0+PYR(0))
13145 DO 600 JT=1,2
13146 I=MINT(84)+2+JT
13147 K(I,1)=1
13148 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13149 K(I,2)=MINT(20+JT)
13150 K(I,3)=MINT(83)+IDOC+JT-2
13151 P(I,5)=PYMASS(K(I,2))
13152 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13153 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13154 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13155 P(I,1)=PTABS*COS(PHI(JT))
13156 P(I,2)=PTABS*SIN(PHI(JT))
13157 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13158 P(I,4)=0.5D0*SHPR*Z(JT)
13159 IZW=MINT(83)+6+JT
13160 K(IZW,1)=21
13161 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13162 K(IZW,2)=23
13163 ELSE
13164 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13165 ENDIF
13166 K(IZW,3)=IZW-2
13167 P(IZW,1)=-P(I,1)
13168 P(IZW,2)=-P(I,2)
13169 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13170 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13171 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13172 IPU=MINT(84)+4+JT
13173 K(IPU,1)=3
13174 K(IPU,2)=KFPR(ISUB,JT)
13175 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13176 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13177 K(IPU,3)=MINT(83)+8+JT
13178 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13179 P(IPU,5)=PYMASS(K(IPU,2))
13180 ELSE
13181 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13182 ENDIF
13183 MINT(22+JT)=K(IPU,2)
13184 600 CONTINUE
13185C...Find rotation and boost for hard scattering subsystem
13186 I1=MINT(83)+7
13187 I2=MINT(83)+8
13188 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13189 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13190 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13191 GAMCM=(P(I1,4)+P(I2,4))/SHR
13192 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13193 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13194 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13195 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13196 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13197 PHICM=PYANGL(PX,PY)
13198C...Store hard scattering subsystem. Rotate and boost it
13199 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13200 & P(IPU6,5)**2
13201 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13202 CTHWZ=VINT(23)
13203 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13204 PHIWZ=VINT(24)-PHICM
13205 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13206 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13207 P(IPU5,3)=PABS*CTHWZ
13208 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13209 P(IPU6,1)=-P(IPU5,1)
13210 P(IPU6,2)=-P(IPU5,2)
13211 P(IPU6,3)=-P(IPU5,3)
13212 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13213 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13214 DO 620 JT=1,2
13215 I1=MINT(83)+8+JT
13216 I2=MINT(84)+4+JT
13217 K(I1,1)=21
13218 K(I1,2)=K(I2,2)
13219 DO 610 J=1,5
13220 P(I1,J)=P(I2,J)
13221 610 CONTINUE
13222 620 CONTINUE
13223 N=IPU6
13224 MINT(7)=MINT(83)+9
13225 MINT(8)=MINT(83)+10
13226 ENDIF
13227
13228 IF(ISET(ISUB).EQ.11) THEN
13229 ELSEIF(IDOC.GE.8) THEN
13230C...Store colour connection indices
13231 DO 630 J=1,2
13232 JC=J
13233 IF(KCS.EQ.-1) JC=3-J
13234 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13235 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13236 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13237 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13238 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13239 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13240 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13241 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13242 630 CONTINUE
13243
13244C...Copy outgoing partons to documentation lines
13245 IMAX=2
13246 IF(IDOC.EQ.9) IMAX=3
13247 DO 650 I=1,IMAX
13248 I1=MINT(83)+IDOC-IMAX+I
13249 I2=MINT(84)+2+I
13250 K(I1,1)=21
13251 K(I1,2)=K(I2,2)
13252 IF(IDOC.LE.9) K(I1,3)=0
13253 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13254 DO 640 J=1,5
13255 P(I1,J)=P(I2,J)
13256 640 CONTINUE
13257 650 CONTINUE
13258
13259 ELSEIF(IDOC.EQ.9) THEN
13260C...Store colour connection indices
13261 DO 660 J=1,2
13262 JC=J
13263 IF(KCS.EQ.-1) JC=3-J
13264 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13265 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13266 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13267 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13268 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13269 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13270 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13271 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13272 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13273 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13274 660 CONTINUE
13275
13276C...Copy outgoing partons to documentation lines
13277 DO 680 I=1,3
13278 I1=MINT(83)+IDOC-3+I
13279 I2=MINT(84)+2+I
13280 K(I1,1)=21
13281 K(I1,2)=K(I2,2)
13282 K(I1,3)=0
13283 DO 670 J=1,5
13284 P(I1,J)=P(I2,J)
13285 670 CONTINUE
13286 680 CONTINUE
13287 ENDIF
13288
13289C...Copy outgoing partons to list of allowed radiators.
13290 NPART=0
13291 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13292 DO 690 I=MINT(84)+3,N
13293 NPART=NPART+1
13294 IPART(NPART)=I
13295 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13296 690 CONTINUE
13297 ENDIF
13298
13299C...Low-pT events: remove gluons used for string drawing purposes
13300 IF(ISUB.EQ.95) THEN
13301 IF(MINT(35).LE.1) THEN
13302 K(IPU3,1)=K(IPU3,1)+10
13303 K(IPU4,1)=K(IPU4,1)+10
13304 ENDIF
13305 DO 700 J=41,66
13306 VINTSV(J)=VINT(J)
13307 VINT(J)=0D0
13308 700 CONTINUE
13309 DO 720 I=MINT(83)+5,MINT(83)+8
13310 DO 710 J=1,5
13311 P(I,J)=0D0
13312 710 CONTINUE
13313 720 CONTINUE
13314 ENDIF
13315
13316 RETURN
13317 END
13318
13319C***********************************************************************
13320
13321C...PYEVOL
13322C...Handles intertwined pT-ordered spacelike initial-state parton
13323C...and multiple interactions.
13324
13325 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13326C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13327C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13328C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13329
13330C...Double precision and integer declarations.
13331 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13332 IMPLICIT INTEGER(I-N)
13333 INTEGER PYK,PYCHGE,PYCOMP
13334C...External
13335 EXTERNAL PYALPS
13336 DOUBLE PRECISION PYALPS
13337C...Parameter statement for maximum size of showers.
13338 PARAMETER (MAXNUR=1000)
13339C...Commonblocks.
13340 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13341 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13343 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13344 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13345 COMMON/PYINT1/MINT(400),VINT(400)
13346 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13347 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13348 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13349 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13350 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13351 COMMON/PYCTAG/NCT,MCT(4000,2)
13352 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13353 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13354 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13355C...Local arrays and saved variables.
13356 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13357 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13358 & ,PSAV,KSAV,VSAV
13359
13360 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13361 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13362
13363C----------------------------------------------------------------------
13364C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13365C...done only once per event, while MODE=0 is repeated each time the
13366C...evolution needs to be restarted.
13367 IF (MODE.EQ.-1) THEN
13368 ISUBHD=MINT(1)
13369 NSAV=N
13370 NPARTS=NPART
13371C...Store hard scattering variables
13372 M15SV=MINT(15)
13373 M16SV=MINT(16)
13374 M21SV=MINT(21)
13375 M22SV=MINT(22)
13376 DO 100 J=11,80
13377 VINTSV(J)=VINT(J)
13378 100 CONTINUE
13379 DO 120 J=1,5
13380 DO 110 IS=1,4
13381 I=IS+MINT(84)
13382 PSAV(IS,J)=P(I,J)
13383 KSAV(IS,J)=K(I,J)
13384 VSAV(IS,J)=V(I,J)
13385 110 CONTINUE
13386 120 CONTINUE
13387
13388C...Set shat for hardest scattering
13389 SHAT(1)=VINT(44)
13390 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13391 & *VINT(2)
13392
13393C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13394 RMC=PMAS(4,1)
13395 RMB=PMAS(5,1)
13396 ALAM4=PARP(61)
13397 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13398 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13399 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13400
13401C----------------------------------------------------------------------
13402C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13403C...interaction initiators, with no previous evolution. Check the input
13404C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13405C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13406C...smaller than the CM energy / 2.)
13407 ELSEIF (MODE.EQ.0) THEN
13408C...Reset counters and switches
13409 N=NSAV
13410 NPART=NPARTS
13411 MINT(30)=0
13412 MINT(31)=1
13413 MINT(36)=1
13414C...Reset hard scattering variables
13415 MINT(1)=ISUBHD
13416 DO 130 J=11,80
13417 VINT(J)=VINTSV(J)
13418 130 CONTINUE
13419 DO 150 J=1,5
13420 DO 140 IS=1,4
13421 I=IS+MINT(84)
13422 P(I,J)=PSAV(IS,J)
13423 K(I,J)=KSAV(IS,J)
13424 V(I,J)=VSAV(IS,J)
13425 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13426 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13427 140 CONTINUE
13428 150 CONTINUE
13429C...Reset statistics on activity in event.
13430 DO 160 J=351,359
13431 MINT(J)=0
13432 VINT(J)=0D0
13433 160 CONTINUE
13434C...Reset extra companion reweighting factor
13435 VINT(140)=1D0
13436
13437C...We do not generate MI for soft process (ISUB=95), but the
13438C...initialization must be done regardless, for later purposes.
13439 MINT(36)=1
13440
13441C...Initialize multiple interactions.
13442 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13443 IF(MINT(51).NE.0) RETURN
13444
13445C...Decide whether quarks in hard scattering were valence or sea
13446 PT2HD=VINT(54)
13447 DO 170 JS=1,2
13448 MINT(30)=JS
13449 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13450 IF(MINT(51).NE.0) RETURN
13451 170 CONTINUE
13452
13453C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13454 VINT(18)=0D0
13455 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13456 IF (MSTP(70).EQ.2) THEN
13457C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13458 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13459 ELSEIF (MSTP(70).EQ.3) THEN
13460C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13461 ALPHA0 = MAX(1D-6,PARP(73))
13462 Q20 = ALAM3**2/PARP(64)
13463 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13464 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13465 ENDIF
13466C...Also store PT2MIN in VINT(17).
13467 180 VINT(17)=PT2MIN
13468
13469C...Set FS masses zero now.
13470 VINT(63)=0D0
13471 VINT(64)=0D0
13472
13473C...Initialize IS showers with VINT(56) as max scale.
13474 PT2ISR=VINT(56)
13475 PT20=PT2MIN
13476 IF (MSTP(70).EQ.0) THEN
13477 PT20=MAX(PT2MIN,PARP(62)**2)
13478 ELSEIF (MSTP(70).EQ.1) THEN
13479 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13480 ENDIF
13481 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13482 IF(MINT(51).NE.0) RETURN
13483
13484 RETURN
13485
13486C----------------------------------------------------------------------
13487C...MODE= 1: Evolve event from PTMAX to PTMIN.
13488 ELSEIF (MODE.EQ.1) THEN
13489
13490C...Skip if no phase space.
13491 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13492
13493C...Starting pT2 max scale (to be udpated successively).
13494 PT2CMX=PT2MAX
13495
13496C...Evolve two sides of the event to find which branches at highest pT.
13497 200 JSMX=-1
13498 MIMX=0
13499 PT2MX=0D0
13500
13501C...Loop over current shower initiators.
13502 IF (MSTP(61).GE.1) THEN
13503 DO 230 MI=1,MINT(31)
13504 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13505 ISUB=96
13506 IF (MI.EQ.1) ISUB=ISUBHD
13507 MINT(1)=ISUB
13508 MINT(36)=MI
13509C...Set up shat, initiator x values, and x remaining in BR.
13510 VINT(44)=SHAT(MI)
13511 VINT(141)=XMI(1,MI)
13512 VINT(142)=XMI(2,MI)
13513 VINT(143)=1D0
13514 VINT(144)=1D0
13515 DO 210 JI=1,MINT(31)
13516 IF (JI.EQ.MINT(36)) GOTO 210
13517 VINT(143)=VINT(143)-XMI(1,JI)
13518 VINT(144)=VINT(144)-XMI(2,JI)
13519 210 CONTINUE
13520C...Loop over sides.
13521C...Generate trial branchings for this interaction. The hardest
13522C...branching so far is automatically updated if necessary in /PYISMX/.
13523 DO 220 JS=1,2
13524 MINT(30)=JS
13525 PT20=PT2MIN
13526 IF (MSTP(70).EQ.0) THEN
13527 PT20=MAX(PT2MIN,PARP(62)**2)
13528 ELSEIF (MSTP(70).EQ.1) THEN
13529 PT20=MAX(PT2MIN,
13530 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13531 ENDIF
13532 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13533 IF (MINT(51).NE.0) RETURN
13534 220 CONTINUE
13535 230 CONTINUE
13536 ENDIF
13537
13538C...Generate trial additional interaction.
13539 MINT(36)=MINT(31)+1
13540 240 IF (MOD(MSTP(81),10).GE.1) THEN
13541 MINT(1)=96
13542C...Set up X remaining in BR.
13543 VINT(143)=1D0
13544 VINT(144)=1D0
13545 DO 250 JI=1,MINT(31)
13546 VINT(143)=VINT(143)-XMI(1,JI)
13547 VINT(144)=VINT(144)-XMI(2,JI)
13548 250 CONTINUE
13549C...Generate trial interaction
13550 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13551 IF (MINT(51).EQ.1) RETURN
13552 ENDIF
13553
13554C...And the winner is:
13555 IF (PT2MX.LT.PT2MIN) THEN
13556 GOTO 330
13557 ELSEIF (JSMX.EQ.0) THEN
13558C...Accept additional interaction (may still fail).
13559 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13560 IF(MINT(51).NE.0) RETURN
13561 IF (IFAIL.EQ.0) THEN
13562 SHAT(MINT(36))=VINT(44)
13563C...Decide on flavours (valence/sea/companion).
13564 DO 270 JS=1,2
13565 MINT(30)=JS
13566 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13567 IF(MINT(51).NE.0) RETURN
13568 270 CONTINUE
13569 ENDIF
13570 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13571C...Reconstruct kinematics of acceptable ISR branching.
13572C...Set up shat, initiator x values, and x remaining in BR.
13573 MINT(30)=JSMX
13574 MINT(36)=MIMX
13575 VINT(44)=SHAT(MINT(36))
13576 VINT(141)=XMI(1,MINT(36))
13577 VINT(142)=XMI(2,MINT(36))
13578 VINT(143)=1D0
13579 VINT(144)=1D0
13580 DO 280 JI=1,MINT(31)
13581 IF (JI.EQ.MINT(36)) GOTO 280
13582 VINT(143)=VINT(143)-XMI(1,JI)
13583 VINT(144)=VINT(144)-XMI(2,JI)
13584 280 CONTINUE
13585 PT2NEW=PT2MX
13586 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13587 IF (MINT(51).EQ.1) RETURN
13588 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13589C...Bookeep joining. Cannot (yet) be constructed kinematically.
13590 MINT(354)=MINT(354)+1
13591 VINT(354)=VINT(354)+SQRT(PT2MX)
13592 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13593 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13594 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13595 ENDIF
13596
13597C...Update PT2 iteration scale.
13598 PT2CMX=PT2MX
13599
13600C...Loop back to continue evolution.
13601 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13602 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13603 ELSE
13604 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13605 ENDIF
13606
13607C----------------------------------------------------------------------
13608C...MODE= 2: (Re-)store user information on hardest interaction etc.
13609 ELSEIF (MODE.EQ.2) THEN
13610
13611C...Revert to "ordinary" meanings of some parameters.
13612 290 DO 310 JS=1,2
13613 MINT(12+JS)=K(IMI(JS,1,1),2)
13614 VINT(140+JS)=XMI(JS,1)
13615 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13616 VINT(142+JS)=1D0
13617 DO 300 MI=1,MINT(31)
13618 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13619 300 CONTINUE
13620 310 CONTINUE
13621
13622C...Restore saved quantities for hardest interaction.
13623 MINT(1)=ISUBHD
13624 MINT(15)=M15SV
13625 MINT(16)=M16SV
13626 MINT(21)=M21SV
13627 MINT(22)=M22SV
13628 DO 320 J=11,80
13629 VINT(J)=VINTSV(J)
13630 320 CONTINUE
13631
13632 ENDIF
13633
13634 330 RETURN
13635 END
13636
13637C*********************************************************************
13638
13639C...PYSSPA
13640C...Generates spacelike parton showers.
13641
13642 SUBROUTINE PYSSPA(IPU1,IPU2)
13643
13644C...Double precision and integer declarations.
13645 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13646 IMPLICIT INTEGER(I-N)
13647 INTEGER PYK,PYCHGE,PYCOMP
13648 PARAMETER (MAXNUR=1000)
13649C...Commonblocks.
13650 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13651 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13652 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13653 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13654 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13655 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13656 COMMON/PYINT1/MINT(400),VINT(400)
13657 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13658 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13659 COMMON/PYCTAG/NCT,MCT(4000,2)
13660 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13661 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13662C...Local arrays and data.
13663 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13664 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13665 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13666 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13667 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13668 DATA IS/2*0/
13669
13670C...Read out basic information; set global Q^2 scale.
13671 IPUS1=IPU1
13672 IPUS2=IPU2
13673 ISUB=MINT(1)
13674 Q2MX=VINT(56)
13675 VINT2R=VINT(2)*VINT(143)*VINT(144)
13676 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13677 &MIN(VINT2R,PARP(67)*VINT(56))
13678 FCQ2MX=1D0
13679
13680C...Define which processes ME corrections have been implemented for.
13681 MECOR=0
13682 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13683 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13684 & ISUB.EQ.144) MECOR=1
13685 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13686 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13687 ENDIF
13688
13689C...Initialize QCD evolution and check phase space.
13690 Q2MNC=PARP(62)**2
13691 Q2MNCS(1)=Q2MNC
13692 Q2MNCS(2)=Q2MNC
13693 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13694 Q0S=PARP(15)**2
13695 PS=VINT(3)**2
13696 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13697 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13698 Q2INT=SQRT(Q0S*Q2EFF)
13699 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13700 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13701 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13702 ENDIF
13703 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13704 Q0S=PARP(15)**2
13705 PS=VINT(4)**2
13706 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13707 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13708 Q2INT=SQRT(Q0S*Q2EFF)
13709 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13710 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13711 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13712 ENDIF
13713 MCEV=0
13714 ALAMS=PARU(112)
13715 PARU(112)=PARP(61)
13716 FQ2C=1D0
13717 TCMX=0D0
13718 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13719 MCEV=1
13720 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13721 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13722 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13723 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13724 & MCEV=0
13725 ENDIF
13726
13727C...Initialize QED evolution and check phase space.
13728 MEEV=0
13729 XEE=1D-10
13730 SPME=PMAS(11,1)**2
13731 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13732 &SPME=PMAS(13,1)**2
13733 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13734 &SPME=PMAS(15,1)**2
13735 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13736 TEMX=0D0
13737 FWTE=10D0
13738 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13739 MEEV=1
13740 TEMX=LOG(Q2MX/SPME)
13741 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13742 ENDIF
13743 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
13744 MEEV=2
13745 TEMX=TCMX
13746 FWTE=1D0
13747 ENDIF
13748 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
13749
13750C...Loopback point in case of failure to reconstruct kinematics.
13751 NS=N
13752 NPARTS=NPART
13753 LOOP=0
13754 MNT352=MINT(352)
13755 MNT353=MINT(353)
13756 VNT352=VINT(352)
13757 VNT353=VINT(353)
13758 100 LOOP=LOOP+1
13759 IF(LOOP.GT.100) THEN
13760 MINT(51)=1
13761 RETURN
13762 ENDIF
13763 N=NS
13764 NPART=NPARTS
13765 MINT(352)=MNT352
13766 MINT(353)=MNT353
13767 VINT(352)=VNT352
13768 VINT(353)=VNT353
13769
13770C...Initial values: flavours, momenta, virtualities.
13771 DO 120 JT=1,2
13772 MORE(JT)=1
13773 KFBEAM(JT)=MINT(10+JT)
13774 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
13775 KFLS(JT)=MINT(14+JT)
13776 KFLS(JT+2)=KFLS(JT)
13777 XS(JT)=VINT(40+JT)
13778 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
13779 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
13780 ZS(JT)=1D0
13781 Q2S(JT)=FCQ2MX*Q2MX
13782 DQ2(JT)=0D0
13783 TEVCSV(JT)=TCMX
13784 ALAM(JT)=PARP(61)
13785 THE2(JT)=1D0
13786 TEVESV(JT)=TEMX
13787 MCESV(JT)=0
13788C...Calculate initial parton distribution weights.
13789 MINT(105)=MINT(102+JT)
13790 MINT(109)=MINT(106+JT)
13791 VINT(120)=VINT(2+JT)
13792C.... ALICE
13793C.... Store side in MINT(124)
13794 MINT(124) = JT
13795C....
13796 IF(XS(JT).LT.1D0-XEE) THEN
13797 IF(MINT(31).GE.2) MINT(30)=JT
13798 IF(MSTP(57).LE.1) THEN
13799 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13800 ELSE
13801 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
13802 ENDIF
13803 ENDIF
13804 DO 110 KFL=-25,25
13805 XFS(JT,KFL)=XFB(KFL)
13806 110 CONTINUE
13807C...Special kinematics check for c/b quarks (that g -> c cbar or
13808C...b bbar kinematically possible).
13809 KFLCB=IABS(KFLS(JT))
13810 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
13811 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
13812 MINT(51)=1
13813 RETURN
13814 ENDIF
13815 ENDIF
13816 120 CONTINUE
13817 DSH=VINT(44)
13818 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
13819
13820C...Find if interference with final state partons.
13821 MFIS=0
13822 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
13823 IF(MFIS.NE.0) THEN
13824 DO 140 I=1,2
13825 KCFI(I)=0
13826 KCA=PYCOMP(IABS(KFLS(I)))
13827 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
13828 NFIS(I)=0
13829 IF(KCFI(I).NE.0) THEN
13830 IF(I.EQ.1) IPFS=IPUS1
13831 IF(I.EQ.2) IPFS=IPUS2
13832 DO 130 J=1,2
13833 ICSI=MOD(K(IPFS,3+J),MSTU(5))
13834 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
13835 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
13836 NFIS(I)=NFIS(I)+1
13837 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
13838 & P(ICSI,2)**2))
13839 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
13840 ENDIF
13841 130 CONTINUE
13842 ENDIF
13843 140 CONTINUE
13844 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
13845 ENDIF
13846
13847C...Pick up leg with highest virtuality.
13848 JTOLD=1
13849 150 N=N+1
13850 JT=1
13851 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
13852 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
13853 IF(MORE(JT).EQ.0) JT=3-JT
13854 JTOLD=JT
13855 KFLB=KFLS(JT)
13856 XB=XS(JT)
13857 DO 160 KFL=-25,25
13858 XFB(KFL)=XFS(JT,KFL)
13859 160 CONTINUE
13860 DSHR=2D0*SQRT(DSH)
13861 DSHZ=DSH/ZS(JT)
13862
13863C...Check if allowed to branch.
13864 MCEV=0
13865 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
13866 MCEV=1
13867 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
13868 IF(XB.GE.1D0-2D0*XEC) MCEV=0
13869 ENDIF
13870 MEEV=0
13871 IF(MINT(44+JT).EQ.3) THEN
13872 MEEV=1
13873 IF(XB.GE.1D0-2D0*XEE) MEEV=0
13874 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
13875 & MEEV=0
13876C***Currently kill QED shower for resolved photoproduction.
13877 IF(MINT(18+JT).EQ.1) MEEV=0
13878C***Currently kill shower for W inside electron.
13879 IF(IABS(KFLB).EQ.24) THEN
13880 MCEV=0
13881 MEEV=0
13882 ENDIF
13883 ENDIF
13884 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
13885 &MEEV=2
13886 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
13887 Q2B=0D0
13888 GOTO 260
13889 ENDIF
13890
13891C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
13892 Q2B=Q2S(JT)
13893 TEVCB=TEVCSV(JT)
13894 TEVEB=TEVESV(JT)
13895 IF(MSTP(62).LE.1) THEN
13896 IF(ZS(JT).GT.0.99999D0) THEN
13897 Q2B=Q2S(JT)
13898 ELSE
13899 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
13900 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
13901 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
13902 ENDIF
13903 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
13904 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
13905 ENDIF
13906 IF(MCEV.EQ.1) THEN
13907 ALSDUM=PYALPS(FQ2C*Q2B)
13908 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
13909 ALAM(JT)=PARU(117)
13910 B0=(33D0-2D0*MSTU(118))/6D0
13911 ENDIF
13912 IF(MEEV.EQ.2) TEVEB=TEVCB
13913 TEVCBS=TEVCB
13914 TEVEBS=TEVEB
13915
13916C...Select side for interference with final state partons.
13917 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
13918 IFI=N-NS
13919 ISFI(IFI)=0
13920 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
13921 ISFI(IFI)=1
13922 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
13923 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
13924 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
13925 ISFI(IFI)=1
13926 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
13927 ENDIF
13928 ENDIF
13929
13930C...Calculate preweighting factor for ME-corrected processes.
13931 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
13932
13933C...Calculate Altarelli-Parisi weights.
13934 DO 170 KFL=-25,25
13935 WTAPC(KFL)=0D0
13936 WTAPE(KFL)=0D0
13937 WTSF(KFL)=0D0
13938 170 CONTINUE
13939C...q -> q (g or gamma emission), g -> q.
13940 IF(IABS(KFLB).LE.10) THEN
13941 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
13942 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
13943 EQ2=1D0/9D0
13944 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
13945 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
13946 & (XEC*(1D0-XEC)))
13947 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13948 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
13949 WTAPC(21)=WTGF*WTAPC(21)
13950 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13951 ENDIF
13952C...f -> f, gamma -> f.
13953 ELSEIF(IABS(KFLB).LE.20) THEN
13954 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
13955 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
13956 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
13957 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
13958 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13959 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
13960 WTAPE(22)=WTGF*WTAPE(22)
13961 ENDIF
13962C...f -> g, g -> g.
13963 ELSEIF(KFLB.EQ.21) THEN
13964 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
13965 DO 180 KFL=1,MSTP(58)
13966 WTAPC(KFL)=WTAPQ
13967 WTAPC(-KFL)=WTAPQ
13968 180 CONTINUE
13969 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
13970 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13971 DO 190 KFL=1,MSTP(58)
13972 WTAPC(KFL)=WTFG*WTAPC(KFL)
13973 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
13974 190 CONTINUE
13975 WTAPC(21)=WTGG*WTAPC(21)
13976 ENDIF
13977C...f -> gamma, W+, W-.
13978 ELSEIF(KFLB.EQ.22) THEN
13979 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
13980 WTAPE(11)=WTAPF
13981 WTAPE(-11)=WTAPF
13982 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
13983 WTAPE(11)=WTFG*WTAPE(11)
13984 WTAPE(-11)=WTFG*WTAPE(-11)
13985 ENDIF
13986 ELSEIF(KFLB.EQ.24) THEN
13987 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13988 & (XEE*(XB+XEE)))/XB
13989 ELSEIF(KFLB.EQ.-24) THEN
13990 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
13991 & (XEE*(XB+XEE)))/XB
13992 ENDIF
13993
13994C...Calculate parton distribution weights and sum.
13995 NTRY=0
13996 200 NTRY=NTRY+1
13997 IF(NTRY.GT.500) THEN
13998 MINT(51)=1
13999 RETURN
14000 ENDIF
14001 WTSUMC=0D0
14002 WTSUME=0D0
14003 XFBO=MAX(1D-10,XFB(KFLB))
14004 DO 210 KFL=-25,25
14005 WTSF(KFL)=XFB(KFL)/XFBO
14006 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14007 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14008 210 CONTINUE
14009 WTSUMC=MAX(0.0001D0,WTSUMC)
14010 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14011
14012C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14013 NTRY2=0
14014 220 NTRY2=NTRY2+1
14015 IF(NTRY2.GT.500) THEN
14016 MINT(51)=1
14017 RETURN
14018 ENDIF
14019 IF(MCEV.EQ.1) THEN
14020 IF(MSTP(64).LE.0) THEN
14021 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14022 ELSEIF(MSTP(64).EQ.1) THEN
14023 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14024 ELSE
14025 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14026 ENDIF
14027 ENDIF
14028 IF(MEEV.EQ.1) THEN
14029 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14030 & (PARU(101)*FWTE*WTSUME*TEMX)))
14031 ELSEIF(MEEV.EQ.2) THEN
14032 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14033 ENDIF
14034
14035C...Translate t into Q2 scale; choose between QCD and QED evolution.
14036 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14037 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14038 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14039C...Ensure that Q2 is above threshold for charm/bottom.
14040 KFLCB=IABS(KFLB)
14041 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14042 &MCEV.EQ.1) THEN
14043 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14044 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14045 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14046 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14047 ENDIF
14048 ENDIF
14049 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14050 &MEEV.EQ.2) THEN
14051 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14052 ENDIF
14053 MCE=0
14054 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14055 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14056 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14057 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14058 IF(Q2EB.GT.Q2MNE) MCE=2
14059 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14060 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14061 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14062 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14063 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14064 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14065 MCE=1
14066 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14067 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14068 ELSE
14069 MCE=2
14070 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14071 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14072 ENDIF
14073
14074C...Evolution possibly ended. Update t values.
14075 IF(MCE.EQ.0) THEN
14076 Q2B=0D0
14077 GOTO 260
14078 ELSEIF(MCE.EQ.1) THEN
14079 Q2B=Q2CB
14080 Q2REF=FQ2C*Q2B
14081 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14082 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14083 ELSE
14084 Q2B=Q2EB
14085 Q2REF=Q2B
14086 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14087 ENDIF
14088
14089C...Select flavour for branching parton.
14090 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14091 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14092 KFLA=-25
14093 240 KFLA=KFLA+1
14094 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14095 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14096 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14097 IF(KFLA.EQ.25) THEN
14098 Q2B=0D0
14099 GOTO 260
14100 ENDIF
14101
14102C...Choose z value and corrective weight.
14103 WTZ=0D0
14104C...q -> q + g or q -> q + gamma.
14105 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14106 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14107 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14108 WTZ=0.5D0*(1D0+Z**2)
14109C...q -> g + q.
14110 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14111 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14112 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14113C...f -> f + gamma.
14114 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14115 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14116 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14117 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14118 ELSE
14119 Z=XB+XB*(XEE/(1D0-XEE))*
14120 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14121 ENDIF
14122 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14123C...f -> gamma + f.
14124 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) 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
14128C...f -> W+- + f.
14129 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14130 Z=XB+XB*(XEE/(1D0-XEE))*
14131 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14132 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14133 & (Q2B/(Q2B+PMAS(24,1)**2))
14134C...g -> q + qbar.
14135 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14136 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14137 WTZ=1D0-2D0*Z*(1D0-Z)
14138C...g -> g + g.
14139 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14140 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14141 WTZ=(1D0-Z*(1D0-Z))**2
14142C...gamma -> f + fbar.
14143 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14144 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14145 WTZ=1D0-2D0*Z*(1D0-Z)
14146 ENDIF
14147 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14148
14149C...Option with resummation of soft gluon emission as effective z shift.
14150 IF(MCE.EQ.1) THEN
14151 IF(MSTP(65).GE.1) THEN
14152 RSOFT=6D0
14153 IF(KFLB.NE.21) RSOFT=8D0/3D0
14154 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14155 IF(Z.LE.XB) GOTO 220
14156 ENDIF
14157
14158C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14159 IF(MSTP(64).GE.2) THEN
14160 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14161 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14162 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14163 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14164 ENDIF
14165 ENDIF
14166
14167C...Remove kinematically impossible branchings.
14168 UHAT=Q2B-DSH*(1D0-Z)/Z
14169 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14170
14171C...Select phi angle of branching at random.
14172 PHIBR=PARU(2)*PYR(0)
14173
14174C...Matrix-element corrections for some processes.
14175 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14176 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14177 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14178 WTZ=WTZ*WTME/WTFF
14179 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14180 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14181 WTZ=WTZ*WTME/WTGF
14182 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14183 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14184 WTZ=WTZ*WTME/WTFG
14185 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14186 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14187 WTZ=WTZ*WTME/WTGG
14188 ENDIF
14189 ENDIF
14190
14191C...Impose angular constraint in first branching from interference
14192C...with final state partons.
14193 IF(MCE.EQ.1) THEN
14194 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14195 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14196 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14197 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14198 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14199 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14200 ENDIF
14201 ENDIF
14202
14203C...Option with angular ordering requirement.
14204 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14205 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14206 IF(THE2T.GT.THE2(JT)) GOTO 220
14207 ENDIF
14208 ENDIF
14209
14210C...Weighting with new parton distributions.
14211 MINT(105)=MINT(102+JT)
14212 MINT(109)=MINT(106+JT)
14213 VINT(120)=VINT(2+JT)
14214 IF(MINT(31).GE.2) MINT(30)=JT
14215C.... ALICE
14216C.... Store side in MINT(124)
14217 MINT(124) = JT
14218C....
14219 IF(MSTP(57).LE.1) THEN
14220 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14221 ELSE
14222 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14223 ENDIF
14224 XFBN=XFN(KFLB)
14225 IF(XFBN.LT.1D-20) THEN
14226 IF(KFLA.EQ.KFLB) THEN
14227 TEVCB=TEVCBS
14228 TEVEB=TEVEBS
14229 WTAPC(KFLB)=0D0
14230 WTAPE(KFLB)=0D0
14231 GOTO 200
14232 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14233 TEVCB=0.5D0*(TEVCBS+TEVCB)
14234 GOTO 230
14235 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14236 TEVEB=0.5D0*(TEVEBS+TEVEB)
14237 GOTO 230
14238 ELSE
14239 XFBN=1D-10
14240 XFN(KFLB)=XFBN
14241 ENDIF
14242 ENDIF
14243 DO 250 KFL=-25,25
14244 XFB(KFL)=XFN(KFL)
14245 250 CONTINUE
14246 XA=XB/Z
14247C.... ALICE
14248C.... Store side in MINT(124)
14249 MINT(124) = JT
14250C....
14251 IF(MINT(31).GE.2) MINT(30)=JT
14252 IF(MSTP(57).LE.1) THEN
14253 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14254 ELSE
14255 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14256 ENDIF
14257 XFAN=XFA(KFLA)
14258 IF(XFAN.LT.1D-20) GOTO 200
14259 WTSFA=WTSF(KFLA)
14260 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14261
14262C...Define two hard scatterers in their CM-frame.
14263 260 IF(N.EQ.NS+2) THEN
14264 DQ2(JT)=Q2B
14265 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14266 DO 280 JR=1,2
14267 I=NS+JR
14268 IF(JR.EQ.1) IPO=IPUS1
14269 IF(JR.EQ.2) IPO=IPUS2
14270 DO 270 J=1,5
14271 K(I,J)=0
14272 P(I,J)=0D0
14273 V(I,J)=0D0
14274 270 CONTINUE
14275 K(I,1)=14
14276 K(I,2)=KFLS(JR+2)
14277 K(I,4)=IPO
14278 K(I,5)=IPO
14279 P(I,3)=DPLCM*(-1)**(JR+1)
14280 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14281 P(I,5)=-SQRT(DQ2(JR))
14282 K(IPO,1)=14
14283 K(IPO,3)=I
14284 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14285 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14286 MCT(I,1)=MCT(IPO,1)
14287 MCT(I,2)=MCT(IPO,2)
14288 280 CONTINUE
14289
14290C...Find maximum allowed mass of timelike parton.
14291 ELSEIF(N.GT.NS+2) THEN
14292 JR=3-JT
14293 DQ2(3)=Q2B
14294 DPC(1)=P(IS(1),4)
14295 DPC(2)=P(IS(2),4)
14296 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14297 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14298 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14299 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14300 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14301 IKIN=0
14302 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14303 & 1D-10*DPD(1)) IKIN=1
14304 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14305 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14306 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14307 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14308
14309C...Generate timelike parton shower (if required).
14310 IT=N
14311 DO 290 J=1,5
14312 K(IT,J)=0
14313 P(IT,J)=0D0
14314 V(IT,J)=0D0
14315 290 CONTINUE
14316C...f -> f + g (gamma).
14317 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14318 K(IT,2)=21
14319 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14320C...f -> g (gamma, W+-) + f.
14321 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14322 K(IT,2)=KFLB
14323 IF(KFLS(JT+2).EQ.24) THEN
14324 K(IT,2)=-12
14325 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14326 K(IT,2)=12
14327 ENDIF
14328C...g (gamma) -> f + fbar, g + g.
14329 ELSE
14330 K(IT,2)=-KFLS(JT+2)
14331 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14332 ENDIF
14333 K(IT,1)=3
14334 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14335 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14336 P(IT,5)=PYMASS(K(IT,2))
14337 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14338 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14339 MSTJ48=MSTJ(48)
14340 PARJ85=PARJ(85)
14341 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14342 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14343 IF(MSTP(63).EQ.1) THEN
14344 Q2TIM=DMSMA
14345 ELSEIF(MSTP(63).EQ.2) THEN
14346 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14347 ELSE
14348 Q2TIM=DMSMA
14349 MSTJ(48)=1
14350 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14351 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14352 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14353 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14354 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14355 ENDIF
14356C...Only do timelike shower here if using PYSHOW
14357 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14358 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14359 ENDIF
14360 MSTJ(48)=MSTJ48
14361 PARJ(85)=PARJ85
14362 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14363 ENDIF
14364
14365C...Reconstruct kinematics of branching: timelike parton shower.
14366 DMS=P(IT,5)**2
14367 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14368 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14369 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14370 & (4D0*DSH*DPC(3)**2)
14371 IF(DPT2.LT.0D0) GOTO 100
14372 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14373 & DSHR)/DPC(3)-DPC(3)
14374 P(IT,1)=SQRT(DPT2)
14375 P(IT,3)=DPB(1)*(-1)**(JT+1)
14376 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14377 IF(N.GE.IT+1) THEN
14378 DPB(1)=SQRT(DPB(1)**2+DPT2)
14379 DPB(2)=SQRT(DPB(1)**2+DMS)
14380 DPB(3)=P(IT+1,3)
14381 DPB(4)=SQRT(DPB(3)**2+DMS)
14382 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14383 & DPB(1))
14384 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14385 THE=PYANGL(P(IT,3),P(IT,1))
14386 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14387 ENDIF
14388
14389C...Reconstruct kinematics of branching: spacelike parton.
14390 DO 300 J=1,5
14391 K(N+1,J)=0
14392 P(N+1,J)=0D0
14393 V(N+1,J)=0D0
14394 300 CONTINUE
14395 K(N+1,1)=14
14396 K(N+1,2)=KFLB
14397 P(N+1,1)=P(IT,1)
14398 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14399 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14400 P(N+1,5)=-SQRT(DQ2(3))
14401 MCT(N+1,1)=0
14402 MCT(N+1,2)=0
14403
14404C...Define colour flow of branching.
14405 K(IS(JT),3)=N+1
14406 K(IT,3)=N+1
14407 IM1=N+1
14408 IM2=N+1
14409C...f -> f + gamma (Z, W).
14410 IF(IABS(K(IT,2)).GE.22) THEN
14411 K(IT,1)=1
14412 ID1=IS(JT)
14413 ID2=IS(JT)
14414C...f -> gamma (Z, W) + f.
14415 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14416 ID1=IT
14417 ID2=IT
14418C...gamma -> q + qbar, g + g.
14419 ELSEIF(K(N+1,2).EQ.22) THEN
14420 ID1=IS(JT)
14421 ID2=IT
14422 IM1=ID2
14423 IM2=ID1
14424C...q -> q + g.
14425 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14426 ID1=IT
14427 ID2=IS(JT)
14428C...q -> g + q.
14429 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14430 ID1=IS(JT)
14431 ID2=IT
14432C...qbar -> qbar + g.
14433 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14434 ID1=IS(JT)
14435 ID2=IT
14436C...qbar -> g + qbar.
14437 ELSEIF(K(N+1,2).LT.0) THEN
14438 ID1=IT
14439 ID2=IS(JT)
14440C...g -> g + g; g -> q + qbar.
14441 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14442 ID1=IS(JT)
14443 ID2=IT
14444 ELSE
14445 ID1=IT
14446 ID2=IS(JT)
14447 ENDIF
14448 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14449 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14450 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14451 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14452 IF(ID1.NE.ID2) THEN
14453 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14454 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14455 ENDIF
14456 N=N+1
14457 IF(K(IT,1).EQ.1) THEN
14458 K(IT,4)=0
14459 K(IT,5)=0
14460 ENDIF
14461
14462C...Boost to new CM-frame.
14463 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14464 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14465 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14466 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14467 IR=N+(JT-1)*(IS(1)-N)
14468 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14469 & 0D0,0D0,0D0)
14470
14471C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14472 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14473 NPART=NPART+1
14474 IPART(NPART)=IT
14475 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14476 ENDIF
14477
14478C...Global statistics.
14479 MINT(352)=MINT(352)+1
14480 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14481 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14482
14483 ENDIF
14484
14485C...Update kinematics variables.
14486 IS(JT)=N
14487 DQ2(JT)=Q2B
14488 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14489 DSH=DSHZ
14490
14491C...Save quantities; loop back.
14492 Q2S(JT)=Q2B
14493 DPHI(JT)=PHIBR
14494 MCESV(JT)=MCE
14495 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14496 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14497 KFLS(JT+2)=KFLS(JT)
14498 KFLS(JT)=KFLA
14499 XS(JT)=XA
14500 ZS(JT)=Z
14501 DO 310 KFL=-25,25
14502 XFS(JT,KFL)=XFA(KFL)
14503 310 CONTINUE
14504 TEVCSV(JT)=TEVCB
14505 TEVESV(JT)=TEVEB
14506 ELSE
14507 MORE(JT)=0
14508 IF(JT.EQ.1) IPU1=N
14509 IF(JT.EQ.2) IPU2=N
14510 ENDIF
14511 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14512 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14513 IF(MSTU(21).GE.1) N=NS
14514 IF(MSTU(21).GE.1) RETURN
14515 ENDIF
14516 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14517
14518C...Boost hard scattering partons to frame of shower initiators.
14519 DO 320 J=1,3
14520 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14521 320 CONTINUE
14522 K(N+2,1)=1
14523 DO 330 J=1,5
14524 P(N+2,J)=P(NS+1,J)
14525 330 CONTINUE
14526 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14527 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14528 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14529 IMIN=MINT(83)+5
14530 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14531 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14532 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14533
14534C...Store user information. Reset Lambda value.
14535 IF(MINT(31).LE.1) THEN
14536 K(IPU1,3)=MINT(83)+3
14537 K(IPU2,3)=MINT(83)+4
14538 ELSE
14539 K(IPU1,3)=MINT(83)+1
14540 K(IPU2,3)=MINT(83)+2
14541 ENDIF
14542 DO 340 JT=1,2
14543 MINT(12+JT)=KFLS(JT)
14544 VINT(140+JT)=XS(JT)
14545 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14546 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14547 340 CONTINUE
14548 PARU(112)=ALAMS
14549
14550 RETURN
14551 END
14552
14553C*********************************************************************
14554
14555C...PYPTIS
14556C...Generates pT-ordered spacelike initial-state parton showers and
14557C...trial joinings.
14558C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14559C... interaction initiators at PT2NOW.
14560C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14561C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14562C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14563C... is below PT2CUT.
14564C... (Also generate test joinings if MSTP(96)=1.)
14565C...MODE= 1: Accept stored shower branching. Update event record etc.
14566C...PT2NOW : Starting (max) PT2 scale for evolution.
14567C...PT2CUT : Lower limit for evolution.
14568C...PT2 : Result of evolution. Generated PT2 for trial emission.
14569C...IFAIL : Status return code. IFAIL=0 when all is well.
14570
14571 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14572
14573C...Double precision and integer declarations.
14574 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14575 IMPLICIT INTEGER(I-N)
14576 INTEGER PYK,PYCHGE,PYCOMP
14577C...Parameter statement for maximum size of showers.
14578 PARAMETER (MAXNUR=1000)
14579C...Commonblocks.
14580 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14581 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14582 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14583 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14584 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14585 COMMON/PYINT1/MINT(400),VINT(400)
14586 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14587 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14588 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14589 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14590 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14591 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14592 COMMON/PYCTAG/NCT,MCT(4000,2)
14593 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14594 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14595 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14596C...Local variables
14597 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14598 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14599 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14600 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14601 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14602 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14603C...For check on excessive weights.
14604 CHARACTER CHWT*12
14605
14606C...Only give errors for very large weights, otherwise just warnings
14607 DATA WTEMAX /1.5D0/
14608C...Only give errors for large pT, otherwise just warnings
14609 DATA PTEMAX /5D0/
14610
14611 IFAIL=-1
14612
14613C----------------------------------------------------------------------
14614C...MODE=-1: Initialize initial state showers from scratch, i.e.
14615C...starting from the hardest interaction initiators.
14616 IF (MODE.EQ.-1) THEN
14617C...Set hard scattering SHAT.
14618 SHTNOW(1)=VINT(44)
14619C...Mass thresholds and Lambda for QCD evolution.
14620 AEM2PI=PARU(101)/PARU(2)
14621 RMB=PMAS(5,1)
14622 RMC=PMAS(4,1)
14623 ALAM4=PARP(61)
14624 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14625 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14626 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14627 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14628C...Optionally use Lambda_MC = Lambda_CMW
14629 IF (MSTP(64).EQ.3) THEN
14630 ALAM5 = ALAM5 * 1.569
14631 ALAM4 = ALAM4 * 1.618
14632 ALAM3 = ALAM3 * 1.661
14633 ENDIF
14634 RMB2=RMB**2
14635 RMC2=RMC**2
14636C...Massive quark forced creation threshold (in M**2).
14637 TMIN=1.01D0
14638C...Set upper limit for X (ensures some X left for beam remnant).
14639 XMXC=1D0-2D0*PARP(111)/VINT(1)
14640
14641 IF (MSTP(61).GE.1) THEN
14642C...Initial values: flavours, momenta, virtualities.
14643 DO 100 JS=1,2
14644 NISGEN(JS,1)=0
14645
14646C...Special kinematics check for c/b quarks (that g -> c cbar or
14647C...b bbar kinematically possible).
14648 KFLB=K(IMI(JS,1,1),2)
14649 KFLCB=IABS(KFLB)
14650 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14651C...Check PT2MAX > mQ^2
14652 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14653 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14654 & 'No Q creation possible.')
14655 MINT(51)=1
14656 RETURN
14657 ELSE
14658C...Check for physical z values (m == MQ / sqrt(s))
14659C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14660 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14661 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14662 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14663 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14664 & 'Q creation.')
14665 MINT(51)=1
14666 RETURN
14667 ENDIF
14668 ENDIF
14669 ENDIF
14670 100 CONTINUE
14671 ENDIF
14672
14673 MINT(354)=0
14674C...Zero joining array
14675 DO 110 MJ=1,240
14676 MJOIND(1,MJ)=0
14677 MJOIND(2,MJ)=0
14678 110 CONTINUE
14679
14680C----------------------------------------------------------------------
14681C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14682C...MINT(30). Store if emission PT2 scale is largest so far.
14683C...Also generate test joinings if MSTP(96)=1.
14684 ELSEIF(MODE.EQ.0) THEN
14685 IFAIL=-1
14686 MECOR=0
14687 ISUB=MINT(1)
14688 JS=MINT(30)
14689C...No shower for structureless beam
14690 IF (MINT(44+JS).EQ.1) RETURN
14691 MI=MINT(36)
14692 SHAT=VINT(44)
14693C...Absolute shower max scale = VINT(56)
14694 PT2=MIN(PT2NOW,VINT(56))
14695 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14696C...Define for which processes ME corrections have been implemented.
14697 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14698 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14699 & .142.OR.ISUB.EQ.144) MECOR=1
14700 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14701 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14702C...Calculate preweighting factor for ME-corrected processes.
14703 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14704 ENDIF
14705C...Basic info on daughter for which to find mother.
14706 KFLB=K(IMI(JS,MI,1),2)
14707 KFLBA=IABS(KFLB)
14708C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14709C...second companion.
14710 KSVCB=MAX(-1,IMI(JS,MI,2))
14711C...Treat "first" companion of a pair like an ordinary sea quark
14712C...(except that creation diagram is not allowed)
14713 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14714C...X (rescaled to [0,1])
14715 XB=XMI(JS,MI)/VINT(142+JS)
14716C...Massive quarks (use physical masses.)
14717 RMQ2=0D0
14718 MQMASS=0
14719 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14720 RMQ2=RMC2
14721 IF (KFLBA.EQ.5) RMQ2=RMB2
14722C...Special threshold treatment for non-photon beams
14723 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14724 ENDIF
14725
14726C...Flags for parton distribution calls.
14727 MINT(105)=MINT(102+JS)
14728 MINT(109)=MINT(106+JS)
14729 VINT(120)=VINT(2+JS)
14730
14731C.... ALICE
14732C.... Store side in MINT(124)
14733 MINT(124) = JS
14734C....
14735C...Calculate initial parton distribution weights.
14736 IF(XB.GE.XMXC) THEN
14737 RETURN
14738 ELSEIF(MQMASS.EQ.0) THEN
14739 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
14740 ELSE
14741C...Initialize massive quark PT2 dependent pdf underestimate.
14742 PT20=PT2
14743 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
14744C.!.Tentative treatment of massive valence quarks.
14745 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
14746 XG0=XFB(21)
14747 TPM0=LOG(PT20/RMQ2)
14748 WPDF0=TPM0*XG0/XQ0
14749 ENDIF
14750 IF (KFLBA.LE.6) THEN
14751C...For quarks, only include respective sea, val, or cmp part.
14752 IF (KSVCB.LE.0) THEN
14753 XFB(KFLB)=XPSVC(KFLB,KSVCB)
14754 ELSE
14755C...Find companion's companion
14756 MISEA=0
14757 120 MISEA=MISEA+1
14758 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
14759 XS=XMI(JS,MISEA)
14760 XREM=VINT(142+JS)
14761 YS=XS/(XREM+XS)
14762C...Momentum fraction of the companion quark.
14763C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
14764 YB=XB*(1D0-YS)
14765 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
14766 ENDIF
14767 ENDIF
14768
14769C...Determine overestimated z range: switch at c and b masses.
14770 130 IF (PT2.GT.TMIN*RMB2) THEN
14771 IZRG=3
14772 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
14773 B0=23D0/6D0
14774 ALAM2=ALAM5**2
14775 ELSEIF(PT2.GT.TMIN*RMC2) THEN
14776 IZRG=2
14777 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
14778 B0=25D0/6D0
14779 ALAM2=ALAM4**2
14780 ELSE
14781 IZRG=1
14782 PT2MNE=PT2CUT
14783 B0=27D0/6D0
14784 ALAM2=ALAM3**2
14785 ENDIF
14786C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
14787 ALAM2=ALAM2/PARP(64)
14788C...Overestimated ZMAX:
14789 IF (MQMASS.EQ.0) THEN
14790C...Massless
14791 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
14792 & /PT2MNE)-1D0)
14793 ELSE
14794C...Massive (limit for bremsstrahlung diagram > creation)
14795 FMQ=SQRT(RMQ2/SHTNOW(MI))
14796 ZMAX=1D0/(1D0+FMQ)
14797 ENDIF
14798 ZMIN=XB/XMXC
14799
14800C...If kinematically impossible then do not evolve.
14801 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
14802
14803C...Reset Altarelli-Parisi and PDF weights.
14804 DO 140 KFL=-5,5
14805 WTAP(KFL)=0D0
14806 WTPDF(KFL)=0D0
14807 140 CONTINUE
14808 WTAP(21)=0D0
14809 WTPDF(21)=0D0
14810C...Zero joining weights and compute X(partner) and X(mother) values.
14811 IF (MSTP(96).NE.0) THEN
14812 NJN=0
14813 DO 150 MJ=1,MINT(31)
14814 WTAPJ(MJ)=0D0
14815 WTPDFJ(MJ)=0D0
14816 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
14817 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
14818 & +XMI(JS,MI))
14819 150 CONTINUE
14820 ENDIF
14821
14822C...Approximate Altarelli-Parisi weights (integrated AP dz).
14823C...q -> q, g -> q or q -> q + gamma (already set which).
14824 IF(KFLBA.LE.5) THEN
14825C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
14826 IF (KSVCB.LT.0) THEN
14827 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14828 ELSE
14829 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
14830 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
14831 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
14832 ENDIF
14833 WTAP(21)=0.5D0*(ZMAX-ZMIN)
14834 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
14835 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
14836 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14837 WTAP(KFLB)=WTFF*WTAP(KFLB)
14838 WTAP(21)=WTGF*WTAP(21)
14839 WTAPE=WTFF*WTAPE
14840 ENDIF
14841 IF (KSVCB.GE.1) THEN
14842C...Kill normal creation but add joining diagrams for cmp quark.
14843 WTAP(21)=0D0
14844 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14845 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
14846 & " quark here. Not handled yet, giving up!")
14847 PT2=0D0
14848 MINT(51)=1
14849 RETURN
14850 ENDIF
14851C...Check for possible joinings
14852 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
14853C...Find companion's companion.
14854 MJ=0
14855 160 MJ=MJ+1
14856 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
14857 IF (MJOIND(JS,MJ).EQ.0) THEN
14858 Y(MI)=YB+YS
14859 Z=YB/Y(MI)
14860 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
14861 IF (WTAPJ(MJ).GT.1D-6) THEN
14862 NJN=1
14863 ELSE
14864 WTAPJ(MJ)=0D0
14865 ENDIF
14866 ENDIF
14867C...Add trial gluon joinings.
14868 DO 170 MJ=1,MINT(31)
14869 KFLC=K(IMI(JS,MJ,1),2)
14870 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
14871 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14872 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14873 IF (WTAPJ(MJ).GT.1D-6) THEN
14874 NJN=NJN+1
14875 ELSE
14876 WTAPJ(MJ)=0D0
14877 ENDIF
14878 170 CONTINUE
14879 ENDIF
14880 ELSEIF (IMI(JS,MI,2).GE.0) THEN
14881C...Kill creation diagram for val quarks and sea quarks with companions.
14882 WTAP(21)=0D0
14883 ELSEIF (MQMASS.EQ.0) THEN
14884C...Extra safety factor for massless sea quark creation.
14885 WTAP(21)=WTAP(21)*1.25D0
14886 ENDIF
14887
14888C... q -> g, g -> g.
14889 ELSEIF(KFLB.EQ.21) THEN
14890C...Here we decide later whether a quark picked up is valence or
14891C...sea, so we maintain the extra factor sqrt(z) since we deal
14892C...with the *sum* of sea and valence in this context.
14893 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
14894C...new: do not allow backwards evol to pick up heavy flavour.
14895 DO 180 KFL=1,MIN(3,MSTP(58))
14896 WTAP(KFL)=WTAPQ
14897 WTAP(-KFL)=WTAPQ
14898 180 CONTINUE
14899 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
14900 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
14901 WTAPQ=WTFG*WTAPQ
14902 WTAP(21)=WTGG*WTAP(21)
14903 ENDIF
14904C...Check for possible joinings (companions handled separately above)
14905 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
14906 & THEN
14907 DO 190 MJ=1,MINT(31)
14908 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
14909 KSVCC=IMI(JS,MJ,2)
14910 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14911 IF (KSVCC.GE.1) GOTO 190
14912 KFLC=K(IMI(JS,MJ,1),2)
14913C...Only try g -> g + g once.
14914 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
14915 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
14916 IF (KFLC.EQ.21) THEN
14917 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
14918 ELSE
14919 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
14920 ENDIF
14921 IF (WTAPJ(MJ).GT.1D-6) THEN
14922 NJN=NJN+1
14923 ELSE
14924 WTAPJ(MJ)=0D0
14925 ENDIF
14926 190 CONTINUE
14927 ENDIF
14928 ENDIF
14929
14930C...Initialize massive quark evolution
14931 IF (MQMASS.NE.0) THEN
14932 RML=(RMQ2+VINT(18))/ALAM2
14933 TML=LOG(RML)
14934 TPL=LOG((PT2+VINT(18))/ALAM2)
14935 TPM=LOG((PT2+VINT(18))/RMQ2)
14936 WN=WTAP(21)*WPDF0/B0
14937 ENDIF
14938
14939
14940C...Loopback point for iteration
14941 NTRY=0
14942 NTHRES=0
14943 200 NTRY=NTRY+1
14944 IF(NTRY.GT.500) THEN
14945 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
14946 MINT(51)=1
14947 RETURN
14948 ENDIF
14949
14950C... Calculate PDF weights and sum for evolution rate.
14951 WTSUM=0D0
14952 XFBO=MAX(1D-10,XFB(KFLB))
14953 DO 210 KFL=-5,5
14954 WTPDF(KFL)=XFB(KFL)/XFBO
14955 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
14956 210 CONTINUE
14957C...Only add gluon mother diagram for massless KFLB.
14958 IF(MQMASS.EQ.0) THEN
14959 WTPDF(21)=XFB(21)/XFBO
14960 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
14961 ENDIF
14962 WTSUM=MAX(0.0001D0,WTSUM)
14963 WTSUMS=WTSUM
14964C...Add joining diagrams where applicable.
14965 WTJOIN=0D0
14966 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
14967 DO 220 MJ=1,MINT(31)
14968 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
14969 WTPDFJ(MJ)=1D0/XFBO
14970C...x and x*pdf (+ sea/val) for parton C.
14971 KFLC=K(IMI(JS,MJ,1),2)
14972 KFLCA=IABS(KFLC)
14973 KSVCC=MAX(-1,IMI(JS,MJ,2))
14974 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
14975 MINT(30)=JS
14976 MINT(36)=MJ
14977C.... ALICE
14978C.... Store side in MINT(124)
14979 MINT(124) = JS
14980C....
14981 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
14982 MINT(36)=MI
14983 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
14984 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
14985 ELSEIF (KSVCC.GE.1) THEN
14986 print*, 'error! parton C is companion!'
14987 ENDIF
14988 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
14989C...x and x*pdf (+ sea/val) for parton A.
14990 KFLA=21
14991 KSVCA=0
14992 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
14993 KFLA=KFLB
14994 KSVCA=KSVCB
14995 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
14996 KFLA=KFLC
14997 KSVCA=KSVCC
14998 ENDIF
14999 MINT(30)=JS
15000C.... ALICE
15001C.... Store side in MINT(124)
15002 MINT(124) = JS
15003C....
15004 IF (KSVCA.LE.0) THEN
15005C...Consider C the "evolved" parton if B is gluon. Val/sea
15006C...counting will then be done correctly in PYPDFU.
15007 IF (KFLBA.EQ.21) MINT(36)=MJ
15008 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15009 MINT(36)=MI
15010 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15011 ELSE
15012C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15013 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15014 ENDIF
15015 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15016 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15017 220 CONTINUE
15018 ENDIF
15019
15020C...Pick normal pT2 (in overestimated z range).
15021 230 PT2OLD=PT2
15022 WTSUM=WTSUMS
15023 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15024 KFLC=21
15025
15026C...Evolve q -> q gamma separately, pick it if larger pT.
15027 IF(KFLBA.LE.5) THEN
15028 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15029 IF(PT2QED.GT.PT2) THEN
15030 PT2=PT2QED
15031 KFLC=22
15032 KFLA=KFLB
15033 ENDIF
15034 ENDIF
15035
15036C... Evolve massive quark creation separately.
15037 MCRQQ=0
15038 IF (MQMASS.NE.0) THEN
70b8e6ec 15039 if (WN .eq. 0.) THEN
15040 ARG = -1.
15041 ELSE
15042 ARG = TPM/(TPL*PYR(0)**(-TML/WN)-TPM)
15043 ENDIF
15044 PT2CR=(RMQ2+VINT(18))*(RML**ARG)-VINT(18)
02626a96 15045C... Ensure mininimum PT2CR and force creation near threshold.
15046 IF (PT2CR.LT.TMIN*RMQ2) THEN
15047 NTHRES=NTHRES+1
15048 IF (NTHRES.GT.50) THEN
15049 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15050 & 'massive quark creation. Gave up trying.')
15051 MINT(51)=1
15052C...Special return code if failing before any evolution at all: bad event
15053 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15054 RETURN
15055 ENDIF
15056 PT2=0D0
15057 PT2CR=TMIN*RMQ2
15058 MCRQQ=2
15059 ENDIF
15060C... Select largest PT2 (brems or creation):
15061 IF (PT2CR.GT.PT2) THEN
15062 MCRQQ=MAX(MCRQQ,1)
15063 WTSUM=0D0
15064 PT2=PT2CR
15065 KFLA=21
15066 ELSE
15067 MCRQQ=0
15068 KFLA=KFLB
15069 ENDIF
15070C... Compute logarithms for this PT2
15071 TPL=LOG((PT2+VINT(18))/ALAM2)
15072 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15073 WTCRQQ=TPM/LOG(PT2/RMQ2)
15074 ENDIF
15075
15076C...Evolve joining separately
15077 MJOIN=0
15078 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15079 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15080 & -VINT(18)
15081 IF (PT2JN.GE.PT2) THEN
15082 MJOIN=1
15083 PT2=PT2JN
15084 ENDIF
15085 ENDIF
15086
15087C...Loopback if crossed c/b mass thresholds.
15088 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15089 PT2=RMB2
15090 GOTO 130
15091 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15092 PT2=RMC2
15093 GOTO 130
15094 ENDIF
15095
15096C...Speed up shower. Skip if higher-PT acceptable branching
15097C...already found somewhere else.
15098C...Also finish if below lower cutoff.
15099
15100 IF (PT2.LT.PT2MX.OR.PT2.LT.PT2CUT) RETURN
15101
15102C...Select parton A flavour (massive Q handled above.)
15103 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15104 WTRAN=PYR(0)*WTSUM
15105 KFLA=-6
15106 240 KFLA=KFLA+1
15107 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15108 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15109 IF(KFLA.EQ.6) KFLA=21
15110 ELSEIF (MJOIN.EQ.1) THEN
15111C...Tentative joining accept/reject.
15112 WTRAN=PYR(0)*WTJOIN
15113 MJ=0
15114 250 MJ=MJ+1
15115 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15116 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15117 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15118 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15119 & ' Rejected.')
15120 GOTO 230
15121 ENDIF
15122C...x*pdf (+ sea/val) at new pT2 for parton B.
15123 IF (KSVCB.LE.0) THEN
15124 MINT(30)=JS
15125C.... ALICE
15126C.... Store side in MINT(124)
15127 MINT(124) = JS
15128C....
15129 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15130 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15131 ELSE
15132C...Companion distributions do not evolve.
15133 XFB(KFLB)=XFBO
15134 ENDIF
15135 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15136 KFLC=K(IMI(JS,MJ,1),2)
15137 KFLCA=IABS(KFLC)
15138 KSVCC=MAX(-1,IMI(JS,MJ,2))
15139 IF (KSVCB.GE.1) KSVCC=-1
15140C...x*pdf (+ sea/val) at new pT2 for parton C.
15141 MINT(30)=JS
15142 MINT(36)=MJ
15143C.... ALICE
15144C.... Store side in MINT(124)
15145 MINT(124) = JS
15146C....
15147 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15148 MINT(36)=MI
15149 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15150 WTVETO=WTVETO/XFJ(KFLC)
15151C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15152 KFLA=21
15153 KSVCA=0
15154 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15155 KFLA=KFLB
15156 KSVCA=KSVCB
15157 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15158 KFLA=KFLC
15159 KSVCA=KSVCC
15160 ENDIF
15161 IF (KSVCA.LE.0) THEN
15162 MINT(30)=JS
15163C.... ALICE
15164C.... Store side in MINT(124)
15165 MINT(124) = JS
15166C....
15167 IF (KFLB.EQ.21) MINT(36)=MJ
15168 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15169 MINT(36)=MI
15170 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15171 ELSE
15172 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15173 ENDIF
15174 WTVETO=WTVETO*XFJ(KFLA)
15175C...Monte Carlo veto.
15176 IF (WTVETO.LT.PYR(0)) GOTO 200
15177C...If accept, save PT2 of this joining.
15178 IF (PT2.GT.PT2MX) THEN
15179 PT2MX=PT2
15180 JSMX=2+JS
15181 MJN1MX=MJ
15182 MJN2MX=MI
15183 WTAPJ(MJ)=0D0
15184 NJN=0
15185 ENDIF
15186C...Exit and continue evolution.
15187 GOTO 390
15188 ENDIF
15189 KFLAA=IABS(KFLA)
15190
15191C...Choose z value (still in overestimated range) and corrective weight.
15192C...Unphysical z will be rejected below when Q2 has is computed.
15193 WTZ=0D0
15194
15195C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15196C...q -> q + g or q -> q + gamma (already set which).
15197 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15198 IF (KSVCB.LT.0) THEN
15199 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15200 ELSE
15201 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15202 Z=((1-ZFAC)/(1+ZFAC))**2
15203 ENDIF
15204 WTZ=0.5D0*(1D0+Z**2)
15205C...Massive weight correction.
15206 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15207C...Valence quark weight correction (extra sqrt)
15208 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15209
15210C...q -> g + q.
15211C...NB: MQ>0 not yet implemented. Forced absent above.
15212 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15213 KFLC=KFLA
15214 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15215 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15216
15217C...g -> q + qbar.
15218 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15219 KFLC=-KFLB
15220 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15221 WTZ=Z**2+(1D0-Z)**2
15222C...Massive correction
15223 IF (MQMASS.NE.0) THEN
15224 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15225C...Extra safety margin for light sea quark creation
15226 ELSEIF (KSVCB.LT.0) THEN
15227 WTZ=WTZ/1.25D0
15228 ENDIF
15229
15230C...g -> g + g.
15231 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15232 KFLC=21
15233 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15234 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15235 WTZ=(1D0-Z*(1D0-Z))**2
15236 ENDIF
15237
15238C...Derive Q2 from pT2.
15239 Q2B=PT2/(1D0-Z)
15240 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15241
15242C...Loopback if outside allowed z range for given pT2.
15243 RM2C=PYMASS(KFLC)**2
15244 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15245 IF (PT2ADJ.LT.1D-6) GOTO 230
15246
15247C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15248C...No modification for very first emission if using ME correction
15249 MSTP67 = MSTP(67)
15250 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15251 MSTP67 = 0
15252 ENDIF
15253
15254C...For 1st branching, limit phase space by s-hat with color-partner
15255 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15256 MSIDE=1
15257 IDIP=IMI(JS,MI,1)
15258C...Use anticolor tag for antiquark, or for gluon half the time
15259 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15260 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15261C...Tag
15262 MCTAG=MCT(IDIP,MSIDE)
15263C...Default is to set up phase space using the opposite incoming parton
15264 JDIP=IMI(3-JS,MI,1)
15265 NDIP=0
15266C...Alternatively, look for final-state color partner (pick first if several)
15267 DO 260 IFS=1,NPART
15268 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15269 JDIP=IPART(IFS)
15270 NDIP=NDIP+1
15271 ENDIF
15272 260 CONTINUE
15273C...Compute mass of pair
15274 SDIP=(P(IDIP,4)+P(JDIP,4))**2-(P(IDIP,3)+P(JDIP,3))**2
15275 & -(P(IDIP,2)+P(JDIP,2))**2-(P(IDIP,1)+P(JDIP,1))**2
15276 IF (MSTP67.EQ.1) THEN
15277C...1 Option to completely kill radiation above s_dip * PARP(67)
15278 IF (4*PT2.GT.PARP(67)*SDIP) GOTO 230
15279 ELSE IF (MSTP67.EQ.2) THEN
15280C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15281C... (-> improved power showers?)
15282 IF (4*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15283 ENDIF
15284
15285C...For subsequent branchings, loopback if nonordered in angle/rapidity
15286 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15287 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15288 & GOTO 230
15289 ENDIF
15290
15291C...Select phi angle of branching at random.
15292 PHI=PARU(2)*PYR(0)
15293
15294C...Matrix-element corrections for some processes.
15295 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15296 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15297 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15298 WTZ=WTZ*WTME/WTFF
15299 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15300 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15301 WTZ=WTZ*WTME/WTGF
15302 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15303 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15304 WTZ=WTZ*WTME/WTFG
15305 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15306 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15307 WTZ=WTZ*WTME/WTGG
15308 ENDIF
15309 ENDIF
15310
15311C...Parton distributions at new pT2 but old x.
15312 MINT(30)=JS
15313C.... ALICE
15314C.... Store side in MINT(124)
15315 MINT(124) = JS
15316C....
15317 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15318C...Treat val and cmp separately
15319 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15320 IF (KSVCB.GE.1)
15321 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15322 XFBN=XFN(KFLB)
15323 IF(XFBN.LT.1D-20) THEN
15324 IF(KFLA.EQ.KFLB) THEN
15325 WTAP(KFLB)=0D0
15326 GOTO 200
15327 ELSE
15328 XFBN=1D-10
15329 XFN(KFLB)=XFBN
15330 ENDIF
15331 ENDIF
15332 DO 270 KFL=-5,5
15333 XFB(KFL)=XFN(KFL)
15334 270 CONTINUE
15335 XFB(21)=XFN(21)
15336
15337C...Parton distributions at new pT2 and new x.
15338 XA=XB/Z
15339 MINT(30)=JS
15340C.... ALICE
15341C.... Store side in MINT(124)
15342 MINT(124) = JS
15343C....
15344 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15345 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15346C...q -> q + g: only consider respective sea, val, or cmp content.
15347 IF (KSVCB.LE.0) THEN
15348 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15349 ELSE
15350 YA=XA*(1D0-YS)
15351 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15352 ENDIF
15353 ENDIF
15354 XFAN=XFA(KFLA)
15355 IF(XFAN.LT.1D-20) THEN
15356 GOTO 200
15357 ENDIF
15358
15359C...If weighting fails continue evolution.
15360 WTTOT=0D0
15361 IF (MCRQQ.EQ.0) THEN
15362 WTPDFA=1D0/WTPDF(KFLA)
15363 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15364 ELSEIF(MCRQQ.EQ.1) THEN
15365 WTPDFA=TPM/WPDF0
15366 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15367 XBEST=TPM/TPM0*XQ0
15368 ELSEIF(MCRQQ.EQ.2) THEN
15369C...Force massive quark creation.
15370 WTTOT=1D0
15371 ENDIF
15372
15373C...Loop back if trial emission fails.
15374 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15375 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15376 IF(WTTOT.LT.0D0) THEN
15377 WRITE(CHWT,'(1P,E12.4)') WTTOT
15378 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15379 ELSEIF(WTTOT.GT.WTACC) THEN
15380 WRITE(CHWT,'(1P,E12.4)') WTTOT
15381 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15382C...Too high weight: write out as error, but do not update error counter
15383 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15384 CALL PYERRM(19,
15385 & '(PYPTIS:) Weight '//CHWT//' above unity')
15386 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15387 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15388 ELSE
15389 CALL PYERRM(9,
15390 & '(PYPTIS:) Weight '//CHWT//' above unity')
15391 ENDIF
15392C...Useful for debugging but commented out for distribution:
15393C print*, 'JS, MI',JS, MI
15394C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15395C print*, 'A -> B C',KFLA, KFLB, KFLC
15396C XFAO=XFBO/WTPDFA
15397C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15398 ENDIF
15399
15400C...Save acceptable branching.
15401 IF(PT2.GT.PT2MX) THEN
15402 MIMX=MINT(36)
15403 JSMX=JS
15404 PT2MX=PT2
15405 KFLAMX=KFLA
15406 KFLCMX=KFLC
15407 RM2CMX=RM2C
15408 Q2BMX=Q2B
15409 ZMX=Z
15410 PT2AMX=PT2ADJ
15411 PHIMX=PHI
15412 ENDIF
15413
15414C----------------------------------------------------------------------
15415C...MODE= 1: Accept stored shower branching. Update event record etc.
15416 ELSEIF (MODE.EQ.1) THEN
15417 MI=MIMX
15418 JS=JSMX
15419 SHAT=SHTNOW(MI)
15420 SIDE=3D0-2D0*JS
15421C...Shift down rest of event record to make room for insertion.
15422 IT=IMISEP(MI)+1
15423 IM=IT+1
15424 IS=IMI(JS,MI,1)
15425 DO 290 I=N,IT,-1
15426 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15427 KT1=K(I,4)/MSTU(5)**2
15428 KT2=K(I,5)/MSTU(5)**2
15429 ID1=MOD(K(I,4),MSTU(5))
15430 ID2=MOD(K(I,5),MSTU(5))
15431 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15432 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15433 IF (ID1.GE.IT) ID1=ID1+2
15434 IF (ID2.GE.IT) ID2=ID2+2
15435 IF (IM1.GE.IT) IM1=IM1+2
15436 IF (IM2.GE.IT) IM2=IM2+2
15437 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15438 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15439 DO 280 IX=1,5
15440 K(I+2,IX)=K(I,IX)
15441 P(I+2,IX)=P(I,IX)
15442 V(I+2,IX)=V(I,IX)
15443 280 CONTINUE
15444 MCT(I+2,1)=MCT(I,1)
15445 MCT(I+2,2)=MCT(I,2)
15446 290 CONTINUE
15447 N=N+2
15448C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15449 DO 300 JI=1,MINT(31)
15450 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15451 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15452 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15453 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15454 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15455C...Also update companion pointers to the present mother.
15456 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15457 300 CONTINUE
15458 DO 310 IFS=1,NPART
15459 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15460 310 CONTINUE
15461C...Zero entries dedicated for new timelike and mother partons.
15462 DO 330 I=IT,IT+1
15463 DO 320 J=1,5
15464 K(I,J)=0
15465 P(I,J)=0D0
15466 V(I,J)=0D0
15467 320 CONTINUE
15468 MCT(I,1)=0
15469 MCT(I,2)=0
15470 330 CONTINUE
15471
15472C...Define timelike and new mother partons. History.
15473 K(IT,1)=3
15474 K(IT,2)=KFLCMX
15475 K(IM,1)=14
15476 K(IM,2)=KFLAMX
15477 K(IS,3)=IM
15478 K(IT,3)=IM
15479C...Set mother origin = side.
15480 K(IM,3)=MINT(83)+JS+2
15481 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15482
15483C...Define colour flow of branching.
15484 IM1=IM
15485 IM2=IM
15486C...q -> q + gamma.
15487 IF(K(IT,2).EQ.22) THEN
15488 K(IT,1)=1
15489 ID1=IS
15490 ID2=IS
15491C...q -> q + g.
15492 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15493 ID1=IT
15494 ID2=IS
15495C...q -> g + q.
15496 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15497 ID1=IS
15498 ID2=IT
15499C...qbar -> qbar + g.
15500 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15501 ID1=IS
15502 ID2=IT
15503C...qbar -> g + qbar.
15504 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15505 ID1=IT
15506 ID2=IS
15507C...g -> g + g; g -> q + qbar..
15508 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15509 ID1=IS
15510 ID2=IT
15511 ELSE
15512 ID1=IT
15513 ID2=IS
15514 ENDIF
15515 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15516 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15517 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15518 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15519 IF(ID1.NE.ID2) THEN
15520 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15521 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15522 ENDIF
15523 IF(K(IT,1).EQ.1) THEN
15524 K(IT,4)=0
15525 K(IT,5)=0
15526 ENDIF
15527C...Update IMI and colour tag arrays.
15528 IMI(JS,MI,1)=IM
15529 DO 340 MC=1,2
15530 MCT(IT,MC)=0
15531 MCT(IM,MC)=0
15532 340 CONTINUE
15533 DO 350 JCS=4,5
15534 KCS=JCS
15535C...If mother flag not yet set for spacelike parton, trace it.
15536 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15537 IF(MINT(51).NE.0) RETURN
15538 350 CONTINUE
15539 DO 360 JCS=4,5
15540 KCS=JCS
15541C...If mother flag not yet set for timelike parton, trace it.
15542 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15543 IF(MINT(51).NE.0) RETURN
15544 360 CONTINUE
15545
15546C...Boost recoiling parton to compensate for Q2 scale.
15547 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15548 & (1D0+(1D0+Q2BMX/SHAT)**2)
15549 IR=IMI(3-JS,MI,1)
15550 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15551
15552C...Define system to be rotated and boosted
15553C...(not including the 2 just added partons)
15554C...(but including the docu lines for first interaction)
15555 IMIN=IMISEP(MI-1)+1
15556 IF (MI.EQ.1) IMIN=MINT(83)+5
15557 IMAX=IMISEP(MI)-2
15558
15559C...Rotate back system in phi to compensate for subsequent rotation.
15560 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15561
15562C...Define kinematics of new partons in old frame.
15563 IMAX=IMISEP(MI)
15564 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15565 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15566 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15567 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15568 P(IT,1)=P(IM,1)
15569 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15570 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15571 P(IT,5)=SQRT(RM2CMX)
15572
15573C...Update internal line, now spacelike
15574 P(IS,1)=P(IM,1)-P(IT,1)
15575 P(IS,2)=P(IM,2)-P(IT,2)
15576 P(IS,3)=P(IM,3)-P(IT,3)
15577 P(IS,4)=P(IM,4)-P(IT,4)
15578 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15579C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15580 IF (P(IS,5).LT.0D0) THEN
15581 P(IS,5)=-SQRT(ABS(P(IS,5)))
15582 ELSE
15583 P(IS,5)=SQRT(P(IS,5))
15584 ENDIF
15585
15586C...Boost entire system and rotate to new frame.
15587C...(including docu lines)
15588 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15589 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15590 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15591 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15592 MINT(51)=1
15593 IFAIL=-1
15594 RETURN
15595 ENDIF
15596 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15597 I1=IMI(1,MI,1)
15598 THETA=PYANGL(P(I1,3),P(I1,1))
15599 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15600
15601C...Global statistics.
15602 MINT(352)=MINT(352)+1
15603 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15604 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15605
15606C...Add parton with relevant pT scale for timelike shower.
15607 IF (K(IT,2).NE.22) THEN
15608 NPART=NPART+1
15609 IPART(NPART)=IT
15610 PTPART(NPART)=SQRT(PT2AMX)
15611 ENDIF
15612
15613C...Update saved variables.
15614 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15615 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15616 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15617 PT2SAV(JSMX,MIMX)=PT2MX
15618 ZSAV(JS,MIMX)=ZMX
15619
15620 KSA=IABS(K(IS,2))
15621 KMA=IABS(K(IM,2))
15622 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15623C...Gluon reconstructs to quark.
15624C...Decide whether newly created quark is valence or sea:
15625 MINT(30)=JS
15626 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15627 IF(MINT(51).NE.0) RETURN
15628 ENDIF
15629 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15630C...Quark reconstructs to gluon.
15631C...Now some guy may have lost his companion. Check.
15632 ICMP=IMI(JS,MI,2)
15633 IF (ICMP.GT.0) THEN
15634 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15635 & //' away. Cannot handle that yet. Giving up.')
15636 MINT(51)=1
15637 RETURN
15638 ELSEIF(ICMP.LT.0) THEN
15639C...A sea quark with companion still in BR was reconstructed to a gluon.
15640C...Companion should now be removed from the beam remnant.
15641C...(Momentum integral is automatically updated in next call to PYPDFU.)
15642 ICMP=-ICMP
15643 IFL=-K(IS,2)
15644 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15645 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15646 DO 370 JI=1,MINT(31)
15647 KMI=-IMI(JS,JI,2)
15648 JFL=-K(IMI(JS,JI,1),2)
15649 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15650 & ,2)+1
15651 370 CONTINUE
15652 380 CONTINUE
15653 NVC(JS,IFL)=NVC(JS,IFL)-1
15654 ENDIF
15655C...Set gluon IMI(JS,MI,2) = 0.
15656 IMI(JS,MI,2)=0
15657 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15658C...Quark reconstructing to quark. If sea with companion still in BR
15659C...then update associated x value.
15660C...(Momentum integral is automatically updated in next call to PYPDFU.)
15661 IF (IMI(JS,MI,2).LT.0) THEN
15662 ICMP=-IMI(JS,MI,2)
15663 IFL=-K(IS,2)
15664 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15665 ENDIF
15666 ENDIF
15667
15668 ENDIF
15669
15670C...If reached this point, normal exit.
15671 390 IFAIL=0
15672
15673 RETURN
15674 END
15675
15676C*********************************************************************
15677
15678C...PYMEMX
15679C...Generates maximum ME weight in some initial-state showers.
15680C...Inparameter MECOR: kind of hard scattering process
15681C...Outparameter WTFF: maximum weight for fermion -> fermion
15682C... WTGF: maximum weight for gluon/photon -> fermion
15683C... WTFG: maximum weight for fermion -> gluon/photon
15684C... WTGG: maximum weight for gluon -> gluon
15685
15686 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15687
15688C...Double precision and integer declarations.
15689 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15690 IMPLICIT INTEGER(I-N)
15691 INTEGER PYK,PYCHGE,PYCOMP
15692C...Commonblocks.
15693 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15694 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15695 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15696 COMMON/PYINT1/MINT(400),VINT(400)
15697 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15698 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15699
15700C...Default maximum weight.
15701 WTFF=1D0
15702 WTGF=1D0
15703 WTFG=1D0
15704 WTGG=1D0
15705
15706C...Select maximum weight by process.
15707 IF(MECOR.EQ.1) THEN
15708 WTFF=1D0
15709 WTGF=3D0
15710 ELSEIF(MECOR.EQ.2) THEN
15711 WTFG=1D0
15712 WTGG=1D0
15713 ENDIF
15714
15715 RETURN
15716 END
15717
15718C*********************************************************************
15719
15720C...PYMEWT
15721C...Calculates actual ME weight in some initial-state showers.
15722C...Inparameter MECOR: kind of hard scattering process
15723C... IFLCB: flavour combination of branching,
15724C... 1 for fermion -> fermion,
15725C... 2 for gluon/photon -> fermion
15726C... 3 for fermion -> gluon/photon,
15727C... 4 for gluon -> gluon
15728C... Q2: Q2 value of shower branching
15729C... Z: Z value of branching
15730C...In+outparameter PHIBR: azimuthal angle of branching
15731C...Outparameter WTME: actual ME weight
15732
15733 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
15734
15735C...Double precision and integer declarations.
15736 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15737 IMPLICIT INTEGER(I-N)
15738 INTEGER PYK,PYCHGE,PYCOMP
15739C...Commonblocks.
15740 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15742 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15743 COMMON/PYINT1/MINT(400),VINT(400)
15744 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15745 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15746
15747C...Default output.
15748 WTME=1D0
15749
15750C...Define kinematics of shower branching in Mandelstam variables.
15751 SQM=VINT(44)
15752 SH=SQM/Z
15753 TH=-Q2
15754 UH=Q2-SQM*(1D0-Z)/Z
15755
15756C...Matrix-element corrections for f + fbar -> s-channel vector boson.
15757 IF(MECOR.EQ.1) THEN
15758 IF(IFLCB.EQ.1) THEN
15759 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
15760 ELSEIF(IFLCB.EQ.2) THEN
15761 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
15762 ENDIF
15763
15764C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
15765 ELSEIF(MECOR.EQ.2) THEN
15766 IF(IFLCB.EQ.3) THEN
15767 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
15768 ELSEIF(IFLCB.EQ.4) THEN
15769 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
15770 ENDIF
15771
15772C...Matrix-element corrections for q + qbar -> Higgs (h0)
15773 ELSEIF(MECOR.EQ.3) THEN
15774 IF(IFLCB.EQ.2) THEN
15775 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
15776 1 (SH**2+2D0*SQM*(SQM-SH))
15777 ENDIF
15778 ENDIF
15779
15780 RETURN
15781 END
15782
15783C*********************************************************************
15784
15785C...PYPTMI
15786C...Handles the generation of additional interactions in the new
15787C...multiple interactions framework.
15788C...MODE=-1 : Initalize MI from scratch.
15789C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
15790C... Sudakov for PT2, abort if below PT2CUT.
15791C...MODE= 1 : Accept interaction at PT2NOW and store variables.
15792C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
15793C...PT2NOW : Starting (max) PT2 scale for evolution.
15794C...PT2CUT : Lower limit for evolution.
15795C...PT2 : Result of evolution. Generated PT2 for trial interaction.
15796C...IFAIL : Status return code.
15797C... = 0: All is well.
15798C... < 0: Phase space exhausted, generation to be terminated.
15799C... > 0: Additional interaction vetoed, but continue evolution.
15800
15801 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
15802C...Double precision and integer declarations.
15803 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15804 IMPLICIT INTEGER(I-N)
15805 INTEGER PYK,PYCHGE,PYCOMP
15806C...Parameter statement for maximum size of showers.
15807 PARAMETER (MAXNUR=1000)
15808C...Commonblocks.
15809 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
15810 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15812 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
15813 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
15814 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15815 COMMON/PYINT1/MINT(400),VINT(400)
15816 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15817 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
15818 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
15819 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
15820 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
15821 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
15822 & XMI(2,240),PT2MI(240),IMISEP(0:240)
15823 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
15824 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
15825 COMMON/PYCTAG/NCT,MCT(4000,2)
15826C...Local arrays and saved variables.
15827 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
15828
15829 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
15830 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
15831 & /PYISMX/,/PYCTAG/
15832 SAVE XT2FAC,SIGS
15833
15834 IFAIL=0
15835C...Set MI subprocess = QCD 2 -> 2.
15836 ISUB=96
15837
15838C----------------------------------------------------------------------
15839C...MODE=-1: Initialize from scratch
15840 IF (MODE.EQ.-1) THEN
15841C...Initialize PT2 array.
15842 PT2MI(1)=VINT(54)
15843C...Initialize list of incoming beams and partons from two sides.
15844 DO 110 JS=1,2
15845 DO 100 MI=1,240
15846 IMI(JS,MI,1)=0
15847 IMI(JS,MI,2)=0
15848 100 CONTINUE
15849 NMI(JS)=1
15850 IMI(JS,1,1)=MINT(84)+JS
15851 IMI(JS,1,2)=0
15852 XMI(JS,1)=VINT(40+JS)
15853C...Rescale x values to fractions of photon energy.
15854 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
15855C...Hard reset: hard interaction initiators motherless by definition.
15856 K(MINT(84)+JS,3)=2+JS
15857 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
15858 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
15859 110 CONTINUE
15860 IMISEP(0)=MINT(84)
15861 IMISEP(1)=N
15862 IF (MOD(MSTP(81),10).GE.1) THEN
15863 IF(MSTP(82).LE.1) THEN
15864 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
15865 & ,5))
15866 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
15867 & VINT(317)/(VINT(318)*VINT(320))
15868 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
15869 ELSE
15870 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
15871 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
15872 ENDIF
15873 ENDIF
15874C...Zero entries relating to scatterings beyond the first.
15875 DO 120 MI=2,240
15876 IMI(1,MI,1)=0
15877 IMI(2,MI,1)=0
15878 IMI(1,MI,2)=0
15879 IMI(2,MI,2)=0
15880 IMISEP(MI)=IMISEP(1)
15881 PT2MI(MI)=0D0
15882 XMI(1,MI)=0D0
15883 XMI(2,MI)=0D0
15884 120 CONTINUE
15885C...Initialize factors for PDF reshaping.
15886 DO 140 JS=1,2
15887 KFBEAM(JS)=MINT(10+JS)
15888 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
15889 KFABM=IABS(KFBEAM(JS))
15890 KFSBM=ISIGN(1,KFBEAM(JS))
15891
15892C...Zero flavour content of incoming beam particle.
15893 KFIVAL(JS,1)=0
15894 KFIVAL(JS,2)=0
15895 KFIVAL(JS,3)=0
15896C... Flavour content of baryon.
15897 IF(KFABM.GT.1000) THEN
15898 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
15899 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
15900 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
15901C... Flavour content of pi+-, K+-.
15902 ELSEIF(KFABM.EQ.211) THEN
15903 KFIVAL(JS,1)=KFSBM*2
15904 KFIVAL(JS,2)=-KFSBM
15905 ELSEIF(KFABM.EQ.321) THEN
15906 KFIVAL(JS,1)=-KFSBM*3
15907 KFIVAL(JS,2)=KFSBM*2
15908C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
15909 ENDIF
15910
15911C...Zero initial valence and companion content.
15912 DO 130 IFL=-6,6
15913 NVC(JS,IFL)=0
15914 130 CONTINUE
15915 140 CONTINUE
15916C...Set up colour line tags starting from hard interaction initiators.
15917 NCT=0
15918C...Reset colour tag array and colour processing flags.
15919 DO 150 I=IMISEP(0)+1,N
15920 MCT(I,1)=0
15921 MCT(I,2)=0
15922 K(I,4)=MOD(K(I,4),MSTU(5)**2)
15923 K(I,5)=MOD(K(I,5),MSTU(5)**2)
15924 150 CONTINUE
15925C... Consider each side in turn.
15926 DO 170 JS=1,2
15927 I1=IMI(JS,1,1)
15928 I2=IMI(3-JS,1,1)
15929 DO 160 JCS=4,5
15930 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
15931 & GOTO 160
15932 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
15933 KCS=JCS
15934 CALL PYCTTR(I1,KCS,I2)
15935 IF(MINT(51).NE.0) RETURN
15936 160 CONTINUE
15937 170 CONTINUE
15938
15939C...Range checking for companion quark pdf large-x param.
15940 IF (MSTP(87).LT.0) THEN
15941 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15942 & ' MSTP(87)=0')
15943 MSTP(87)=0
15944 ELSEIF (MSTP(87).GT.4) THEN
15945 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
15946 & ' MSTP(87)=4')
15947 MSTP(87)=4
15948 ENDIF
15949
15950C----------------------------------------------------------------------
15951C...MODE=0: Generate trial interaction. Return codes:
15952C...IFAIL < 0: Phase space exhausted, generation to be terminated.
15953C...IFAIL = 0: Additional interaction generated at PT2.
15954C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
15955 ELSEIF (MODE.EQ.0) THEN
15956C...Abolute MI max scale = VINT(62)
15957 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
15958 180 IF(MSTP(82).LE.1) THEN
15959 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
15960 IF(XT2.LT.VINT(149)) IFAIL=-2
15961 ELSE
15962 IF(XT2.LE.0.01001D0*VINT(149)) THEN
15963 IFAIL=-3
15964 ELSE
15965 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
15966 & LOG(PYR(0)))-VINT(149)
15967 ENDIF
15968 ENDIF
15969C...Also exit if below lower limit or if higher trial branching
15970C...already found.
15971 PT2=0.25D0*VINT(2)*XT2
15972 IF (PT2.LE.PT2CUT) IFAIL=-4
15973 IF (PT2.LE.PT2MX) IFAIL=-5
15974 IF (IFAIL.NE.0) THEN
15975 PT2=0D0
15976 RETURN
15977 ENDIF
15978 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
15979 VINT(25)=4D0*PT2/VINT(2)
15980 XT2=VINT(25)
15981
15982C...Choose tau and y*. Calculate cos(theta-hat).
15983 IF(PYR(0).LE.COEF(ISUB,1)) THEN
15984 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
15985 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
15986 ELSE
15987 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
15988 ENDIF
15989 VINT(21)=TAU
15990C...New: require shat > 1.
15991 IF(TAU*VINT(2).LT.1D0) GOTO 180
15992 CALL PYKLIM(2)
15993 RYST=PYR(0)
15994 MYST=1
15995 IF(RYST.GT.COEF(ISUB,8)) MYST=2
15996 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
15997 CALL PYKMAP(2,MYST,PYR(0))
15998 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
15999
16000C...Check that x not used up. Accept or reject kinematical variables.
16001 X1M=SQRT(TAU)*EXP(VINT(22))
16002 X2M=SQRT(TAU)*EXP(-VINT(22))
16003 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16004 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16005 CALL PYSIGH(NCHN,SIGS)
16006 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16007 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16008 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16009
16010C...Save if highest PT so far.
16011 IF (PT2.GT.PT2MX) THEN
16012 JSMX=0
16013 MIMX=MINT(31)+1
16014 PT2MX=PT2
16015 ENDIF
16016
16017C----------------------------------------------------------------------
16018C...MODE=1: Generate and save accepted scattering.
16019 ELSEIF (MODE.EQ.1) THEN
16020 PT2=PT2NOW
16021C...Reset K, P, V, and MCT vectors.
16022 DO 200 I=N+1,N+4
16023 DO 190 J=1,5
16024 K(I,J)=0
16025 P(I,J)=0D0
16026 V(I,J)=0D0
16027 190 CONTINUE
16028 MCT(I,1)=0
16029 MCT(I,2)=0
16030 200 CONTINUE
16031
16032 NTRY=0
16033C...Choose flavour of reacting partons (and subprocess).
16034 210 NTRY=NTRY+1
16035 IF (NTRY.GT.50) THEN
16036 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16037 & //'interaction. Giving up!')
16038 MINT(51)=1
16039 RETURN
16040 ENDIF
16041 RSIGS=SIGS*PYR(0)
16042 DO 220 ICHN=1,NCHN
16043 KFL1=ISIG(ICHN,1)
16044 KFL2=ISIG(ICHN,2)
16045 ICONMI=ISIG(ICHN,3)
16046 RSIGS=RSIGS-SIGH(ICHN)
16047 IF(RSIGS.LE.0D0) GOTO 230
16048 220 CONTINUE
16049
16050C...Reassign to appropriate process codes.
16051 230 ISUBMI=ICONMI/10
16052 ICONMI=MOD(ICONMI,10)
16053
16054C...Choose new quark flavour for annihilation graphs
16055 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16056 SH=VINT(21)*VINT(2)
16057 CALL PYWIDT(21,SH,WDTP,WDTE)
16058 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16059 DO 250 I=1,MDCY(21,3)
16060 KFLF=KFDP(I+MDCY(21,2)-1,1)
16061 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16062 IF(RKFL.LE.0D0) GOTO 260
16063 250 CONTINUE
16064 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16065 IF(KFLF.GE.4) GOTO 240
16066 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16067 KFLF=4
16068 ICONMI=ICONMI-2
16069 ELSEIF(ISUBMI.EQ.53) THEN
16070 KFLF=5
16071 ICONMI=ICONMI-4
16072 ENDIF
16073 ENDIF
16074
16075C...Final state flavours and colour flow: default values
16076 JS=1
16077 KFL3=KFL1
16078 KFL4=KFL2
16079 KCC=20
16080 KCS=ISIGN(1,KFL1)
16081
16082 IF(ISUBMI.EQ.11) THEN
16083C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16084 KCC=ICONMI
16085 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16086
16087 ELSEIF(ISUBMI.EQ.12) THEN
16088C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16089 KFL3=ISIGN(KFLF,KFL1)
16090 KFL4=-KFL3
16091 KCC=4
16092
16093 ELSEIF(ISUBMI.EQ.13) THEN
16094C...f + fbar -> g + g; th arbitrary
16095 KFL3=21
16096 KFL4=21
16097 KCC=ICONMI+4
16098
16099 ELSEIF(ISUBMI.EQ.28) THEN
16100C...f + g -> f + g; th = (p(f)-p(f))**2
16101 IF(KFL1.EQ.21) JS=2
16102 KCC=ICONMI+6
16103 IF(KFL1.EQ.21) KCC=KCC+2
16104 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16105 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16106
16107 ELSEIF(ISUBMI.EQ.53) THEN
16108C...g + g -> f + fbar; th arbitrary
16109 KCS=(-1)**INT(1.5D0+PYR(0))
16110 KFL3=ISIGN(KFLF,KCS)
16111 KFL4=-KFL3
16112 KCC=ICONMI+10
16113
16114 ELSEIF(ISUBMI.EQ.68) THEN
16115C...g + g -> g + g; th arbitrary
16116 KCC=ICONMI+12
16117 KCS=(-1)**INT(1.5D0+PYR(0))
16118 ENDIF
16119
16120C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16121 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16122 & .OR.IABS(KFL4).EQ.5) THEN
16123 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16124 IF (PT2.LE.1.05*RMMAX2) THEN
16125 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16126 & //' too close to threshold (2nd try).')
16127 GOTO 210
16128 ENDIF
16129 ENDIF
16130
16131C...Store flavours of scattering.
16132 MINT(13)=KFL1
16133 MINT(14)=KFL2
16134 MINT(15)=KFL1
16135 MINT(16)=KFL2
16136 MINT(21)=KFL3
16137 MINT(22)=KFL4
16138
16139C...Set flavours and mothers of scattering partons.
16140 K(N+1,1)=14
16141 K(N+2,1)=14
16142 K(N+3,1)=3
16143 K(N+4,1)=3
16144 K(N+1,2)=KFL1
16145 K(N+2,2)=KFL2
16146 K(N+3,2)=KFL3
16147 K(N+4,2)=KFL4
16148 K(N+1,3)=MINT(83)+1
16149 K(N+2,3)=MINT(83)+2
16150 K(N+3,3)=N+1
16151 K(N+4,3)=N+2
16152
16153C...Store colour connection indices.
16154 DO 270 J=1,2
16155 JC=J
16156 IF(KCS.EQ.-1) JC=3-J
16157 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16158 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16159 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16160 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16161 270 CONTINUE
16162
16163C...Store incoming and outgoing partons in their CM-frame.
16164 SHR=SQRT(VINT(21))*VINT(1)
16165 P(N+1,3)=0.5D0*SHR
16166 P(N+1,4)=0.5D0*SHR
16167 P(N+2,3)=-0.5D0*SHR
16168 P(N+2,4)=0.5D0*SHR
16169 P(N+3,5)=PYMASS(K(N+3,2))
16170 P(N+4,5)=PYMASS(K(N+4,2))
16171 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16172 IFAIL=1
16173 RETURN
16174 ENDIF
16175 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16176 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16177 P(N+4,4)=SHR-P(N+3,4)
16178 P(N+4,3)=-P(N+3,3)
16179
16180C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16181 PHI=PARU(2)*PYR(0)
16182 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16183
16184C...Global statistics.
16185 MINT(351)=MINT(351)+1
16186 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16187 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16188
16189C...Keep track of loose colour ends and information on scattering.
16190 MINT(31)=MINT(31)+1
16191 MINT(36)=MINT(31)
16192 PT2MI(MINT(36))=PT2
16193 IMISEP(MINT(31))=N+4
16194 DO 280 JS=1,2
16195 IMI(JS,MINT(31),1)=N+JS
16196 IMI(JS,MINT(31),2)=0
16197 XMI(JS,MINT(31))=VINT(40+JS)
16198 NMI(JS)=NMI(JS)+1
16199C...Update cumulative counters
16200 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16201 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16202 280 CONTINUE
16203
16204C...Add to list of final state partons
16205 IPART(NPART+1)=N+3
16206 IPART(NPART+2)=N+4
16207 PTPART(NPART+1)=SQRT(PT2)
16208 PTPART(NPART+2)=SQRT(PT2)
16209 NPART=NPART+2
16210
16211C...Initialize ISR
16212 NISGEN(1,MINT(31))=0
16213 NISGEN(2,MINT(31))=0
16214
16215C...Update ER
16216 N=N+4
16217 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16218 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16219 MINT(51)=1
16220 RETURN
16221 ENDIF
16222
16223C...Finally, assign colour tags to new partons
16224 DO 300 JS=1,2
16225 I1=IMI(JS,MINT(31),1)
16226 I2=IMI(3-JS,MINT(31),1)
16227 DO 290 JCS=4,5
16228 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16229 & GOTO 290
16230 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16231 KCS=JCS
16232 CALL PYCTTR(I1,KCS,I2)
16233 IF(MINT(51).NE.0) RETURN
16234 290 CONTINUE
16235 300 CONTINUE
16236
16237C----------------------------------------------------------------------
16238C...MODE=2: Decide whether quarks in last scattering were valence,
16239C...companion, or sea.
16240 ELSEIF (MODE.EQ.2) THEN
16241 JS=MINT(30)
16242 MI=MINT(36)
16243 PT2=PT2NOW
16244 KFSBM=ISIGN(1,MINT(10+JS))
16245 IFL=K(IMI(JS,MI,1),2)
16246 IMI(JS,MI,2)=0
16247 IF (IABS(IFL).GE.6) THEN
16248 IF (IABS(IFL).EQ.6) THEN
16249 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16250 ENDIF
16251 RETURN
16252 ENDIF
16253C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16254C...(Do not include the parton itself in the X rescaling.)
16255 X=XMI(JS,MI)
16256 XRSC=X/(VINT(142+JS)+X)
16257C...Note: XPSVC = x*pdf.
16258 MINT(30)=JS
16259C.... ALICE
16260C.... Store side in MINT(124)
16261 MINT(124) = JS
16262C....
16263 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16264 SEA=XPSVC(IFL,-1)
16265 VAL=XPSVC(IFL,0)
16266C...Ensure that pdfs are positive definite
16267 IF (SEA.LT.0D0) THEN
16268 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16269 SEA=MAX(0D0,SEA)
16270 ELSEIF (VAL.LT.0D0) THEN
16271 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16272 VAL=MAX(0D0,VAL)
16273 ENDIF
16274 CMP=0D0
16275 DO 310 IVC=1,NVC(JS,IFL)
16276 CMP=CMP+XPSVC(IFL,IVC)
16277 310 CONTINUE
16278
16279 NTRY=0
16280C...Decide (Extra factor x cancels in the dvision).
16281 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16282 IVNOW=1
16283 NTRY=NTRY+1
16284 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16285C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16286 IVNOW=0
16287 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16288 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16289 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16290 IF(KFIVAL(JS,1).EQ.0) THEN
16291 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16292 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16293 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16294 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16295 ELSE
16296C...Count down valence remaining. Do not count current scattering.
16297 DO 340 I1=1,NMI(JS)
16298 IF (I1.EQ.MINT(36)) GOTO 340
16299 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16300 & IVNOW=IVNOW-1
16301 340 CONTINUE
16302 ENDIF
16303 IF(IVNOW.EQ.0) GOTO 330
16304C...Mark valence.
16305 IMI(JS,MI,2)=0
16306C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16307 IF(KFIVAL(JS,1).EQ.0) THEN
16308 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16309 KFIVAL(JS,1)=IFL
16310 KFIVAL(JS,2)=-IFL
16311 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16312 KFIVAL(JS,1)=IFL
16313 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16314 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16315 ENDIF
16316 ENDIF
16317
16318 ELSEIF (RVCS.LE.VAL+SEA) THEN
16319C...If sea, add opposite sign companion parton. Store X and I.
16320 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16321 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16322C...Set pointer to companion
16323 IMI(JS,MI,2)=-NVC(JS,-IFL)
16324
16325 ELSE
16326C...If companion, check whether we've got any in the books
16327 IF (NVC(JS,IFL).EQ.0) THEN
16328 CMP=0D0
16329C...Only report error first time for this event
16330 IF (NTRY.EQ.1)
16331 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16332C...Try a few times
16333 IF (NTRY.LE.10) THEN
16334 GOTO 320
16335C... But if it stil fails, abort this event
16336 ELSE
16337 MINT(51)=1
16338 RETURN
16339 ENDIF
16340 ENDIF
16341C...If several possibilities, decide which one
16342 CMPSUM=VAL+SEA
16343 ISEL=0
16344 350 ISEL=ISEL+1
16345 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16346 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16347C...Find original sea (anti-)quark. Do not consider current scattering.
16348 IASSOC=0
16349 DO 360 I1=1,NMI(JS)
16350 IF (I1.EQ.MINT(36)) GOTO 360
16351 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16352 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16353 IMI(JS,MI,2)=IMI(JS,I1,1)
16354 IMI(JS,I1,2)=IMI(JS,MI,1)
16355 ENDIF
16356 360 CONTINUE
16357C...Mark companion "out-kicked".
16358 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16359 ENDIF
16360
16361 ENDIF
16362 RETURN
16363 END
16364
16365C*********************************************************************
16366
16367C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16368C...Giving the x*f pdf of a companion quark, with its partner at XS,
16369C...using an approximate gluon density like (1-X)^NPOW/X. The value
16370C...corresponds to an unrescaled range between 0 and 1-X.
16371
16372 FUNCTION PYFCMP(XC,XS,NPOW)
16373 IMPLICIT NONE
16374 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16375 INTEGER NPOW
16376
16377 PYFCMP=0D0
16378C...Parent gluon momentum fraction
16379 Y=XC+XS
16380 IF (Y.GE.1D0) RETURN
16381C...Common factor (includes factor XC, since PYFCMP=x*f)
16382 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16383C...Store normalized companion x*f distribution.
16384 IF (NPOW.LE.0) THEN
16385 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16386 ELSEIF (NPOW.EQ.1) THEN
16387 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16388 ELSEIF (NPOW.EQ.2) THEN
16389 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16390 & +3D0*XS*(1D0+XS)*LOG(XS)))
16391 ELSEIF (NPOW.EQ.3) THEN
16392 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16393 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16394 ELSEIF (NPOW.GE.4) THEN
16395 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16396 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16397 ENDIF
16398 RETURN
16399 END
16400
16401C*********************************************************************
16402
16403C...PYPCMP: Auxiliary to PYPDFU.
16404C...Giving the momentum integral of a companion quark, with its
16405C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16406C...The value corresponds to an unrescaled range between 0 and 1-XS.
16407
16408 FUNCTION PYPCMP(XS,NPOW)
16409 IMPLICIT NONE
16410 DOUBLE PRECISION XS, PYPCMP
16411 INTEGER NPOW
16412 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16413 PYPCMP=0D0
16414 ELSEIF (NPOW.LE.0) THEN
16415 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16416 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16417 ELSEIF (NPOW.EQ.1) THEN
16418 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16419 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16420 ELSEIF (NPOW.EQ.2) THEN
16421 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16422 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16423 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16424 & -3D0*XS*LOG(XS)*(1+XS)))
16425 ELSEIF (NPOW.EQ.3) THEN
16426 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16427 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16428 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16429 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16430 ELSE
16431 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16432 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16433 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16434 & -6D0*XS*LOG(XS)*(1D0+XS)))
16435 ENDIF
16436 RETURN
16437 END
16438
16439C*********************************************************************
16440
16441C...PYUPRE
16442C...Rearranges contents of the HEPEUP commonblock so that
16443C...mothers precede daughters and daughters of a decay are
16444C...listed consecutively.
16445
16446 SUBROUTINE PYUPRE
16447
16448C...Double precision and integer declarations.
16449 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16450 IMPLICIT INTEGER(I-N)
16451
16452C...User process event common block.
16453 INTEGER MAXNUP
16454 PARAMETER (MAXNUP=500)
16455 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16456 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16457 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16458 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16459 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16460 SAVE /HEPEUP/
16461
16462C...Local arrays.
16463 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16464 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16465 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16466
16467C...Check whether a rearrangement is required.
16468 NEED=0
16469 DO 100 IUP=1,NUP
16470 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16471 100 CONTINUE
16472 DO 110 IUP=2,NUP
16473 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16474 110 CONTINUE
16475
16476 IF(NEED.NE.0) THEN
16477C...Find the new order that particles should have.
16478 NEWPOS(0)=0
16479 NNEW=0
16480 INEW=-1
16481 120 INEW=INEW+1
16482 DO 130 IUP=1,NUP
16483 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16484 NNEW=NNEW+1
16485 NEWPOS(NNEW)=IUP
16486 ENDIF
16487 130 CONTINUE
16488 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16489 IF(NNEW.NE.NUP) THEN
16490 CALL PYERRM(2,
16491 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16492 RETURN
16493 ENDIF
16494
16495C...Copy old info into temporary storage.
16496 DO 150 I=1,NUP
16497 IDUPT(I)=IDUP(I)
16498 ISTUPT(I)=ISTUP(I)
16499 MOTUPT(1,I)=MOTHUP(1,I)
16500 MOTUPT(2,I)=MOTHUP(2,I)
16501 ICOUPT(1,I)=ICOLUP(1,I)
16502 ICOUPT(2,I)=ICOLUP(2,I)
16503 DO 140 J=1,5
16504 PUPT(J,I)=PUP(J,I)
16505 140 CONTINUE
16506 VTIUPT(I)=VTIMUP(I)
16507 SPIUPT(I)=SPINUP(I)
16508 150 CONTINUE
16509
16510C...Copy info back into HEPEUP in right order.
16511 DO 180 I=1,NUP
16512 IOLD=NEWPOS(I)
16513 IDUP(I)=IDUPT(IOLD)
16514 ISTUP(I)=ISTUPT(IOLD)
16515 MOTHUP(1,I)=0
16516 MOTHUP(2,I)=0
16517 DO 160 IMOT=1,I-1
16518 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16519 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16520 160 CONTINUE
16521 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16522 MOTHSW=MOTHUP(1,I)
16523 MOTHUP(1,I)=MOTHUP(2,I)
16524 MOTHUP(2,I)=MOTHSW
16525 ENDIF
16526 ICOLUP(1,I)=ICOUPT(1,IOLD)
16527 ICOLUP(2,I)=ICOUPT(2,IOLD)
16528 DO 170 J=1,5
16529 PUP(J,I)=PUPT(J,IOLD)
16530 170 CONTINUE
16531 VTIMUP(I)=VTIUPT(IOLD)
16532 SPINUP(I)=SPIUPT(IOLD)
16533 180 CONTINUE
16534 ENDIF
16535
16536c...If incoming particles are massive recalculate to put them massless.
16537 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16538 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16539 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16540 PUP(4,1)=0.5D0*PPLUS
16541 PUP(3,1)=PUP(4,1)
16542 PUP(5,1)=0D0
16543 PUP(4,2)=0.5D0*PMINUS
16544 PUP(3,2)=-PUP(4,2)
16545 PUP(5,2)=0D0
16546 ENDIF
16547
16548 RETURN
16549 END
16550
16551C*********************************************************************
16552
16553C...PYADSH
16554C...Administers the generation of successive final-state showers
16555C...in external processes.
16556
16557 SUBROUTINE PYADSH(NFIN)
16558
16559C...Double precision and integer declarations.
16560 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16561 IMPLICIT INTEGER(I-N)
16562 INTEGER PYK,PYCHGE,PYCOMP
16563C...Parameter statement for maximum size of showers.
16564 PARAMETER (MAXNUR=1000)
16565C...Commonblocks.
16566 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16567 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16568 COMMON/PYCTAG/NCT,MCT(4000,2)
16569 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16570 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16571 COMMON/PYINT1/MINT(400),VINT(400)
16572 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16573C...Local array.
16574 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16575
16576C...Set primary vertex.
16577 DO 100 J=1,5
16578 V(MINT(83)+5,J)=0D0
16579 V(MINT(83)+6,J)=0D0
16580 V(MINT(84)+1,J)=0D0
16581 V(MINT(84)+2,J)=0D0
16582 100 CONTINUE
16583
16584C...Isolate systems of particles with the same mother.
16585 NSYS=0
16586 IMS=-1
16587 DO 140 I=MINT(84)+3,NFIN
16588 IM=K(I,3)
16589 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16590 IF(IM.NE.IMS) THEN
16591 NSYS=NSYS+1
16592 IBEG(NSYS)=I
16593 IMS=IM
16594 ENDIF
16595
16596C...Set production vertices.
16597 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16598 & THEN
16599 DO 110 J=1,4
16600 V(I,J)=0D0
16601 110 CONTINUE
16602 ELSE
16603 DO 120 J=1,4
16604 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16605 120 CONTINUE
16606 ENDIF
16607 IF(MSTP(125).GE.1) THEN
16608 IDOC=I-MSTP(126)+4
16609 DO 130 J=1,5
16610 V(IDOC,J)=V(I,J)
16611 130 CONTINUE
16612 ENDIF
16613 140 CONTINUE
16614
16615C...End loop over systems. Return if no showers to be performed.
16616 IBEG(NSYS+1)=NFIN+1
16617 IF(MSTP(71).LE.0) RETURN
16618
16619C...Loop through systems of particles; check that sensible size.
16620 DO 270 ISYS=1,NSYS
16621 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16622 IF(MINT(35).LE.2) THEN
16623 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16624 GOTO 270
16625 ELSEIF(NSIZ.LE.1) THEN
16626 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16627 GOTO 270
16628 ELSEIF(NSIZ.GT.80) THEN
16629 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16630 GOTO 270
16631 ENDIF
16632 ENDIF
16633
16634C...Save status codes and daughters of showering particles; reset them.
16635 DO 150 J=1,4
16636 PSUM(J)=0D0
16637 150 CONTINUE
16638 DO 170 II=1,NSIZ
16639 I=IBEG(ISYS)-1+II
16640 KSAV(II,1)=K(I,1)
16641 IF(K(I,1).GT.10) THEN
16642 K(I,1)=1
16643 IF(KSAV(II,1).EQ.14) K(I,1)=3
16644 ENDIF
16645 IF(KSAV(II,1).LE.10) THEN
16646 ELSEIF(K(I,1).EQ.1) THEN
16647 KSAV(II,4)=K(I,4)
16648 KSAV(II,5)=K(I,5)
16649 K(I,4)=0
16650 K(I,5)=0
16651 ELSE
16652 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16653 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16654 K(I,4)=K(I,4)-KSAV(II,4)
16655 K(I,5)=K(I,5)-KSAV(II,5)
16656 ENDIF
16657 DO 160 J=1,4
16658 PSUM(J)=PSUM(J)+P(I,J)
16659 160 CONTINUE
16660 170 CONTINUE
16661
16662C...Perform shower.
16663 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16664 & PSUM(3)**2))
16665 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16666 NSAV=N
16667 IF(MINT(35).LE.2) THEN
16668 IF(NSIZ.EQ.2) THEN
16669 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16670 ELSE
16671 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16672 ENDIF
16673
16674C...For external processes, first call, also ISR partons radiate.
16675C...Can use existing PYPART list, removing partons that radiate later.
16676 ELSEIF(ISYS.EQ.1) THEN
16677 NPARTN=0
16678 DO 175 II=1,NPART
16679 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16680 NPARTN=NPARTN+1
16681 IPART(NPARTN)=IPART(II)
16682 PTPART(NPARTN)=PTPART(II)
16683 ENDIF
16684 175 CONTINUE
16685 NPART=NPARTN
16686 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16687 ELSE
16688C...For subsequent calls use the systems excluded above.
16689 NPART=NSIZ
16690 NPARTD=0
16691 DO 180 II=1,NSIZ
16692 I=IBEG(ISYS)-1+II
16693 IPART(II)=I
16694 PTPART(II)=0.5D0*QMAX
16695 180 CONTINUE
16696 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16697 ENDIF
16698
16699C...Look up showered copies of original showering particles.
16700 DO 260 II=1,NSIZ
16701 I=IBEG(ISYS)-1+II
16702 IMV=I
16703C...Particles without daughters need not be studied.
16704 IF(KSAV(II,1).LE.10) GOTO 260
16705 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16706 ELSEIF(K(I,1).EQ.11) THEN
16707 190 IMV=MOD(K(IMV,4),MSTU(5))
16708 IF(K(IMV,1).EQ.11) GOTO 190
16709 ELSE
16710 KDA1=MOD(K(I,4),MSTU(5))
16711 IF(KDA1.GT.0) THEN
16712 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16713 ENDIF
16714 KDA2=MOD(K(I,5),MSTU(5))
16715 IF(KDA2.GT.0) THEN
16716 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16717 ENDIF
16718 DO 200 I3=I+1,N
16719 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
16720 & THEN
16721 IMV=I3
16722 KDA1=MOD(K(I3,4),MSTU(5))
16723 IF(KDA1.GT.0) THEN
16724 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16725 ENDIF
16726 KDA2=MOD(K(I3,5),MSTU(5))
16727 IF(KDA2.GT.0) THEN
16728 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16729 ENDIF
16730 ENDIF
16731 200 CONTINUE
16732 ENDIF
16733
16734C...Restore daughter info of original partons to showered copies.
16735 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
16736 IF(KSAV(II,1).LE.10) THEN
16737 ELSEIF(K(I,1).EQ.1) THEN
16738 K(IMV,4)=KSAV(II,4)
16739 K(IMV,5)=KSAV(II,5)
16740 ELSE
16741 K(IMV,4)=K(IMV,4)+KSAV(II,4)
16742 K(IMV,5)=K(IMV,5)+KSAV(II,5)
16743 ENDIF
16744
16745C...Reset mother info of existing daughters to showered copies.
16746 DO 210 I3=IBEG(ISYS+1),NFIN
16747 IF(K(I3,3).EQ.I) K(I3,3)=IMV
16748 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
16749 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
16750 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
16751 ENDIF
16752 210 CONTINUE
16753
16754C...Boost all original daughters to new frame of showered copy.
16755C...Also update their colour tags.
16756 IF(IMV.NE.I) THEN
16757 DO 220 J=1,3
16758 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
16759 220 CONTINUE
16760 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
16761 DO 230 J=1,3
16762 BETA(J)=FAC*BETA(J)
16763 230 CONTINUE
16764 DO 250 I3=IBEG(ISYS+1),NFIN
16765 IMO=I3
16766 240 IMO=K(IMO,3)
16767 IF(MSTP(128).LE.0) THEN
16768 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
16769 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
16770 & THEN
16771 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16772 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16773 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16774 ENDIF
16775 ELSE
16776 IF(IMO.EQ.IMV) THEN
16777 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
16778 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
16779 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
16780 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
16781 GOTO 240
16782 ENDIF
16783 ENDIF
16784 250 CONTINUE
16785 ENDIF
16786 260 CONTINUE
16787
16788C...End of loop over showering systems
16789 270 CONTINUE
16790
16791 RETURN
16792 END
16793
16794C*********************************************************************
16795
16796C...PYVETO
16797C...Interface to UPVETO, which allows user to veto event generation
16798C...on the parton level, after parton showers but before multiple
16799C...interactions, beam remnants and hadronization is added.
16800
16801 SUBROUTINE PYVETO(IVETO)
16802
16803C...All real arithmetic in double precision.
16804 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16805C...Three Pythia functions return integers, so need declaring.
16806 INTEGER PYK,PYCHGE,PYCOMP
16807
16808C...PYTHIA commonblocks.
16809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16810 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16811 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16812 COMMON/PYINT1/MINT(400),VINT(400)
16813 SAVE /PYJETS/,/PYPARS/,/PYINT1/
16814C...HEPEVT commonblock.
16815 PARAMETER (NMXHEP=4000)
16816 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
16817 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
16818 DOUBLE PRECISION PHEP,VHEP
16819 SAVE /HEPEVT/
16820C...Local array.
16821 DIMENSION IRESO(100)
16822
16823C...Define longitudinal boost from initiator rest frame to cm frame.
16824 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
16825 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
16826
16827C...Presentation is different if using pT-ordered shower
16828 IF(MINT(35).EQ.3) THEN
16829 GAMMA=1D0
16830 GABEZ=0D0
16831 ENDIF
16832
16833C... Reset counters.
16834 NEVHEP=0
16835 NHEP=0
16836 NRESO=0
16837
16838C...Oth pass: identify beam and incoming partons
16839 DO 140 I=MINT(83)+1,MINT(83)+6
16840 ISTORE=0
16841 IF(K(I,2).EQ.94) THEN
16842
16843 ELSE
16844 NRESO=NRESO+1
16845 IRESO(NRESO)=I
16846 IMOTH=K(I,3)
16847 ENDIF
16848 140 CONTINUE
16849
16850C...First pass: identify final locations of resonances
16851C...and of their daughters before showering.
16852 DO 150 I=MINT(84)+3,N
16853 ISTORE=0
16854 IMOTH=0
16855
16856C...Skip shower CM frame documentation lines.
16857 IF(K(I,2).EQ.94) THEN
16858
16859C... Store a new intermediate product, when mother in documentation.
16860 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
16861 & K(I,3).LE.MINT(84)) THEN
16862 ISTORE=1
16863 NHEP=NHEP+1
16864 II=NHEP
16865 NRESO=NRESO+1
16866 IRESO(NRESO)=I
16867 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
16868
16869C... Store a new intermediate product, when mother in main section.
16870 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
16871 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
16872 ISTORE=1
16873 NHEP=NHEP+1
16874 II=NHEP
16875 NRESO=NRESO+1
16876 IRESO(NRESO)=I
16877 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
16878 ENDIF
16879
16880 IF(ISTORE.EQ.1) THEN
16881C...Copy parton info, boosting momenta along z axis to cm frame.
16882 ISTHEP(II)=2
16883 IDHEP(II)=K(I,2)
16884 PHEP(1,II)=P(I,1)
16885 PHEP(2,II)=P(I,2)
16886 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16887 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16888 PHEP(5,II)=P(I,5)
16889C...Store one mother. Rest of history and vertex info zeroed.
16890 JMOHEP(1,II)=IMOTH
16891 JMOHEP(2,II)=0
16892 JDAHEP(1,II)=0
16893 JDAHEP(2,II)=0
16894 VHEP(1,II)=0D0
16895 VHEP(2,II)=0D0
16896 VHEP(3,II)=0D0
16897 VHEP(4,II)=0D0
16898 ENDIF
16899 150 CONTINUE
16900
16901C...Second pass: identify current set of "final" partons.
16902 DO 200 I=MINT(84)+3,N
16903 ISTORE=0
16904 IMOTH=0
16905
16906C...Store a final parton.
16907 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
16908 ISTORE=1
16909 NHEP=NHEP+1
16910 II=NHEP
16911C..Trace it back through shower, to check if from documented particle.
16912 IHIST=I
16913 ISAVE=IHIST
16914 160 CONTINUE
16915 IF(IHIST.GT.MINT(84)) THEN
16916 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
16917 DO 170 IRI=1,NRESO
16918 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
16919 170 CONTINUE
16920 ISAVE=IHIST
16921 IHIST=K(IHIST,3)
16922 IF(IMOTH.EQ.0) GOTO 160
16923 IMOTH=MAX(0,IMOTH-6)
16924 ELSEIF(IHIST.LE.4) THEN
16925 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
16926 ISTORE=0
16927 NHEP=NHEP-1
16928 ELSE
16929 IMOTH=0
16930 ENDIF
16931 ENDIF
16932 ENDIF
16933
16934 IF(ISTORE.EQ.1) THEN
16935C...Copy parton info, boosting momenta along z axis to cm frame.
16936 ISTHEP(II)=1
16937 IDHEP(II)=K(I,2)
16938 PHEP(1,II)=P(I,1)
16939 PHEP(2,II)=P(I,2)
16940 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
16941 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
16942 PHEP(5,II)=P(I,5)
16943C...Store one mother. Rest of history and vertex info zeroed.
16944 JMOHEP(1,II)=IMOTH
16945 JMOHEP(2,II)=0
16946 JDAHEP(1,II)=0
16947 JDAHEP(2,II)=0
16948 VHEP(1,II)=0D0
16949 VHEP(2,II)=0D0
16950 VHEP(3,II)=0D0
16951 VHEP(4,II)=0D0
16952 ENDIF
16953 200 CONTINUE
16954C...Call user-written routine to decide whether to keep events.
16955 CALL UPVETO(IVETO)
16956 RETURN
16957 END
16958C*********************************************************************
16959
16960C...PYRESD
16961C...Allows resonances to decay (including parton showers for hadronic
16962C...channels).
16963
16964 SUBROUTINE PYRESD(IRES)
16965
16966C...Double precision and integer declarations.
16967 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16968 IMPLICIT INTEGER(I-N)
16969 INTEGER PYK,PYCHGE,PYCOMP
16970C...Parameter statement to help give large particle numbers.
16971 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
16972 &KEXCIT=4000000,KDIMEN=5000000)
16973C...Parameter statement for maximum size of showers.
16974 PARAMETER (MAXNUR=1000)
16975C...Commonblocks.
16976 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16977 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16978 COMMON/PYCTAG/NCT,MCT(4000,2)
16979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16980 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16981 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16982 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
16983 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16984 COMMON/PYINT1/MINT(400),VINT(400)
16985 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16986 COMMON/PYINT4/MWID(500),WIDS(500,5)
16987 COMMON/PYPUED/IUED(0:99),RUED(0:99)
16988 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
16989 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
16990C...Local arrays and complex and character variables.
16991 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
16992 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(3),ILIN(6),
16993 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
16994 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),XM(5),VDCY(4),
16995 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(3),ITRI(3),IOCT(3)
16996 COMPLEX FGK,HA(6,6),HC(6,6)
16997 REAL TIR,UIR
16998 CHARACTER CODE*9,MASS*9
16999
17000C...The F, Xi and Xj functions of Gunion and Kunszt
17001C...(Phys. Rev. D33, 665, plus errata from the authors).
17002 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17003 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17004 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17005 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17006 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17007 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17008 &2D0*(D34/D56+D56/D34))
17009
17010C...Some general constants.
17011 XW=PARU(102)
17012 XWV=XW
17013 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17014 XW1=1D0-XW
17015 SQMZ=PMAS(23,1)**2
17016
17017 GMMZ=PMAS(23,1)*PMAS(23,2)
17018 SQMW=PMAS(24,1)**2
17019 GMMW=PMAS(24,1)*PMAS(24,2)
17020 SH=VINT(44)
17021
17022C...Boost and rotate to rest frame of incoming partons,
17023C...to get proper amount of smearing of decay angles.
17024 IBST=0
17025 IF(IRES.EQ.0) THEN
17026 IBST=1
17027 IIN1=MINT(84)+1
17028 IIN2=MINT(84)+2
17029C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17030C...(101,102) are off shell and can have inconsistent momenta, resulting
17031C...in boosts larger than unity. However, the corresponding docu partons
17032C...(5,6) are kept on shell, and have consistent momenta that can be used
17033C...to derive this boost instead. Ultimately, should change the way the new
17034C...shower stores intermediate partons, but just using partons (5,6) for now
17035C...does define the boost and furnishes a quick and much needed solution.
17036 IF (MINT(35).EQ.3) THEN
17037 IIN1=MINT(83)+5
17038 IIN2=MINT(83)+6
17039 ENDIF
17040 ETOTIN=P(IIN1,4)+P(IIN2,4)
17041 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17042 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17043 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17044 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17045 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17046 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17047 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17048 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17049 ENDIF
17050
17051C...Reset original resonance configuration.
17052 DO 100 JT=1,8
17053 IREF(1,JT)=0
17054 100 CONTINUE
17055
17056C...Define initial one, two or three objects for subprocess.
17057 IHDEC=0
17058 IF(IRES.EQ.0) THEN
17059 ISUB=MINT(1)
17060 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17061 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17062 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17063 JTMAX=1
17064 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17065 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17066 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17067 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17068 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17069 JTMAX=2
17070 ELSEIF(ISET(ISUB).EQ.5) THEN
17071 IREF(1,1)=MINT(84)+3
17072 IREF(1,2)=MINT(84)+4
17073 IREF(1,3)=MINT(84)+5
17074 IREF(1,4)=MINT(83)+7
17075 IREF(1,5)=MINT(83)+8
17076 IREF(1,6)=MINT(83)+9
17077 JTMAX=3
17078 ENDIF
17079
17080C...Define original resonance for odd cases.
17081 ELSE
17082 ISUB=0
17083 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17084 & IHDEC=1
17085 IF(IHDEC.EQ.1) ISUB=3
17086 IREF(1,1)=IRES
17087 IREF(1,4)=K(IRES,3)
17088 IRESTM=IRES
17089 IF(IREF(1,4).GT.MINT(84)) THEN
17090 110 ITMPMO=IREF(1,4)
17091 IF(K(ITMPMO,2).EQ.94) THEN
17092 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17093 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17094 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17095 IRESTM=ITMPMO
17096C...Explicitly check that reference particle exists, otherwise stop recursion
17097 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17098 IREF(1,4)=K(ITMPMO,3)
17099 GOTO 110
17100 ENDIF
17101 ENDIF
17102 ENDIF
17103 IF(IREF(1,4).GT.MINT(84)) THEN
17104 EMATCH=1D10
17105 IREF14=IREF(1,4)
17106 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17107 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17108 & EMATCH) THEN
17109 IREF(1,4)=II
17110 EMATCH=ABS(P(II,4)-P(IREF14,4))
17111 ENDIF
17112 120 CONTINUE
17113 ENDIF
17114 JTMAX=1
17115 ENDIF
17116
17117C...Check if initial resonance has been moved (in resonance + jet).
17118 DO 140 JT=1,3
17119 IF(IREF(1,JT).GT.0) THEN
17120 IF(K(IREF(1,JT),1).GT.10) THEN
17121 KFA=IABS(K(IREF(1,JT),2))
17122 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17123 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17124 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17125 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17126 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17127 ENDIF
17128 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17129 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17130 ENDIF
17131 DO 130 I=IREF(1,JT)+1,N
17132 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17133 & I.EQ.KDA2)) THEN
17134 IREF(1,JT)=I
17135 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17136 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17137 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17138 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17139 ENDIF
17140 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17141 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17142 ENDIF
17143 ENDIF
17144 130 CONTINUE
17145 ELSE
17146 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17147 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17148 ENDIF
17149 ENDIF
17150 ENDIF
17151 140 CONTINUE
17152
17153C...Set decay vertex for initial resonances
17154 DO 160 JT=1,JTMAX
17155 DO 150 I=1,4
17156 V(IREF(1,JT),I)=0D0
17157 150 CONTINUE
17158 160 CONTINUE
17159
17160C...Loop over decay history.
17161 NP=1
17162 IP=0
17163 170 IP=IP+1
17164 NINH=0
17165 JTMAX=2
17166 IF(IREF(IP,2).EQ.0) JTMAX=1
17167 IF(IREF(IP,3).NE.0) JTMAX=3
17168 IT4=0
17169 NSAV=N
17170
17171C...Check for Higgs which appears as decay product of user-process.
17172 IF(ISUB.EQ.0) THEN
17173 IHDEC=0
17174 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17175 & .EQ.36) IHDEC=1
17176 IF(IHDEC.EQ.1) ISUB=3
17177 ENDIF
17178
17179C...Start treatment of one, two or three resonances in parallel.
17180 180 N=NSAV
17181 DO 340 JT=1,JTMAX
17182 ID=IREF(IP,JT)
17183 KDCY(JT)=0
17184 KFL1(JT)=0
17185 KFL2(JT)=0
17186 KFL3(JT)=0
17187 KEQL(JT)=0
17188 NSD(JT)=ID
17189 ITJUNC(JT)=0
17190
17191C...Check whether particle can/is allowed to decay.
17192 IF(ID.EQ.0) GOTO 330
17193 KFA=IABS(K(ID,2))
17194 KCA=PYCOMP(KFA)
17195 IF(MWID(KCA).EQ.0) GOTO 330
17196 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17197 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17198 & KFA.EQ.18) IT4=IT4+1
17199 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17200 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17201
17202C...Choose lifetime and determine decay vertex.
17203 IF(K(ID,1).EQ.5) THEN
17204 V(ID,5)=0D0
17205 ELSEIF(K(ID,1).NE.4) THEN
17206 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17207 ENDIF
17208 DO 190 J=1,4
17209 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17210 190 CONTINUE
17211
17212C...Determine whether decay allowed or not.
17213 MOUT=0
17214 IF(MSTJ(22).EQ.2) THEN
17215 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17216 ELSEIF(MSTJ(22).EQ.3) THEN
17217 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17218 ELSEIF(MSTJ(22).EQ.4) THEN
17219 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17220 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17221 ENDIF
17222 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17223 K(ID,1)=4
17224 GOTO 330
17225 ENDIF
17226
17227C...Info for selection of decay channel: sign, pairings.
17228 IF(KCHG(KCA,3).EQ.0) THEN
17229 IPM=2
17230 ELSE
17231 IPM=(5-ISIGN(1,K(ID,2)))/2
17232 ENDIF
17233 KFB=0
17234 IF(JTMAX.EQ.2) THEN
17235 KFB=IABS(K(IREF(IP,3-JT),2))
17236 ELSEIF(JTMAX.EQ.3) THEN
17237 JT2=JT+1-3*(JT/3)
17238 KFB=IABS(K(IREF(IP,JT2),2))
17239 IF(KFB.NE.KFA) THEN
17240 JT2=JT+2-3*((JT+1)/3)
17241 KFB=IABS(K(IREF(IP,JT2),2))
17242 ENDIF
17243 ENDIF
17244
17245C...Select decay channel.
17246 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17247 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17248 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17249 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17250 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17251 IF(WDTE0S.LE.0D0) GOTO 330
17252 RKFL=WDTE0S*PYR(0)
17253 IDL=0
17254 200 IDL=IDL+1
17255 IDC=IDL+MDCY(KCA,2)-1
17256 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17257 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17258 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17259
17260C...Read out flavours and colour charges of decay channel chosen.
17261 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17262 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17263 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17264 KFC1A=PYCOMP(IABS(KFL1(JT)))
17265 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17266 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17267 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17268 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17269 KFC2A=PYCOMP(IABS(KFL2(JT)))
17270 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17271 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17272 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17273 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17274 KCQ3(JT)=0
17275 IF(KFL3(JT).NE.0) THEN
17276 KFC3A=PYCOMP(IABS(KFL3(JT)))
17277 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17278 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17279 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17280 ENDIF
17281
17282C...Set/save further info on channel.
17283 KDCY(JT)=1
17284 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17285 NSD(JT)=N
17286 HGZ(JT,1)=VINT(111)
17287 HGZ(JT,2)=VINT(112)
17288 HGZ(JT,3)=VINT(114)
17289 JTZ=JT
17290
17291C...Select masses; to begin with assume resonances narrow.
17292 DO 220 I=1,3
17293 P(N+I,5)=0D0
17294 PMMN(I)=0D0
17295 IF(I.EQ.1) THEN
17296 KFLW=IABS(KFL1(JT))
17297 KCW=KFC1A
17298 ELSEIF(I.EQ.2) THEN
17299 KFLW=IABS(KFL2(JT))
17300 KCW=KFC2A
17301 ELSEIF(I.EQ.3) THEN
17302 IF(KFL3(JT).EQ.0) GOTO 220
17303 KFLW=IABS(KFL3(JT))
17304 KCW=KFC3A
17305 ENDIF
17306 P(N+I,5)=PMAS(KCW,1)
17307CMRENNA++
17308C...This prevents SUSY/t particles from becoming too light.
17309 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17310 PMMN(I)=PMAS(KCW,1)
17311 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17312 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17313 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17314 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17315 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17316 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17317 PMMN(I)=MIN(PMMN(I),PMSUM)
17318 ENDIF
17319 210 CONTINUE
17320C MRENNA--
17321 ELSEIF(KFLW.EQ.6) THEN
17322 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17323 ENDIF
17324C...UED: select a graviton mass from continuous distribution
17325C...(stored in PMAS(39,1) so no value returned)
17326 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17327 & CALL PYGRAM(1)
17328 220 CONTINUE
17329
17330C...Check which two out of three are widest.
17331 IWID1=1
17332 IWID2=2
17333 PWID1=PMAS(KFC1A,2)
17334 PWID2=PMAS(KFC2A,2)
17335 KFLW1=IABS(KFL1(JT))
17336 KFLW2=IABS(KFL2(JT))
17337 IF(KFL3(JT).NE.0) THEN
17338 PWID3=PMAS(KFC3A,2)
17339 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17340 IWID1=3
17341 PWID1=PWID3
17342 KFLW1=IABS(KFL3(JT))
17343 ELSEIF(PWID3.GT.PWID2) THEN
17344 IWID2=3
17345 PWID2=PWID3
17346 KFLW2=IABS(KFL3(JT))
17347 ENDIF
17348 ENDIF
17349
17350C...If all narrow then only check that masses consistent.
17351 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17352 & PWID2.LT.PARP(41))) THEN
17353CMRENNA++
17354C....Handle near degeneracy cases.
17355 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17356 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17357 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17358 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17359 ENDIF
17360 ENDIF
17361CMRENNA--
17362 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17363 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17364 MINT(51)=1
17365 GOTO 720
17366 ELSEIF(P(N+1,5)+P(N+2,5)+P(N+3,5)+PARJ(64).GT.P(ID,5)) THEN
17367 CALL PYERRM(3,'(PYRESD:) daughter masses too large')
17368 MINT(51)=1
17369 GOTO 720
17370 ENDIF
17371
17372C...For three wide resonances select narrower of three
17373C...according to BW decoupled from rest.
17374 ELSE
17375 PMTOT=P(ID,5)
17376 IF(KFL3(JT).NE.0) THEN
17377 IWID3=6-IWID1-IWID2
17378 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17379 & KFLW1-KFLW2
17380 LOOP=0
17381 230 LOOP=LOOP+1
17382 P(N+IWID3,5)=PYMASS(KFLW3)
17383 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17384 PMTOT=PMTOT-P(N+IWID3,5)
17385 ENDIF
17386C...Select other two correlated within remaining phase space.
17387 IF(IP.EQ.1) THEN
17388 CKIN45=CKIN(45)
17389 CKIN47=CKIN(47)
17390 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17391 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17392 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17393 & P(N+IWID2,5))
17394 CKIN(45)=CKIN45
17395 CKIN(47)=CKIN47
17396 ELSE
17397 CKIN(49)=PMMN(IWID1)
17398 CKIN(50)=PMMN(IWID2)
17399 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17400 & P(N+IWID2,5))
17401 CKIN(49)=0D0
17402 CKIN(50)=0D0
17403 ENDIF
17404 IF(MINT(51).EQ.1) GOTO 720
17405 ENDIF
17406
17407C...Begin fill decay products, with colour flow for coloured objects.
17408 MSTU10=MSTU(10)
17409 MSTU(10)=1
17410 MSTU(19)=1
17411
17412C...Three-body decays
17413 IF(KFL3(JT).NE.0) THEN
17414 DO 250 I=N+1,N+3
17415 DO 240 J=1,5
17416 K(I,J)=0
17417 V(I,J)=0D0
17418 240 CONTINUE
17419 MCT(I,1)=0
17420 MCT(I,2)=0
17421 250 CONTINUE
17422 K(N+1,1)=1
17423 K(N+1,2)=KFL1(JT)
17424 K(N+2,1)=1
17425 K(N+2,2)=KFL2(JT)
17426 K(N+3,1)=1
17427 K(N+3,2)=KFL3(JT)
17428 IDIN=ID
17429
17430C...Generate kinematics (default is flat)
17431 CALL PYTBDY(IDIN)
17432
17433C...Set generic colour flows whenever unambiguous,
17434C...(independently of the order of the decay products)
17435C...Sum up total colour content
17436 NANT=0
17437 NTRI=0
17438 NOCT=0
17439 KCQ(0)=KCQM(JT)
17440 KCQ(1)=KCQ1(JT)
17441 KCQ(2)=KCQ2(JT)
17442 KCQ(3)=KCQ3(JT)
17443 DO 255 J=0,3
17444 IF (KCQ(J).EQ.-1) THEN
17445 NANT=NANT+1
17446 IANT(NANT)=N+J
17447 ELSEIF (KCQ(J).EQ.1) THEN
17448 NTRI=NTRI+1
17449 ITRI(NTRI)=N+J
17450 ELSEIF (KCQ(J).EQ.2) THEN
17451 NOCT=NOCT+1
17452 IOCT(NOCT)=N+J
17453 ENDIF
17454 255 CONTINUE
17455
17456C...Set color flow for generic 1 -> N processes (N arbitrary)
17457 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17458C...All singlets: do nothing
17459
17460 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17461C...Two octets, zero triplets, n singlets:
17462 IF (KCQ(0).EQ.2) THEN
17463C...8 -> 8 + n(1)
17464 K(ID,4)=K(ID,4)+IOCT(2)
17465 K(ID,5)=K(ID,5)+IOCT(2)
17466 K(IOCT(2),1)=3
17467 K(IOCT(2),4)=MSTU(5)*ID
17468 K(IOCT(2),5)=MSTU(5)*ID
17469 MCT(IOCT(2),1)=MCT(ID,1)
17470 MCT(IOCT(2),2)=MCT(ID,2)
17471 ELSE
17472C...1 -> 8 + 8 + n(1)
17473 K(IOCT(1),1)=3
17474 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17475 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17476 K(IOCT(2),1)=3
17477 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17478 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17479 NCT=NCT+1
17480 MCT(IOCT(1),1)=NCT
17481 MCT(IOCT(2),2)=NCT
17482 NCT=NCT+1
17483 MCT(IOCT(2),1)=NCT
17484 MCT(IOCT(1),2)=NCT
17485 ENDIF
17486
17487 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17488C...Two triplets, zero octets, n singlets.
17489 IF (KCQ(0).EQ.1) THEN
17490C...3 -> 3 + n(1)
17491 K(ID,4)=K(ID,4)+ITRI(2)
17492 K(ITRI(2),1)=3
17493 K(ITRI(2),4)=MSTU(5)*ID
17494 MCT(ITRI(2),1)=MCT(ID,1)
17495 ELSEIF (KCQ(0).EQ.-1) THEN
17496C...3bar -> 3bar + n(1)
17497 K(ID,5)=K(ID,5)+IANT(2)
17498 K(IANT(2),1)=3
17499 K(IANT(2),5)=MSTU(5)*ID
17500 MCT(IANT(2),2)=MCT(ID,2)
17501 ELSE
17502C...1 -> 3 + 3bar + n(1)
17503 K(ITRI(1),1)=3
17504 K(ITRI(1),4)=MSTU(5)*IANT(1)
17505 K(IANT(1),1)=3
17506 K(IANT(1),5)=MSTU(5)*ITRI(1)
17507 NCT=NCT+1
17508 MCT(ITRI(1),1)=NCT
17509 MCT(IANT(1),2)=NCT
17510 ENDIF
17511
17512 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17513C...Two triplets, one octet, n singlets.
17514 IF (KCQ(0).EQ.2) THEN
17515C...8 -> 3 + 3bar + n(1)
17516 K(ID,4)=K(ID,4)+ITRI(1)
17517 K(ID,5)=K(ID,5)+IANT(1)
17518 K(ITRI(1),1)=3
17519 K(ITRI(1),4)=MSTU(5)*ID
17520 K(IANT(1),1)=3
17521 K(IANT(1),5)=MSTU(5)*ID
17522 MCT(ITRI(1),1)=MCT(ID,1)
17523 MCT(IANT(1),2)=MCT(ID,2)
17524 ELSEIF (KCQ(0).EQ.1) THEN
17525C...3 -> 8 + 3 + n(1)
17526 K(ID,4)=K(ID,4)+IOCT(1)
17527 K(IOCT(1),1)=3
17528 K(IOCT(1),4)=MSTU(5)*ID
17529 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17530 K(ITRI(2),1)=3
17531 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17532 MCT(IOCT(1),1)=MCT(ID,1)
17533 NCT=NCT+1
17534 MCT(IOCT(1),2)=NCT
17535 MCT(ITRI(2),1)=NCT
17536 ELSEIF (KCQ(0).EQ.-1) THEN
17537C...3bar -> 8 + 3bar + n(1)
17538 K(ID,5)=K(ID,5)+IOCT(1)
17539 K(IOCT(1),1)=3
17540 K(IOCT(1),5)=MSTU(5)*ID
17541 K(IOCT(1),4)=MSTU(5)*IANT(2)
17542 K(IANT(2),1)=3
17543 K(IANT(2),5)=MSTU(5)*IOCT(1)
17544 MCT(IOCT(1),2)=MCT(ID,2)
17545 NCT=NCT+1
17546 MCT(IOCT(1),1)=NCT
17547 MCT(IANT(2),2)=NCT
17548 ELSE
17549C...1 -> 3 + 3bar + 8 + n(1)
17550 K(ITRI(1),1)=3
17551 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17552 K(IOCT(1),1)=3
17553 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17554 K(IOCT(1),4)=MSTU(5)*IANT(1)
17555 K(IANT(1),1)=3
17556 K(IANT(1),5)=MSTU(5)*IOCT(1)
17557 NCT=NCT+1
17558 MCT(ITRI(1),1)=NCT
17559 MCT(IOCT(1),2)=NCT
17560 NCT=NCT+1
17561 MCT(IOCT(1),1)=NCT
17562 MCT(IANT(1),2)=NCT
17563 ENDIF
17564CPS-- End of generic cases
17565C...(could three octets also be handled?)
17566C...(could (some of) the RPV cases be made generic as well?)
17567
17568C...Special cases (= old treatment)
17569C...Set colour flow for t -> W + b + Z.
17570 ELSEIF(KFA.EQ.6) THEN
17571 K(N+2,1)=3
17572 ISID=4
17573 IF(KCQM(JT).EQ.-1) ISID=5
17574 IDAU=N+2
17575 K(ID,ISID)=K(ID,ISID)+IDAU
17576 K(IDAU,ISID)=MSTU(5)*ID
17577
17578C...Set colour flow in three-body decays - programmed as special cases.
17579
17580 ELSEIF(KFC2A.LE.6) THEN
17581 K(N+2,1)=3
17582 K(N+3,1)=3
17583 ISID=4
17584 IF(KFL2(JT).LT.0) ISID=5
17585 K(N+2,ISID)=MSTU(5)*(N+3)
17586 K(N+3,9-ISID)=MSTU(5)*(N+2)
17587C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
17588 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
17589 & .AND.KFL3(JT).NE.0) THEN
17590 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
17591C...3-body decays of squarks to colour singlets plus one quark
17592 IF (KQSUMA.EQ.1) THEN
17593C...Find quark
17594 IQ=0
17595 IF (KCQ1(JT).NE.0) IQ=1
17596 IF (KCQ2(JT).NE.0) IQ=2
17597 IF (KCQ3(JT).NE.0) IQ=3
17598 ISID=4
17599 IF (K(N+IQ,2).LT.0) ISID=5
17600 K(N+IQ,1)=3
17601 K(ID,ISID)=K(ID,ISID)+(N+IQ)
17602 K(N+IQ,ISID)=MSTU(5)*ID
17603 ENDIF
17604C...PS--
17605 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
17606 K(N+1,1)=3
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(N+1,ISID)=MSTU(5)*(N+2)
17612 K(N+1,9-ISID)=MSTU(5)*(N+3)
17613 K(N+2,ISID)=MSTU(5)*(N+1)
17614 K(N+3,9-ISID)=MSTU(5)*(N+1)
17615 ELSEIF(KFA.EQ.KSUSY1+21) THEN
17616 K(N+2,1)=3
17617 K(N+3,1)=3
17618 ISID=4
17619 IF(KFL2(JT).LT.0) ISID=5
17620 K(ID,ISID)=K(ID,ISID)+(N+2)
17621 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
17622 K(N+2,ISID)=MSTU(5)*ID
17623 K(N+3,9-ISID)=MSTU(5)*ID
17624CMRENNA--
17625
17626 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
17627 & IABS(KCQ2(JT)).EQ.1) THEN
17628 K(N+2,1)=3
17629 K(N+3,1)=3
17630 ISID=4
17631 IF(KFL2(JT).LT.0) ISID=5
17632 K(N+2,ISID)=MSTU(5)*(N+3)
17633 K(N+3,9-ISID)=MSTU(5)*(N+2)
17634 ENDIF
17635
17636 NSAV=N
17637
17638C...Set colour flow in three-body decays with baryon number violation.
17639C...Neutralino and chargino decays first.
17640 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
17641 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
17642 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
17643 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17644C...Insert junction to keep track of colours.
17645 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17646 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17647 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17648C...Set special junction codes:
17649 K(N+4,1)=42
17650 K(N+4,2)=88
17651
17652C...Order decay products by invariant mass. (will be used in PYSTRF).
17653 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)-
17654 & P(N+1,3)*P(N+2,3)
17655 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)-
17656 & P(N+1,3)*P(N+3,3)
17657 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)-
17658 & P(N+2,3)*P(N+3,3)
17659 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
17660 K(N+4,4)=N+3+K(N+4,4)
17661 K(N+4,5)=N+1+MSTU(5)*(N+2)
17662 ELSEIF(PM13.LT.PM23) THEN
17663 K(N+4,4)=N+2+K(N+4,4)
17664 K(N+4,5)=N+1+MSTU(5)*(N+3)
17665 ELSE
17666 K(N+4,4)=N+1+K(N+4,4)
17667 K(N+4,5)=N+2+MSTU(5)*(N+3)
17668 ENDIF
17669 DO 260 J=1,5
17670 P(N+4,J)=0D0
17671 V(N+4,J)=0D0
17672 260 CONTINUE
17673C...Connect daughters to junction.
17674 DO 270 II=N+1,N+3
17675 K(II,4)=0
17676 K(II,5)=0
17677 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
17678 270 CONTINUE
17679C...Particle counter should be stepped up one extra for junction.
17680 N=N+1
17681
17682C...Gluino decays.
17683 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
17684 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
17685 K(N+4,4)=ITJUNC(JT)*MSTU(5)
17686C...Insert junction to keep track of colours.
17687 IF(KCQ1(JT).NE.0) K(N+1,1)=3
17688 IF(KCQ2(JT).NE.0) K(N+2,1)=3
17689 IF(KCQ3(JT).NE.0) K(N+3,1)=3
17690 K(N+4,1)=42
17691 K(N+4,2)=88
17692 DO 280 J=1,5
17693 P(N+4,J)=0D0
17694 V(N+4,J)=0D0
17695 280 CONTINUE
17696 CTMSUM=0D0
17697 DO 290 II=N+1,N+3
17698 K(II,4)=0
17699 K(II,5)=0
17700C...Start by connecting all daughters to junction.
17701 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
17702C...Only consider colour topologies with off shell resonances.
17703 RMQ1=PMAS(PYCOMP(K(II,2)),1)
17704 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
17705 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
17706 IF (RMGLU-RMQ1.LT.RMRES) THEN
17707C...Calculate propagators for each colour topology.
17708 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
17709 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
17710 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
17711 ELSE
17712 CTM2(II-N)=0D0
17713 ENDIF
17714 CTMSUM=CTMSUM+CTM2(II-N)
17715 290 CONTINUE
17716 CTMSUM=PYR(0)*CTMSUM
17717C...Select colour topology J, with most off shell least likely.
17718 J=0
17719 300 J=J+1
17720 CTMSUM=CTMSUM-CTM2(J)
17721 IF (CTMSUM.GT.0D0) GOTO 300
17722C...The lucky winner gets its colour (anti-colour) directly from gluino.
17723 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
17724 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
17725C...The other gluino colour is connected to junction
17726 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
17727 & MSTU(5)
17728 K(N+4,4)=K(N+4,4)+ID
17729C...Lastly, connect junction to remaining daughters.
17730 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
17731C...Particle counter should be stepped up one extra for junction.
17732 N=N+1
17733 ENDIF
17734
17735C...Update particle counter.
17736 N=N+3
17737
17738C...2) Everything else two-body decay.
17739 ELSE
17740 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
17741 MCT(N-1,1)=0
17742 MCT(N-1,2)=0
17743 MCT(N,1)=0
17744 MCT(N,2)=0
17745C...First set colour flow as if mother colour singlet.
17746 IF(KCQ1(JT).NE.0) THEN
17747 K(N-1,1)=3
17748 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
17749 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
17750 ENDIF
17751 IF(KCQ2(JT).NE.0) THEN
17752 K(N,1)=3
17753 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
17754 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
17755 ENDIF
17756C...Then redirect colour flow if mother (anti)triplet.
17757 IF(KCQM(JT).EQ.0) THEN
17758 ELSEIF(KCQM(JT).NE.2) THEN
17759 ISID=4
17760 IF(KCQM(JT).EQ.-1) ISID=5
17761 IDAU=N-1
17762 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
17763 K(ID,ISID)=K(ID,ISID)+IDAU
17764 K(IDAU,ISID)=MSTU(5)*ID
17765C...Then redirect colour flow if mother octet.
17766 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
17767 IDAU=N-1
17768 IF(KCQ1(JT).EQ.0) IDAU=N
17769 K(ID,4)=K(ID,4)+IDAU
17770 K(ID,5)=K(ID,5)+IDAU
17771 K(IDAU,4)=MSTU(5)*ID
17772 K(IDAU,5)=MSTU(5)*ID
17773 ELSE
17774 ISID=4
17775 IF(KCQ1(JT).EQ.-1) ISID=5
17776 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
17777 K(ID,ISID)=K(ID,ISID)+(N-1)
17778 K(ID,9-ISID)=K(ID,9-ISID)+N
17779 K(N-1,ISID)=MSTU(5)*ID
17780 K(N,9-ISID)=MSTU(5)*ID
17781 ENDIF
17782
17783C...Insert junction
17784 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
17785 N=N+1
17786C...~q* mother: type 3 junction. ~q mother: type 4.
17787 ITJUNC(JT)=(7+KCQM(JT))/2
17788C...Specify junction KF and set colour flow from junction
17789 K(N,1)=42
17790 K(N,2)=88
17791 K(N,3)=ID
17792C...Junction type encoded together with mother:
17793 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
17794 K(N,5)=N-1+MSTU(5)*(N-2)
17795C...Zero P and V for junction (V filled later)
17796 DO 310 J=1,5
17797 P(N,J)=0D0
17798 V(N,J)=0D0
17799 310 CONTINUE
17800C...Set colour flow from mother to junction
17801 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
17802C...Set colour flow from daughters to junction
17803 DO 320 II=N-2,N-1
17804 K(II,4) = 0
17805 K(II,5) = 0
17806C...(Anti-)colour mother is junction.
17807 K(II,1+ITJUNC(JT)) = MSTU(5)*(N)
17808 320 CONTINUE
17809 ENDIF
17810 ENDIF
17811
17812C...End loop over resonances for daughter flavour and mass selection.
17813 MSTU(10)=MSTU10
17814 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
17815 & NINH=NINH+1
17816 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
17817 & KFL1(JT).EQ.0) THEN
17818 WRITE(CODE,'(I9)') K(ID,2)
17819 WRITE(MASS,'(F9.3)') P(ID,5)
17820 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
17821 & CODE//' with mass'//MASS)
17822 MINT(51)=1
17823 GOTO 720
17824 ENDIF
17825 340 CONTINUE
17826
17827C...Check for allowed combinations. Skip if no decays.
17828 IF(JTMAX.EQ.1) THEN
17829 IF(KDCY(1).EQ.0) GOTO 710
17830 ELSEIF(JTMAX.EQ.2) THEN
17831 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
17832 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17833 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17834 ELSEIF(JTMAX.EQ.3) THEN
17835 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
17836 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
17837 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17838 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
17839 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
17840 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17841 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
17842 ENDIF
17843
17844C...Special case: matrix element option for Z0 decay to quarks.
17845 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
17846 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
17847
17848C...Check consistency of MSTJ options set.
17849 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
17850 CALL PYERRM(6,
17851 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
17852 MSTJ(110)=1
17853 ENDIF
17854 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
17855 CALL PYERRM(6,
17856 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
17857
17858 MSTJ(111)=0
17859 ENDIF
17860
17861C...Select alpha_strong behaviour.
17862 MST111=MSTU(111)
17863 PAR112=PARU(112)
17864 MSTU(111)=MSTJ(108)
17865 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
17866 & MSTU(111)=1
17867 PARU(112)=PARJ(121)
17868 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
17869
17870C...Find axial fraction in total cross section for scalar gluon model.
17871 PARJ(171)=0D0
17872 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
17873 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
17874 POLL=1D0-PARJ(131)*PARJ(132)
17875 SFF=1D0/(16D0*XW*XW1)
17876 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
17877 & (PARJ(123)*PARJ(124))**2)
17878 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
17879 VE=4D0*XW-1D0
17880 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
17881 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
17882 & (PARJ(132)-PARJ(131)))
17883 KFLC=IABS(KFL1(1))
17884 PMQ=PYMASS(KFLC)
17885 QF=KCHG(KFLC,1)/3D0
17886 VQ=1D0
17887 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
17888 & 1D0-(2D0*PMQ/P(ID,5))**2))
17889 VF=SIGN(1D0,QF)-4D0*QF*XW
17890 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
17891 & VF**2*HF1W)+VQ**3*HF1W
17892 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
17893 ENDIF
17894
17895C...Choice of jet configuration.
17896 CALL PYXJET(P(ID,5),NJET,CUT)
17897 KFLC=IABS(KFL1(1))
17898 KFLN=21
17899 IF(NJET.EQ.4) THEN
17900 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
17901 ELSEIF(NJET.EQ.3) THEN
17902 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
17903 ELSE
17904 MSTJ(120)=1
17905 ENDIF
17906
17907C...Fill jet configuration; return if incorrect kinematics.
17908 NC=N-2
17909 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
17910 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
17911 ELSEIF(NJET.EQ.2) THEN
17912 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
17913 ELSEIF(NJET.EQ.3) THEN
17914 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
17915 ELSEIF(KFLN.EQ.21) THEN
17916 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17917 & X12,X14)
17918 ELSE
17919 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
17920 & X12,X14)
17921 ENDIF
17922 IF(MSTU(24).NE.0) THEN
17923 MINT(51)=1
17924 MSTU(111)=MST111
17925 PARU(112)=PAR112
17926 GOTO 720
17927 ENDIF
17928
17929C...Angular orientation according to matrix element.
17930 IF(MSTJ(106).EQ.1) THEN
17931 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
17932 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
17933 CTHE(1)=COS(THEZ)
17934 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
17935 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
17936 ENDIF
17937
17938C...Boost partons to Z0 rest frame.
17939 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
17940 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
17941
17942C...Mark decayed resonance and add documentation lines,
17943 K(ID,1)=K(ID,1)+10
17944 IDOC=MINT(83)+MINT(4)
17945 DO 360 I=NC+1,N
17946 I1=MINT(83)+MINT(4)+1
17947 K(I,3)=I1
17948 IF(MSTP(128).GE.1) K(I,3)=ID
17949 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
17950 MINT(4)=MINT(4)+1
17951 K(I1,1)=21
17952 K(I1,2)=K(I,2)
17953 K(I1,3)=IREF(IP,4)
17954 DO 350 J=1,5
17955 P(I1,J)=P(I,J)
17956 350 CONTINUE
17957 ENDIF
17958 360 CONTINUE
17959
17960C...Generate parton shower.
17961 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
17962 CALL PYSHOW(N-1,N,P(ID,5))
17963 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
17964 NPART=2
17965 IPART(1)=N-1
17966 IPART(2)=N
17967 PTPART(1)=0.5D0*P(ID,5)
17968 PTPART(2)=PTPART(1)
17969 NCT=NCT+1
17970 IF(K(N-1,2).GT.0) THEN
17971 MCT(N-1,1)=NCT
17972 MCT(N,2)=NCT
17973 ELSE
17974 MCT(N-1,2)=NCT
17975 MCT(N,1)=NCT
17976 ENDIF
17977 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
17978 ENDIF
17979
17980C... End special case for Z0: skip ahead.
17981 MSTU(111)=MST111
17982 PARU(112)=PAR112
17983 GOTO 700
17984 ENDIF
17985
17986C...Order incoming partons and outgoing resonances.
17987 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
17988 &NINH.EQ.0) THEN
17989 ILIN(1)=MINT(84)+1
17990 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
17991 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
17992 & ILIN(1)=2*MINT(84)+3-ILIN(1)
17993 ILIN(2)=2*MINT(84)+3-ILIN(1)
17994 IMIN=1
17995 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17996 & .EQ.36) IMIN=3
17997 IMAX=2
17998 IORD=1
17999 IF(K(IREF(IP,1),2).EQ.23) IORD=2
18000 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18001 IAKIPD=IABS(K(IREF(IP,IORD),2))
18002 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18003 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18004
18005C...Order decay products of resonances.
18006 DO 370 JT=IORD,3-IORD,3-2*IORD
18007 IF(KDCY(JT).EQ.0) THEN
18008 ILIN(IMAX+1)=NSD(JT)
18009 IMAX=IMAX+1
18010 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18011 ILIN(IMAX+1)=N+2*JT-1
18012 ILIN(IMAX+2)=N+2*JT
18013 IMAX=IMAX+2
18014 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18015 K(N+2*JT,2)=K(NSD(JT)+2,2)
18016 ELSE
18017 ILIN(IMAX+1)=N+2*JT
18018
18019 ILIN(IMAX+2)=N+2*JT-1
18020 IMAX=IMAX+2
18021 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18022 K(N+2*JT,2)=K(NSD(JT)+2,2)
18023 ENDIF
18024 370 CONTINUE
18025
18026C...Find charge, isospin, left- and righthanded couplings.
18027 DO 390 I=IMIN,IMAX
18028 DO 380 J=1,4
18029 COUP(I,J)=0D0
18030 380 CONTINUE
18031 KFA=IABS(K(ILIN(I),2))
18032 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18033 COUP(I,1)=KCHG(KFA,1)/3D0
18034 COUP(I,2)=(-1)**MOD(KFA,2)
18035 COUP(I,4)=-2D0*COUP(I,1)*XWV
18036 COUP(I,3)=COUP(I,2)+COUP(I,4)
18037 390 CONTINUE
18038
18039C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18040 IF(ISUB.EQ.22) THEN
18041 DO 420 I=3,5,2
18042 I1=IORD
18043 IF(I.EQ.5) I1=3-IORD
18044 DO 410 J1=1,2
18045 DO 400 J2=1,2
18046 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18047 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18048 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18049 & COUP(I,J2+2)**2
18050 400 CONTINUE
18051 410 CONTINUE
18052 420 CONTINUE
18053 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18054 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18055 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18056 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18057
18058 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18059 ENDIF
18060 ENDIF
18061
18062C...Select angular orientation type - Z'/W' only.
18063 MZPWP=0
18064 IF(ISUB.EQ.141) THEN
18065 IF(PYR(0).LT.PARU(130)) MZPWP=1
18066 IF(IP.EQ.2) THEN
18067 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18068 IAKIR=IABS(K(IREF(2,2),2))
18069 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18070 IF(IAKIR.LE.20) MZPWP=2
18071 ENDIF
18072 IF(IP.GE.3) MZPWP=2
18073 ELSEIF(ISUB.EQ.142) THEN
18074 IF(PYR(0).LT.PARU(136)) MZPWP=1
18075 IF(IP.EQ.2) THEN
18076 IAKIR=IABS(K(IREF(2,2),2))
18077 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18078 IF(IAKIR.LE.20) MZPWP=2
18079 ENDIF
18080 IF(IP.GE.3) MZPWP=2
18081 ENDIF
18082
18083C...Select random angles (begin of weighting procedure).
18084 430 DO 440 JT=1,JTMAX
18085 IF(KDCY(JT).EQ.0) GOTO 440
18086 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18087 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18088 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18089 PHI(JT)=VINT(24)
18090 ELSE
18091 CTHE(JT)=2D0*PYR(0)-1D0
18092 PHI(JT)=PARU(2)*PYR(0)
18093 ENDIF
18094 440 CONTINUE
18095
18096 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18097C...Construct massless four-vectors.
18098 DO 460 I=N+1,N+4
18099 K(I,1)=1
18100 DO 450 J=1,5
18101 P(I,J)=0D0
18102 V(I,J)=0D0
18103 450 CONTINUE
18104 460 CONTINUE
18105 DO 470 JT=1,JTMAX
18106 IF(KDCY(JT).EQ.0) GOTO 470
18107 ID=IREF(IP,JT)
18108 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18109 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18110 P(N+2*JT,3)=-0.5D0*P(ID,5)
18111 P(N+2*JT,4)=0.5D0*P(ID,5)
18112 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18113 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18114 470 CONTINUE
18115
18116C...Store incoming and outgoing momenta, with random rotation to
18117C...avoid accidental zeroes in HA expressions.
18118 IF(ISUB.NE.0) THEN
18119 DO 490 I=IMIN,IMAX
18120 K(N+4+I,1)=1
18121 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18122 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18123 P(N+4+I,5)=P(ILIN(I),5)
18124 DO 480 J=1,3
18125 P(N+4+I,J)=P(ILIN(I),J)
18126 480 CONTINUE
18127 490 CONTINUE
18128 500 THERR=ACOS(2D0*PYR(0)-1D0)
18129 PHIRR=PARU(2)*PYR(0)
18130 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18131 DO 520 I=IMIN,IMAX
18132 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18133 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18134 DO 510 J=1,4
18135 PK(I,J)=P(N+4+I,J)
18136 510 CONTINUE
18137 520 CONTINUE
18138 ENDIF
18139
18140C...Calculate internal products.
18141 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18142 & ISUB.EQ.142) THEN
18143 DO 540 I1=IMIN,IMAX-1
18144 DO 530 I2=I1+1,IMAX
18145 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18146 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18147 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18148 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18149 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18150 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18151 HC(I1,I2)=CONJG(HA(I1,I2))
18152 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18153 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18154 HA(I2,I1)=-HA(I1,I2)
18155 HC(I2,I1)=-HC(I1,I2)
18156 530 CONTINUE
18157 540 CONTINUE
18158 ENDIF
18159
18160C...Calculate four-products.
18161 IF(ISUB.NE.0) THEN
18162 DO 560 I=1,2
18163 DO 550 J=1,4
18164 PK(I,J)=-PK(I,J)
18165 550 CONTINUE
18166 560 CONTINUE
18167 DO 580 I1=IMIN,IMAX-1
18168 DO 570 I2=I1+1,IMAX
18169 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18170 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18171 PKK(I2,I1)=PKK(I1,I2)
18172 570 CONTINUE
18173 580 CONTINUE
18174 ENDIF
18175 ENDIF
18176
18177 KFAGM=IABS(IREF(IP,7))
18178 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18179C...Isotropic decay selected by user.
18180 WT=1D0
18181 WTMAX=1D0
18182
18183 ELSEIF(JTMAX.EQ.3) THEN
18184C...Isotropic decay when three mother particles.
18185 WT=1D0
18186 WTMAX=1D0
18187
18188 ELSEIF(IT4.GE.1) THEN
18189C... Isotropic decay t -> b + W etc for 4th generation q and l.
18190 WT=1D0
18191 WTMAX=1D0
18192
18193 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18194 & IREF(IP,7).EQ.36) THEN
18195C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18196C...CP-odd case added by Kari Ertresvag Myklevoll.
18197C...Now also with mixed Higgs CP-states
18198 ETA=PARP(25)
18199 IF(IP.EQ.1) WTMAX=SH**2
18200 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18201 KFA=IABS(K(IREF(IP,1),2))
18202 KFT=IABS(K(IREF(IP,2),2))
18203
18204 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18205 & MSTP(25).GE.3) THEN
18206C...For mixed CP states need epsilon product.
18207 P10=PK(3,4)
18208 P20=PK(4,4)
18209 P30=PK(5,4)
18210 P40=PK(6,4)
18211 P11=PK(3,1)
18212 P21=PK(4,1)
18213 P31=PK(5,1)
18214 P41=PK(6,1)
18215 P12=PK(3,2)
18216 P22=PK(4,2)
18217 P32=PK(5,2)
18218 P42=PK(6,2)
18219 P13=PK(3,3)
18220 P23=PK(4,3)
18221 P33=PK(5,3)
18222 P43=PK(6,3)
18223 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18224 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18225 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18226 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18227 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18228 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18229 & P22*P30*P41+P13*P22*P31*P40
18230C...For mixed CP states need gauge boson masses.
18231 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18232 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18233 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18234 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18235 XMV=PMAS(KFA,1)
18236 ENDIF
18237
18238C...Z decay
18239 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18240 KFLF1A=IABS(KFL1(1))
18241 EF1=KCHG(KFLF1A,1)/3D0
18242 AF1=SIGN(1D0,EF1+0.1D0)
18243 VF1=AF1-4D0*EF1*XWV
18244 KFLF2A=IABS(KFL1(2))
18245 EF2=KCHG(KFLF2A,1)/3D0
18246 AF2=SIGN(1D0,EF2+0.1D0)
18247 VF2=AF2-4D0*EF2*XWV
18248 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18249 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18250 & THEN
18251C...CP-even decay
18252 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18253 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18254 ELSEIF(MSTP(25).LE.2) THEN
18255C...CP-odd decay
18256 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18257 & -2*PKK(3,4)*PKK(5,6)
18258 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18259 & (PKK(3,4)*PKK(5,6))
18260 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18261 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18262 ELSE
18263C...Mixed CP states.
18264 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18265 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18266 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18267 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18268 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18269 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18270 & +PKK(3,4)*PKK(5,6)
18271 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18272 & +VA12AS*PKK(3,4)*PKK(5,6)
18273 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18274 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18275 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18276 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18277 ENDIF
18278
18279C...W decay
18280 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18281 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18282 & THEN
18283C...CP-even decay
18284 WT=16D0*PKK(3,5)*PKK(4,6)
18285 ELSEIF(MSTP(25).LE.2) THEN
18286C...CP-odd decay
18287 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18288 & -2*PKK(3,4)*PKK(5,6)
18289 & -2*(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(3,6)-PKK(4,5)-PKK(4,6))*
18292 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18293 ELSE
18294C...Mixed CP states.
18295 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18296 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18297 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18298 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18299 & +PKK(3,4)*PKK(5,6)
18300 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18301 & +PKK(3,4)*PKK(5,6)
18302 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18303 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18304 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18305 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18306 ENDIF
18307
18308C...No angular correlations in other Higgs decays.
18309 ELSE
18310 WT=WTMAX
18311 ENDIF
18312
18313 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18314 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18315 & THEN
18316C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18317 I1=IREF(IP,8)
18318 IF(MOD(KFAGM,2).EQ.0) THEN
18319 I2=N+1
18320 I3=N+2
18321 ELSE
18322 I2=N+2
18323 I3=N+1
18324 ENDIF
18325 I4=IREF(IP,2)
18326 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18327 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18328 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18329 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18330
18331 ELSEIF(ISUB.EQ.1) THEN
18332C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18333 EI=KCHG(IABS(MINT(15)),1)/3D0
18334 AI=SIGN(1D0,EI+0.1D0)
18335 VI=AI-4D0*EI*XWV
18336 EF=KCHG(IABS(KFL1(1)),1)/3D0
18337 AF=SIGN(1D0,EF+0.1D0)
18338
18339 VF=AF-4D0*EF*XWV
18340 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18341 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18342 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18343 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18344 & (VI**2+AI**2)*VINT(114)*VF**2)
18345 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18346 & 4D0*VI*AI*VINT(114)*VF*AF)
18347 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18348 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18349 WTMAX=2D0*(WT1+ABS(WT3))
18350
18351 ELSEIF(ISUB.EQ.2) THEN
18352C...Angular weight for W+/- -> 2 quarks/leptons.
18353 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18354 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18355 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18356 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18357 WTMAX=4D0
18358
18359 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18360C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18361C...-> gluon/gamma + 2 quarks/leptons.
18362 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18363 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18364 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18365 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18366 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18367 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18368 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18369 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18370 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18371 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18372 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18373 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18374 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18375 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18376 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18377 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18378
18379 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18380C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18381C...-> gluon/gamma + 2 quarks/leptons.
18382 WT=PKK(1,3)**2+PKK(2,4)**2
18383 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18384
18385 ELSEIF(ISUB.EQ.22) THEN
18386C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18387 S34=P(IREF(IP,IORD),5)**2
18388 S56=P(IREF(IP,3-IORD),5)**2
18389 TI=PKK(1,3)+PKK(1,4)+S34
18390 UI=PKK(1,5)+PKK(1,6)+S56
18391 TIR=REAL(TI)
18392 UIR=REAL(UI)
18393 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18394 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18395 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18396 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18397 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18398 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18399 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18400 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18401
18402 WT=
18403 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18404 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18405 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18406 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18407 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18408 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18409 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18410 & 1D0/UI**2))
18411
18412 ELSEIF(ISUB.EQ.23) THEN
18413C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18414 D34=P(IREF(IP,IORD),5)**2
18415 D56=P(IREF(IP,3-IORD),5)**2
18416 DT=PKK(1,3)+PKK(1,4)+D34
18417 DU=PKK(1,5)+PKK(1,6)+D56
18418 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18419 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18420 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18421 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18422
18423 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18424 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18425 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18426 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18427 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18428 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18429
18430 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18431C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18432C...(or H0, or A0).
18433 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18434 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18435 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18436 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18437 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18438
18439 ELSEIF(ISUB.EQ.25) THEN
18440C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18441 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18442 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18443 D34=P(IREF(IP,IORD),5)**2
18444 D56=P(IREF(IP,3-IORD),5)**2
18445 DT=PKK(1,3)+PKK(1,4)+D34
18446 DU=PKK(1,5)+PKK(1,6)+D56
18447 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18448 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18449 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18450 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18451 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18452 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18453 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18454 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18455 IF(MSTP(50).LE.0) THEN
18456 WT=FGK135**2+(CCWW*FGK253)**2
18457 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18458 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18459 & DJGK(DT,DU)))
18460 ELSE
18461 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18462 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18463 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18464 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18465 ENDIF
18466
18467 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18468C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18469C...(or H0, or A0).
18470 WT=PKK(1,3)*PKK(2,4)
18471 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18472
18473 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18474C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18475C...-> f + 2 quarks/leptons.
18476 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18477 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18478 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18479 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18480 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18481 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18482 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18483 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18484 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18485 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18486 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18487 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18488 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18489 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18490 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18491 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18492 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18493 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18494
18495 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18496C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18497 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18498 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18499 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18500
18501 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18502 & ISUB.EQ.77) THEN
18503C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18504 WT=16D0*PKK(3,5)*PKK(4,6)
18505 WTMAX=SH**2
18506
18507 ELSEIF(ISUB.EQ.110) THEN
18508C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18509 WT=1D0
18510 WTMAX=1D0
18511
18512 ELSEIF(ISUB.EQ.141) THEN
18513C...Special case: if only branching ratios known then isotropic decay.
18514 IF(MWID(32).EQ.2) THEN
18515 WT=1D0
18516 WTMAX=1D0
18517 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18518C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18519C...Couplings of incoming flavour.
18520 KFAI=IABS(MINT(15))
18521 EI=KCHG(KFAI,1)/3D0
18522 AI=SIGN(1D0,EI+0.1D0)
18523 VI=AI-4D0*EI*XWV
18524 KFAIC=1
18525 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18526 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18527 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18528 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18529 VPI=PARU(119+2*KFAIC)
18530 API=PARU(120+2*KFAIC)
18531 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18532 VPI=PARJ(178+2*KFAIC)
18533 API=PARJ(179+2*KFAIC)
18534 ELSE
18535 VPI=PARJ(186+2*KFAIC)
18536 API=PARJ(187+2*KFAIC)
18537 ENDIF
18538C...Couplings of final flavour.
18539 KFAF=IABS(KFL1(1))
18540 EF=KCHG(KFAF,1)/3D0
18541 AF=SIGN(1D0,EF+0.1D0)
18542 VF=AF-4D0*EF*XWV
18543 KFAFC=1
18544 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18545 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18546 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18547 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18548 VPF=PARU(119+2*KFAFC)
18549 APF=PARU(120+2*KFAFC)
18550 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18551 VPF=PARJ(178+2*KFAFC)
18552 APF=PARJ(179+2*KFAFC)
18553 ELSE
18554 VPF=PARJ(186+2*KFAFC)
18555 APF=PARJ(187+2*KFAFC)
18556 ENDIF
18557C...Asymmetry and weight.
18558 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18559 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18560 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18561 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18562 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18563 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18564 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18565 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18566 WTMAX=2D0+ABS(ASYM)
18567 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
18568C...Angular weight for f + fbar -> Z' -> W+ + W-.
18569 RM1=P(NSD(1)+1,5)**2/SH
18570 RM2=P(NSD(1)+2,5)**2/SH
18571 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18572 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18573 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18574 & (RM2-RM1)**2)
18575 WT=CFLAT+CCOS2*CTHE(1)**2
18576 WTMAX=CFLAT+MAX(0D0,CCOS2)
18577 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
18578 & IABS(KFL1(1)).EQ.37)) THEN
18579C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
18580 WT=1D0-CTHE(1)**2
18581 WTMAX=1D0
18582 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18583C...Angular weight for f + fbar -> Z' -> Z0 + h0.
18584 RM1=P(NSD(1)+1,5)**2/SH
18585 RM2=P(NSD(1)+2,5)**2/SH
18586 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18587 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18588 WTMAX=1D0+FLAM2/(8D0*RM1)
18589 ELSEIF(MZPWP.EQ.0) THEN
18590C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18591C...(W:s like if intermediate Z).
18592 D34=P(IREF(IP,IORD),5)**2
18593 D56=P(IREF(IP,3-IORD),5)**2
18594 DT=PKK(1,3)+PKK(1,4)+D34
18595 DU=PKK(1,5)+PKK(1,6)+D56
18596 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18597 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18598 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
18599 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
18600 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18601 ELSEIF(MZPWP.EQ.1) THEN
18602C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
18603C...(W:s approximately longitudinal, like if intermediate H).
18604 WT=16D0*PKK(3,5)*PKK(4,6)
18605 WTMAX=SH**2
18606 ELSE
18607C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
18608C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
18609 WT=1D0
18610 WTMAX=1D0
18611 ENDIF
18612
18613 ELSEIF(ISUB.EQ.142) THEN
18614C...Special case: if only branching ratios known then isotropic decay.
18615 IF(MWID(34).EQ.2) THEN
18616 WT=1D0
18617 WTMAX=1D0
18618 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18619C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
18620 KFAI=IABS(MINT(15))
18621 KFAIC=1
18622 IF(KFAI.GT.10) KFAIC=2
18623 VI=PARU(129+2*KFAIC)
18624 AI=PARU(130+2*KFAIC)
18625 KFAF=IABS(KFL1(1))
18626 KFAFC=1
18627 IF(KFAF.GT.10) KFAFC=2
18628 VF=PARU(129+2*KFAFC)
18629 AF=PARU(130+2*KFAFC)
18630 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
18631 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
18632 WTMAX=2D0+ABS(ASYM)
18633 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
18634C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
18635 RM1=P(NSD(1)+1,5)**2/SH
18636 RM2=P(NSD(1)+2,5)**2/SH
18637 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
18638 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
18639 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
18640 & (RM2-RM1)**2)
18641 WT=CFLAT+CCOS2*CTHE(1)**2
18642 WTMAX=CFLAT+MAX(0D0,CCOS2)
18643 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
18644C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
18645 RM1=P(NSD(1)+1,5)**2/SH
18646 RM2=P(NSD(1)+2,5)**2/SH
18647 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
18648 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
18649 WTMAX=1D0+FLAM2/(8D0*RM1)
18650 ELSEIF(MZPWP.EQ.0) THEN
18651C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18652C...(W/Z like if intermediate W).
18653 D34=P(IREF(IP,IORD),5)**2
18654 D56=P(IREF(IP,3-IORD),5)**2
18655 DT=PKK(1,3)+PKK(1,4)+D34
18656 DU=PKK(1,5)+PKK(1,6)+D56
18657 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
18658 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
18659 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18660 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
18661 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
18662 ELSEIF(MZPWP.EQ.1) THEN
18663C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
18664C...(W/Z approximately longitudinal, like if intermediate H).
18665 WT=16D0*PKK(3,5)*PKK(4,6)
18666 WTMAX=SH**2
18667 ELSE
18668C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
18669C...t + bbar -> t + W + bbar.
18670 WT=1D0
18671 WTMAX=1D0
18672 ENDIF
18673
18674 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
18675 & THEN
18676C...Isotropic decay of leptoquarks (assumed spin 0).
18677 WT=1D0
18678 WTMAX=1D0
18679
18680 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
18681C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
18682 SIDE=1D0
18683 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
18684 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
18685 WT=1D0+SIDE*CTHE(1)
18686 WTMAX=2D0
18687 ELSEIF(IP.EQ.1) THEN
18688
18689 RM1=P(NSD(1)+1,5)**2/SH
18690 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18691 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
18692 ELSE
18693C...W/Z decay assumed isotropic, since not known.
18694 WT=1D0
18695 WTMAX=1D0
18696 ENDIF
18697
18698 ELSEIF(ISUB.EQ.149) THEN
18699C...Isotropic decay of techni-eta.
18700 WT=1D0
18701 WTMAX=1D0
18702
18703 ELSEIF(ISUB.EQ.191) THEN
18704 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18705C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
18706C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
18707 WT=1D0-CTHE(1)**2
18708 WTMAX=1D0
18709 ELSEIF(IP.EQ.1) THEN
18710C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
18711 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18712 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
18713 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18714 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18715 KFAI=IABS(MINT(15))
18716 EI=KCHG(KFAI,1)/3D0
18717 AI=SIGN(1D0,EI+0.1D0)
18718 VI=AI-4D0*EI*XWV
18719 VALI=0.5D0*(VI+AI)
18720 VARI=0.5D0*(VI-AI)
18721 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
18722 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
18723 KFAF=IABS(KFL1(1))
18724 EF=KCHG(KFAF,1)/3D0
18725 AF=SIGN(1D0,EF+0.1D0)
18726 VF=AF-4D0*EF*XWV
18727 VALF=0.5D0*(VF+AF)
18728 VARF=0.5D0*(VF-AF)
18729 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
18730 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
18731 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
18732 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
18733 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
18734 WTMAX=4D0*MAX(ASAME,AFLIP)
18735 ELSE
18736C...Isotropic decay of W/pi_tc produced in rho_tc decay.
18737 WT=1D0
18738 WTMAX=1D0
18739 ENDIF
18740
18741 ELSEIF(ISUB.EQ.192) THEN
18742 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18743C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
18744C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
18745 WT=1D0-CTHE(1)**2
18746 WTMAX=1D0
18747 ELSEIF(IP.EQ.1) THEN
18748C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
18749 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18750 WT=(1D0+CTHESG)**2
18751 WTMAX=4D0
18752 ELSE
18753C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
18754 WT=1D0
18755 WTMAX=1D0
18756 ENDIF
18757
18758 ELSEIF(ISUB.EQ.193) THEN
18759 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
18760C...Angular weight for f + fbar -> omega_tc0 ->
18761C...gamma pi_tc0 or Z0 pi_tc0.
18762 WT=1D0+CTHE(1)**2
18763 WTMAX=2D0
18764 ELSEIF(IP.EQ.1) THEN
18765C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
18766 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
18767 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
18768 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
18769 KFAI=IABS(MINT(15))
18770 EI=KCHG(KFAI,1)/3D0
18771 AI=SIGN(1D0,EI+0.1D0)
18772 VI=AI-4D0*EI*XWV
18773 VALI=0.5D0*(VI+AI)
18774 VARI=0.5D0*(VI-AI)
18775 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
18776 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
18777 KFAF=IABS(KFL1(1))
18778 EF=KCHG(KFAF,1)/3D0
18779 AF=SIGN(1D0,EF+0.1D0)
18780 VF=AF-4D0*EF*XWV
18781 VALF=0.5D0*(VF+AF)
18782 VARF=0.5D0*(VF-AF)
18783 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
18784 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
18785 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
18786 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
18787 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
18788 WTMAX=4D0*MAX(BSAME,BFLIP)
18789 ELSE
18790C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
18791 WT=1D0
18792 WTMAX=1D0
18793 ENDIF
18794
18795 ELSEIF(ISUB.EQ.353) THEN
18796C...Angular weight for Z_R0 -> 2 quarks/leptons.
18797 EI=KCHG(IABS(MINT(15)),1)/3D0
18798 AI=SIGN(1D0,EI+0.1D0)
18799 VI=AI-4D0*EI*XWV
18800 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
18801 AF=SIGN(1D0,EF+0.1D0)
18802 VF=AF-4D0*EF*XWV
18803 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
18804 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
18805 WT2=RMF*(VI**2+AI**2)*VF**2
18806 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
18807 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18808 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18809 WTMAX=2D0*(WT1+ABS(WT3))
18810
18811 ELSEIF(ISUB.EQ.354) THEN
18812C...Angular weight for W_R+/- -> 2 quarks/leptons.
18813 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
18814 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
18815 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18816 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18817 WTMAX=4D0
18818
18819 ELSEIF(ISUB.EQ.391) THEN
18820C...Angular weight for f + fbar -> G* -> f + fbar
18821 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18822 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
18823 WTMAX=2D0
18824C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
18825C...implemented by M.-C. Lemaire
18826 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18827 & IABS(KFL1(1)).EQ.22)) THEN
18828 WT=1D0-CTHE(1)**4
18829 WTMAX=1D0
18830C...Other G* decays not yet implemented angular distributions.
18831 ELSE
18832 WT=1D0
18833 WTMAX=1D0
18834 ENDIF
18835
18836 ELSEIF(ISUB.EQ.392) THEN
18837C...Angular weight for g + g -> G* -> f + fbar
18838 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
18839 WT=1D0-CTHE(1)**4
18840 WTMAX=1D0
18841C...Angular weight for g + g -> G* -> gamma +gamma or g + g
18842C...implemented by M.-C. Lemaire
18843 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
18844 & IABS(KFL1(1)).EQ.22)) THEN
18845 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
18846 WTMAX=8D0
18847C...Other G* decays not yet implemented angular distributions.
18848 ELSE
18849 WT=1D0
18850 WTMAX=1D0
18851 ENDIF
18852
18853C...Obtain correct angular distribution by rejection techniques.
18854 ELSE
18855 WT=1D0
18856 WTMAX=1D0
18857 ENDIF
18858 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
18859
18860C...Construct massive four-vectors using angles chosen.
18861 590 DO 690 JT=1,JTMAX
18862 IF(KDCY(JT).EQ.0) GOTO 690
18863 ID=IREF(IP,JT)
18864 DO 600 J=1,5
18865 DPMO(J)=P(ID,J)
18866 600 CONTINUE
18867 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
18868CMRENNA++
18869 IF(KFL3(JT).EQ.0) THEN
18870 CALL PYROBO(NSD(JT)+1,NSD(JT)+2,ACOS(CTHE(JT)),PHI(JT),
18871 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18872 N0=NSD(JT)+2
18873 ELSE
18874 CALL PYROBO(NSD(JT)+1,NSD(JT)+3,ACOS(CTHE(JT)),PHI(JT),
18875 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
18876 N0=NSD(JT)+3
18877 ENDIF
18878
18879 DO 610 J=1,4
18880 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
18881 610 CONTINUE
18882C...Fill in position of decay vertex.
18883 DO 630 I=NSD(JT)+1,N0
18884 DO 620 J=1,4
18885 V(I,J)=VDCY(J)
18886 620 CONTINUE
18887 V(I,5)=0D0
18888
18889 630 CONTINUE
18890CMRENNA--
18891
18892C...Mark decayed resonances; trace history.
18893 K(ID,1)=K(ID,1)+10
18894 KFA=IABS(K(ID,2))
18895 KCA=PYCOMP(KFA)
18896 IF(KCQM(JT).NE.0) THEN
18897C...Do not kill colour flow through coloured resonance!
18898 ELSE
18899 K(ID,4)=NSD(JT)+1
18900 K(ID,5)=NSD(JT)+2
18901C...If 3-body or 2-body with junction:
18902 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
18903C...If 3-body with junction:
18904 IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
18905 ENDIF
18906
18907C...Add documentation lines.
18908 ISUBRG=MAX(1,MIN(500,MINT(1)))
18909 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
18910 IDOC=MINT(83)+MINT(4)
18911CMRENNA+++
18912 IHI=NSD(JT)+2
18913 IF(KFL3(JT).NE.0) IHI=IHI+1
18914 DO 650 I=NSD(JT)+1,IHI
18915CMRENNA---
18916 I1=MINT(83)+MINT(4)+1
18917 K(I,3)=I1
18918 IF(MSTP(128).GE.1) K(I,3)=ID
18919 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18920 MINT(4)=MINT(4)+1
18921 K(I1,1)=21
18922 K(I1,2)=K(I,2)
18923 K(I1,3)=IREF(IP,JT+3)
18924 DO 640 J=1,5
18925 P(I1,J)=P(I,J)
18926 640 CONTINUE
18927 ENDIF
18928 650 CONTINUE
18929 ELSE
18930 K(NSD(JT)+1,3)=ID
18931 K(NSD(JT)+2,3)=ID
18932C...If 3-body or 2-body with junction:
18933 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
18934C...If 3-body with junction:
18935 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
18936 ENDIF
18937
18938C...Do showering of two or three objects.
18939 NSHBEF=N
18940 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
18941 IF(KFL3(JT).EQ.0) THEN
18942 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
18943 ELSE
18944 CALL PYSHOW(NSD(JT)+1,-3,P(ID,5))
18945 ENDIF
18946
18947c...For pT-ordered shower need set up first, especially colour tags.
18948C...(Need to set up colour tags even if MSTP(71) = 0)
18949 ELSEIF(MINT(35).GE.2) THEN
18950 NPART=2
18951 IF(KFL3(JT).NE.0) NPART=3
18952 IPART(1)=NSD(JT)+1
18953 IPART(2)=NSD(JT)+2
18954 IPART(3)=NSD(JT)+3
18955 PTPART(1)=0.5D0*P(ID,5)
18956 PTPART(2)=PTPART(1)
18957 PTPART(3)=PTPART(1)
18958 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
18959 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
18960 IF(MOTHER.LE.NSD(JT)) THEN
18961 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
18962 ELSE
18963 NCT=NCT+1
18964 MCT(NSD(JT)+1,1)=NCT
18965 MCT(MOTHER,2)=NCT
18966 ENDIF
18967 ENDIF
18968 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
18969 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
18970 IF(MOTHER.LE.NSD(JT)) THEN
18971 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
18972 ELSE
18973 NCT=NCT+1
18974 MCT(NSD(JT)+1,2)=NCT
18975 MCT(MOTHER,1)=NCT
18976 ENDIF
18977 ENDIF
18978 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
18979 & KCQ2(JT).EQ.2)) THEN
18980 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
18981 IF(MOTHER.LE.NSD(JT)) THEN
18982 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
18983 ELSE
18984 NCT=NCT+1
18985 MCT(NSD(JT)+2,1)=NCT
18986 MCT(MOTHER,2)=NCT
18987 ENDIF
18988 ENDIF
18989 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
18990 & KCQ2(JT).EQ.2)) THEN
18991 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
18992 IF(MOTHER.LE.NSD(JT)) THEN
18993 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
18994 ELSE
18995 NCT=NCT+1
18996 MCT(NSD(JT)+2,2)=NCT
18997 MCT(MOTHER,1)=NCT
18998 ENDIF
18999 ENDIF
19000 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19001 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19002 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19003 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19004 ENDIF
19005 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19006 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19007 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19008 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19009 ENDIF
19010 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19011 ENDIF
19012 NSHAFT=N
19013 IF(JT.EQ.1) NAFT1=N
19014
19015C...Check if decay products moved by shower.
19016 NSD1=NSD(JT)+1
19017 NSD2=NSD(JT)+2
19018 NSD3=NSD(JT)+3
19019 IF(NSHAFT.GT.NSHBEF) THEN
19020 IF(K(NSD1,1).GT.10) THEN
19021 DO 660 I=NSHBEF+1,NSHAFT
19022 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19023 660 CONTINUE
19024 ENDIF
19025 IF(K(NSD2,1).GT.10) THEN
19026 DO 670 I=NSHBEF+1,NSHAFT
19027 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19028 & I.NE.NSD1) NSD2=I
19029 670 CONTINUE
19030 ENDIF
19031 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19032 DO 680 I=NSHBEF+1,NSHAFT
19033 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19034 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19035 680 CONTINUE
19036 ENDIF
19037 ENDIF
19038
19039C...Store decay products for further treatment.
19040 NP=NP+1
19041 IREF(NP,1)=NSD1
19042 IREF(NP,2)=NSD2
19043 IREF(NP,3)=0
19044 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19045 IREF(NP,4)=IDOC+1
19046 IREF(NP,5)=IDOC+2
19047 IREF(NP,6)=0
19048 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19049 IREF(NP,7)=K(IREF(IP,JT),2)
19050 IREF(NP,8)=IREF(IP,JT)
19051 690 CONTINUE
19052
19053
19054C...Fill information for 2 -> 1 -> 2.
19055 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19056 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19057 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19058 MINT(25)=KFL1(1)
19059 MINT(26)=KFL2(1)
19060 VINT(23)=CTHE(1)
19061 RM3=P(N-1,5)**2/SH
19062 RM4=P(N,5)**2/SH
19063 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19064 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19065 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19066 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19067 VINT(47)=SQRT(VINT(48))
19068 ENDIF
19069
19070C...Possibility of colour rearrangement in W+W- events.
19071 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19072 IAKF1=IABS(KFL1(1))
19073 IAKF2=IABS(KFL1(2))
19074 IAKF3=IABS(KFL2(1))
19075 IAKF4=IABS(KFL2(2))
19076 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19077 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19078 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19079 IF(MINT(51).NE.0) RETURN
19080 ENDIF
19081
19082C...Loop back if needed.
19083 710 IF(IP.LT.NP) GOTO 170
19084
19085C...Boost back to standard frame.
19086 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19087 &BEZIN)
19088
19089 RETURN
19090 END
19091
19092C*********************************************************************
19093
19094C...PYMULT
19095C...Initializes treatment of multiple interactions, selects kinematics
19096C...of hardest interaction if low-pT physics included in run, and
19097C...generates all non-hardest interactions.
19098
19099 SUBROUTINE PYMULT(MMUL)
19100
19101C...Double precision and integer declarations.
19102 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19103 IMPLICIT INTEGER(I-N)
19104 INTEGER PYK,PYCHGE,PYCOMP
19105C...Commonblocks.
19106 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19107 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19108 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19109 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19110 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19111 COMMON/PYINT1/MINT(400),VINT(400)
19112 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19113 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19114 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19115 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19116 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19117 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19118C...Local arrays and saved variables.
19119 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19120 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19121 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19122 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19123
19124C...Initialization of multiple interaction treatment.
19125 IF(MMUL.EQ.1) THEN
19126 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19127 ISUB=96
19128 MINT(1)=96
19129 VINT(63)=0D0
19130 VINT(64)=0D0
19131 VINT(143)=1D0
19132 VINT(144)=1D0
19133
19134C...Loop over phase space points: xT2 choice in 20 bins.
19135 100 SIGSUM=0D0
19136 DO 120 IXT2=1,20
19137 NMUL(IXT2)=MSTP(83)
19138 SIGM(IXT2)=0D0
19139 DO 110 ITRY=1,MSTP(83)
19140 RSCA=0.05D0*((21-IXT2)-PYR(0))
19141 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19142 XT2=MAX(0.01D0*VINT(149),XT2)
19143 VINT(25)=XT2
19144
19145C...Choose tau and y*. Calculate cos(theta-hat).
19146 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19147 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19148 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19149 ELSE
19150 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19151 ENDIF
19152 VINT(21)=TAU
19153 CALL PYKLIM(2)
19154 RYST=PYR(0)
19155 MYST=1
19156 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19157 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19158 CALL PYKMAP(2,MYST,PYR(0))
19159 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19160
19161C...Calculate differential cross-section.
19162 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19163 CALL PYSIGH(NCHN,SIGS)
19164 SIGM(IXT2)=SIGM(IXT2)+SIGS
19165 110 CONTINUE
19166 SIGSUM=SIGSUM+SIGM(IXT2)
19167 120 CONTINUE
19168 SIGSUM=SIGSUM/(20D0*MSTP(83))
19169
19170C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19171 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19172 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19173 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19174 PARP(82)=0.9D0*PARP(82)
19175 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19176 & VINT(2)
19177 GOTO 100
19178 ENDIF
19179 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19180 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19181
19182C...Start iteration to find k factor.
19183 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19184 P83A=(1D0-PARP(83))**2
19185 P83B=2D0*PARP(83)*(1D0-PARP(83))
19186 P83C=PARP(83)**2
19187 CQ2I=1D0/PARP(84)**2
19188 CQ2R=2D0/(1D0+PARP(84)**2)
19189 SO=0.5D0
19190 XI=0D0
19191 YI=0D0
19192 XF=0D0
19193 YF=0D0
19194 XK=0.5D0
19195 IIT=0
19196 130 IF(IIT.EQ.0) THEN
19197 XK=2D0*XK
19198 ELSEIF(IIT.EQ.1) THEN
19199 XK=0.5D0*XK
19200 ELSE
19201 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19202 ENDIF
19203
19204C...Evaluate overlap integrals. Find where to divide the b range.
19205 IF(MSTP(82).EQ.2) THEN
19206 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19207 SOP=SP/PARU(1)
19208 ELSE
19209 IF(MSTP(82).EQ.3) THEN
19210 DELTAB=0.02D0
19211 ELSEIF(MSTP(82).EQ.4) THEN
19212 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19213 ELSE
19214 POWIP=MAX(0.4D0,PARP(83))
19215 RPWIP=2D0/POWIP-1D0
19216 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19217 SO=0D0
19218 ENDIF
19219 SP=0D0
19220 SOP=0D0
19221 BSP=0D0
19222 SOHIGH=0D0
19223 IBDIV=0
19224 B=-0.5D0*DELTAB
19225 140 B=B+DELTAB
19226 IF(MSTP(82).EQ.3) THEN
19227 OV=EXP(-B**2)/PARU(2)
19228 ELSEIF(MSTP(82).EQ.4) THEN
19229 OV=(P83A*EXP(-MIN(50D0,B**2))+
19230 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19231 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19232 ELSE
19233 OV=EXP(-B**POWIP)/PARU(2)
19234 SO=SO+PARU(2)*B*DELTAB*OV
19235 ENDIF
19236 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19237 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19238 SP=SP+PARU(2)*B*DELTAB*PACC
19239 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19240 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19241 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19242 IBDIV=1
19243 BDIV=B+0.5D0*DELTAB
19244 ENDIF
19245 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19246 ENDIF
19247 YK=PARU(1)*XK*SO/SP
19248
19249C...Continue iteration until convergence.
19250 IF(YK.LT.YKE) THEN
19251 XI=XK
19252 YI=YK
19253 IF(IIT.EQ.1) IIT=2
19254 ELSE
19255 XF=XK
19256 YF=YK
19257 IF(IIT.EQ.0) IIT=1
19258 ENDIF
19259 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19260
19261C...Store some results for subsequent use.
19262 BAVG=BSP/SP
19263 VINT(145)=SIGSUM
19264 VINT(146)=SOP/SO
19265 VINT(147)=SOP/SP
19266 VNT145=VINT(145)
19267 VNT146=VINT(146)
19268 VNT147=VINT(147)
19269C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19270 PIK=(VNT146/VNT147)*YKE
19271
19272C...Find relative weight for low and high impact parameter.
19273 PLOWB=PARU(1)*BDIV**2
19274 IF(MSTP(82).EQ.3) THEN
19275 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19276 ELSEIF(MSTP(82).EQ.4) THEN
19277 S4A=P83A*EXP(-BDIV**2)
19278 S4B=P83B*EXP(-BDIV**2*CQ2R)
19279 S4C=P83C*EXP(-BDIV**2*CQ2I)
19280 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19281 ELSEIF(PARP(83).GE.1.999D0) THEN
19282 PHIGHB=PIK*SOHIGH
19283 B2RPDV=BDIV**POWIP
19284 ELSE
19285 PHIGHB=PIK*SOHIGH
19286 B2RPDV=BDIV**POWIP
19287 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19288 ENDIF
19289 PALLB=PLOWB+PHIGHB
19290
19291C...Initialize iteration in xT2 for hardest interaction.
19292 ELSEIF(MMUL.EQ.2) THEN
19293 VINT(145)=VNT145
19294 VINT(146)=VNT146
19295 VINT(147)=VNT147
19296 IF(MSTP(82).LE.0) THEN
19297 ELSEIF(MSTP(82).EQ.1) THEN
19298 XT2=1D0
19299 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19300 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19301 & VINT(317)/(VINT(318)*VINT(320))
19302 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19303 ELSEIF(MSTP(82).EQ.2) THEN
19304 XT2=1D0
19305 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19306 & VINT(149)*(1D0+VINT(149))
19307 ELSE
19308 XC2=4D0*CKIN(3)**2/VINT(2)
19309 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19310 ENDIF
19311
19312C...Select impact parameter for hardest interaction.
19313 IF(MSTP(82).LE.2) RETURN
19314 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19315C...Treatment in low b region.
19316 MINT(39)=1
19317 B=BDIV*SQRT(PYR(0))
19318 IF(MSTP(82).EQ.3) THEN
19319 OV=EXP(-B**2)/PARU(2)
19320 ELSEIF(MSTP(82).EQ.4) THEN
19321 OV=(P83A*EXP(-MIN(50D0,B**2))+
19322 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19323 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19324 ELSE
19325 OV=EXP(-B**POWIP)/PARU(2)
19326 ENDIF
19327 VINT(148)=OV/VNT147
19328 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19329 XT2=1D0
19330 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19331 & VINT(149)*(1D0+VINT(149))
19332 ELSE
19333C...Treatment in high b region.
19334 MINT(39)=2
19335 IF(MSTP(82).EQ.3) THEN
19336 B=SQRT(BDIV**2-LOG(PYR(0)))
19337 OV=EXP(-B**2)/PARU(2)
19338 ELSEIF(MSTP(82).EQ.4) THEN
19339 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19340 IF(S4RNDM.LT.S4A) THEN
19341 B=SQRT(BDIV**2-LOG(PYR(0)))
19342 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19343 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19344 ELSE
19345 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19346 ENDIF
19347 OV=(P83A*EXP(-MIN(50D0,B**2))+
19348 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19349 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19350 ELSEIF(PARP(83).GE.1.999D0) THEN
19351 144 B2RPW=B2RPDV-LOG(PYR(0))
19352 ACCIP=(B2RPW/B2RPDV)**RPWIP
19353 IF(ACCIP.LT.PYR(0)) GOTO 144
19354 OV=EXP(-B2RPW)/PARU(2)
19355 B=B2RPW**(1D0/POWIP)
19356 ELSE
19357 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19358 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19359 IF(ACCIP.LT.PYR(0)) GOTO 146
19360 OV=EXP(-B2RPW)/PARU(2)
19361 B=B2RPW**(1D0/POWIP)
19362 ENDIF
19363 VINT(148)=OV/VNT147
19364 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19365 ENDIF
19366 IF(PACC.LT.PYR(0)) GOTO 142
19367 VINT(139)=B/BAVG
19368
19369 ELSEIF(MMUL.EQ.3) THEN
19370C...Low-pT or multiple interactions (first semihard interaction):
19371C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19372C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19373 ISUB=MINT(1)
19374 VINT(145)=VNT145
19375 VINT(146)=VNT146
19376 VINT(147)=VNT147
19377 IF(MSTP(82).LE.0) THEN
19378 XT2=0D0
19379 ELSEIF(MSTP(82).EQ.1) THEN
19380 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19381C...Use with "Sudakov" for low b values when impact parameter dependence.
19382 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19383 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19384 & VINT(149)))).GT.PYR(0)) XT2=1D0
19385 IF(XT2.GE.1D0) THEN
19386 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19387 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19388 & VINT(149)
19389 ELSE
19390 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19391 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19392 & VINT(149)
19393 ENDIF
19394 XT2=MAX(0.01D0*VINT(149),XT2)
19395C...Use without "Sudakov" for high b values when impact parameter dep.
19396 ELSE
19397 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19398 & PYR(0)*(1D0-XC2))-VINT(149)
19399 XT2=MAX(0.01D0*VINT(149),XT2)
19400 ENDIF
19401 VINT(25)=XT2
19402
19403C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19404 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19405 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19406 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19407 ISUB=95
19408 MINT(1)=ISUB
19409 VINT(21)=0.01D0*VINT(149)
19410 VINT(22)=0D0
19411 VINT(23)=0D0
19412 VINT(25)=0.01D0*VINT(149)
19413
19414 ELSE
19415C...Multiple interactions (first semihard interaction).
19416C...Choose tau and y*. Calculate cos(theta-hat).
19417 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19418 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19419 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19420 ELSE
19421 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19422 ENDIF
19423 VINT(21)=TAU
19424 CALL PYKLIM(2)
19425 RYST=PYR(0)
19426 MYST=1
19427 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19428 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19429 CALL PYKMAP(2,MYST,PYR(0))
19430 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19431 ENDIF
19432 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19433
19434C...Store results of cross-section calculation.
19435 ELSEIF(MMUL.EQ.4) THEN
19436 ISUB=MINT(1)
19437 VINT(145)=VNT145
19438 VINT(146)=VNT146
19439 VINT(147)=VNT147
19440 XTS=VINT(25)
19441 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19442 IF(ISET(ISUB).EQ.2)
19443 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19444 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19445 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19446 & (XTS+VINT(149))))
19447 IRBIN=INT(1D0+20D0*RBIN)
19448 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19449 NMUL(IRBIN)=NMUL(IRBIN)+1
19450 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19451 ENDIF
19452
19453C...Choose impact parameter if not already done.
19454 ELSEIF(MMUL.EQ.5) THEN
19455 ISUB=MINT(1)
19456 VINT(145)=VNT145
19457 VINT(146)=VNT146
19458 VINT(147)=VNT147
19459 150 IF(MINT(39).GT.0) THEN
19460 ELSEIF(MSTP(82).EQ.3) THEN
19461 EXPB2=PYR(0)
19462 B2=-LOG(PYR(0))
19463 VINT(148)=EXPB2/(PARU(2)*VNT147)
19464 VINT(139)=SQRT(B2)/BAVG
19465 ELSEIF(MSTP(82).EQ.4) THEN
19466 RTYPE=PYR(0)
19467 IF(RTYPE.LT.P83A) THEN
19468 B2=-LOG(PYR(0))
19469 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19470 B2=-LOG(PYR(0))/CQ2R
19471 ELSE
19472 B2=-LOG(PYR(0))/CQ2I
19473 ENDIF
19474 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19475 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19476 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19477 VINT(139)=SQRT(B2)/BAVG
19478 ELSEIF(PARP(83).GE.1.999D0) THEN
19479 POWIP=MAX(2D0,PARP(83))
19480 RPWIP=2D0/POWIP-1D0
19481 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19482 160 IF(PYR(0).LT.PROB1) THEN
19483 B2RPW=PYR(0)**(0.5D0*POWIP)
19484 ACCIP=EXP(-B2RPW)
19485 ELSE
19486 B2RPW=1D0-LOG(PYR(0))
19487 ACCIP=B2RPW**RPWIP
19488 ENDIF
19489 IF(ACCIP.LT.PYR(0)) GOTO 160
19490 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19491 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19492 ELSE
19493 POWIP=MAX(0.4D0,PARP(83))
19494 RPWIP=2D0/POWIP-1D0
19495 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19496 170 IF(PYR(0).LT.PROB1) THEN
19497 B2RPW=2D0*RPWIP*PYR(0)
19498 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19499 ELSE
19500 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19501 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19502 ENDIF
19503 IF(ACCIP.LT .PYR(0)) GOTO 170
19504 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19505 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19506 ENDIF
19507
19508C...Multiple interactions (variable impact parameter) : reject with
19509C...probability exp(-overlap*cross-section above pT/normalization).
19510C...Does not apply to low-b region, where "Sudakov" already included.
19511 VINT(150)=1D0
19512 IF(MINT(39).NE.1) THEN
19513 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19514 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19515 DO 180 IBIN=IRBIN+1,20
19516 RNCOR=RNCOR+NMUL(IBIN)
19517 SIGCOR=SIGCOR+SIGM(IBIN)
19518 180 CONTINUE
19519 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
19520 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
19521 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
19522 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
19523 ENDIF
19524 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
19525 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
19526 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
19527 IF(VINT(150).LT.PYR(0)) GOTO 150
19528 VINT(150)=1D0
19529 ENDIF
19530
19531C...Generate additional multiple semihard interactions.
19532 ELSEIF(MMUL.EQ.6) THEN
19533 ISUBSV=MINT(1)
19534 VINT(145)=VNT145
19535 VINT(146)=VNT146
19536 VINT(147)=VNT147
19537 DO 190 J=11,80
19538 VINTSV(J)=VINT(J)
19539 190 CONTINUE
19540 ISUB=96
19541 MINT(1)=96
19542 VINT(151)=0D0
19543 VINT(152)=0D0
19544
19545C...Reconstruct strings in hard scattering.
19546 NMAX=MINT(84)+4
19547 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
19548 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
19549 NSTR=0
19550 DO 210 I=MINT(84)+1,NMAX
19551 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
19552 IF(KCS.EQ.0) GOTO 210
19553 DO 200 J=1,4
19554 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
19555 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
19556 IF(J.LE.2) THEN
19557 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
19558 ELSE
19559 IST=MOD(K(I,J+1),MSTU(5))
19560 ENDIF
19561 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
19562 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
19563 NSTR=NSTR+1
19564 IF(J.EQ.1.OR.J.EQ.4) THEN
19565 KSTR(NSTR,1)=I
19566 KSTR(NSTR,2)=IST
19567 ELSE
19568 KSTR(NSTR,1)=IST
19569 KSTR(NSTR,2)=I
19570 ENDIF
19571 200 CONTINUE
19572 210 CONTINUE
19573
19574C...Set up starting values for iteration in xT2.
19575 XT2=4D0*VINT(62)/VINT(2)
19576 IF(MSTP(82).LE.1) THEN
19577 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19578 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19579 & VINT(317)/(VINT(318)*VINT(320))
19580 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19581 ELSE
19582 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
19583 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
19584 ENDIF
19585 VINT(63)=0D0
19586 VINT(64)=0D0
19587 VINT(143)=1D0-VINT(141)
19588 VINT(144)=1D0-VINT(142)
19589
19590C...Iterate downwards in xT2.
19591 220 IF(MSTP(82).LE.1) THEN
19592 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19593 IF(XT2.LT.VINT(149)) GOTO 270
19594 ELSE
19595 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
19596 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
19597 & LOG(PYR(0)))-VINT(149)
19598 IF(XT2.LE.0D0) GOTO 270
19599 XT2=MAX(0.01D0*VINT(149),XT2)
19600 ENDIF
19601 VINT(25)=XT2
19602
19603C...Choose tau and y*. Calculate cos(theta-hat).
19604 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19605 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19606 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19607 ELSE
19608 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19609 ENDIF
19610 VINT(21)=TAU
19611 CALL PYKLIM(2)
19612 RYST=PYR(0)
19613 MYST=1
19614 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19615 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19616 CALL PYKMAP(2,MYST,PYR(0))
19617 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19618
19619C...Check that x not used up. Accept or reject kinematical variables.
19620 X1M=SQRT(TAU)*EXP(VINT(22))
19621 X2M=SQRT(TAU)*EXP(-VINT(22))
19622 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
19623 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19624 CALL PYSIGH(NCHN,SIGS)
19625 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
19626 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
19627
19628C...Reset K, P and V vectors. Select some variables.
19629 DO 240 I=N+1,N+2
19630 DO 230 J=1,5
19631 K(I,J)=0
19632 P(I,J)=0D0
19633 V(I,J)=0D0
19634 230 CONTINUE
19635 240 CONTINUE
19636 RFLAV=PYR(0)
19637 PT=0.5D0*VINT(1)*SQRT(XT2)
19638 PHI=PARU(2)*PYR(0)
19639 CTH=VINT(23)
19640
19641C...Add first parton to event record.
19642 K(N+1,1)=3
19643 K(N+1,2)=21
19644 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
19645 & 1+INT((2D0+PARJ(2))*PYR(0))
19646 P(N+1,1)=PT*COS(PHI)
19647 P(N+1,2)=PT*SIN(PHI)
19648 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
19649 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
19650 P(N+1,5)=0D0
19651
19652C...Add second parton to event record.
19653 K(N+2,1)=3
19654 K(N+2,2)=21
19655 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
19656 P(N+2,1)=-P(N+1,1)
19657 P(N+2,2)=-P(N+1,2)
19658 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
19659 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
19660 P(N+2,5)=0D0
19661
19662 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
19663C....Choose relevant string pieces to place gluons on.
19664 DO 260 I=N+1,N+2
19665 DMIN=1D8
19666 DO 250 ISTR=1,NSTR
19667 I1=KSTR(ISTR,1)
19668 I2=KSTR(ISTR,2)
19669 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
19670 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
19671 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
19672 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
19673 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
19674 DMIN=DIST
19675 IST1=I1
19676 IST2=I2
19677 ISTM=ISTR
19678 ENDIF
19679 250 CONTINUE
19680
19681C....Colour flow adjustments, new string pieces.
19682 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
19683 & MOD(K(IST1,4),MSTU(5))
19684 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
19685 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
19686 K(I,5)=MSTU(5)*IST1
19687 K(I,4)=MSTU(5)*IST2
19688 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
19689 & MOD(K(IST2,5),MSTU(5))
19690 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
19691 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
19692 KSTR(ISTM,2)=I
19693 KSTR(NSTR+1,1)=I
19694 KSTR(NSTR+1,2)=IST2
19695 NSTR=NSTR+1
19696 260 CONTINUE
19697
19698C...String drawing and colour flow for gluon loop.
19699 ELSEIF(K(N+1,2).EQ.21) THEN
19700 K(N+1,4)=MSTU(5)*(N+2)
19701 K(N+1,5)=MSTU(5)*(N+2)
19702 K(N+2,4)=MSTU(5)*(N+1)
19703 K(N+2,5)=MSTU(5)*(N+1)
19704 KSTR(NSTR+1,1)=N+1
19705 KSTR(NSTR+1,2)=N+2
19706 KSTR(NSTR+2,1)=N+2
19707 KSTR(NSTR+2,2)=N+1
19708 NSTR=NSTR+2
19709
19710C...String drawing and colour flow for qqbar pair.
19711 ELSE
19712 K(N+1,4)=MSTU(5)*(N+2)
19713 K(N+2,5)=MSTU(5)*(N+1)
19714 KSTR(NSTR+1,1)=N+1
19715 KSTR(NSTR+1,2)=N+2
19716 NSTR=NSTR+1
19717 ENDIF
19718
19719C...Global statistics.
19720 MINT(351)=MINT(351)+1
19721 VINT(351)=VINT(351)+PT
19722 IF (MINT(351).EQ.1) VINT(356)=PT
19723
19724C...Update remaining energy; iterate.
19725 N=N+2
19726 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
19727 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
19728 MINT(51)=1
19729 RETURN
19730 ENDIF
19731 MINT(31)=MINT(31)+1
19732 VINT(151)=VINT(151)+VINT(41)
19733 VINT(152)=VINT(152)+VINT(42)
19734 VINT(143)=VINT(143)-VINT(41)
19735 VINT(144)=VINT(144)-VINT(42)
19736C...Allow FSR for UE (always handle with old showers)
19737 IF(MSTP(152).EQ.1) THEN
19738 M41SAV=MSTJ(41)
19739 IF (MSTJ(41).EQ.10) MSTJ(41)=2
19740 MSTJ(41)=MOD(MSTJ(41),10)
19741 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
19742 MSTJ(41)=M41SAV
19743 ENDIF
19744 IF(MINT(31).LT.240) GOTO 220
19745 270 CONTINUE
19746 MINT(1)=ISUBSV
19747 DO 280 J=11,80
19748 VINT(J)=VINTSV(J)
19749 280 CONTINUE
19750 ENDIF
19751
19752C...Format statements for printout.
19753 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
19754 &'actions for MSTP(82) =',I2,' ******')
19755 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19756 &D9.2,' mb: rejected')
19757 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
19758 &D9.2,' mb: accepted')
19759
19760 RETURN
19761 END
19762
19763C*********************************************************************
19764
19765C...PYREMN
19766C...Adds on target remnants (one or two from each side) and
19767C...includes primordial kT for hadron beams.
19768
19769 SUBROUTINE PYREMN(IPU1,IPU2)
19770
19771C...Double precision and integer declarations.
19772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19773 IMPLICIT INTEGER(I-N)
19774 INTEGER PYK,PYCHGE,PYCOMP
19775C...Commonblocks.
19776 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19777 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19778 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19779 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19780 COMMON/PYINT1/MINT(400),VINT(400)
19781 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
19782C...Local arrays.
19783 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
19784 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
19785
19786C...Find event type and remaining energy.
19787 ISUB=MINT(1)
19788 NS=N
19789 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
19790 VINT(143)=1D0-VINT(141)
19791 VINT(144)=1D0-VINT(142)
19792 ENDIF
19793
19794C...Define initial partons.
19795 NTRY=0
19796 100 NTRY=NTRY+1
19797 DO 130 JT=1,2
19798 I=MINT(83)+JT+2
19799 IF(JT.EQ.1) IPU=IPU1
19800 IF(JT.EQ.2) IPU=IPU2
19801 K(I,1)=21
19802 K(I,2)=K(IPU,2)
19803 K(I,3)=I-2
19804 PMS(JT)=0D0
19805 VINT(156+JT)=0D0
19806 VINT(158+JT)=0D0
19807 IF(MINT(47).EQ.1) THEN
19808 DO 110 J=1,5
19809 P(I,J)=P(I-2,J)
19810 110 CONTINUE
19811 ELSEIF(ISUB.EQ.95) THEN
19812 K(I,2)=21
19813 ELSE
19814 P(I,5)=P(IPU,5)
19815
19816C...No primordial kT, or chosen according to truncated Gaussian or
19817C...exponential, or (for photon) predetermined or power law.
19818 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
19819 IF(MSTP(91).LE.0) THEN
19820 PT=0D0
19821 ELSEIF(MSTP(91).EQ.1) THEN
19822 PT=PARP(91)*SQRT(-LOG(PYR(0)))
19823 ELSE
19824 RPT1=PYR(0)
19825 RPT2=PYR(0)
19826 PT=-PARP(92)*LOG(RPT1*RPT2)
19827 ENDIF
19828 IF(PT.GT.PARP(93)) GOTO 120
19829 ELSEIF(MINT(106+JT).EQ.3) THEN
19830 PTA=SQRT(VINT(282+JT))
19831 PTB=0D0
19832 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
19833 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
19834 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
19835 RPT1=PYR(0)
19836 RPT2=PYR(0)
19837 PTB=-PARP(99)*LOG(RPT1*RPT2)
19838 ENDIF
19839 IF(PTB.GT.PARP(100)) GOTO 120
19840 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
19841 PT=PT*0.8D0**MINT(57)
19842 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
19843 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
19844 IF(MSTP(93).LE.0) THEN
19845 PT=0D0
19846 ELSEIF(MSTP(93).EQ.1) THEN
19847 PT=PARP(99)*SQRT(-LOG(PYR(0)))
19848 ELSEIF(MSTP(93).EQ.2) THEN
19849 RPT1=PYR(0)
19850 RPT2=PYR(0)
19851 PT=-PARP(99)*LOG(RPT1*RPT2)
19852 ELSEIF(MSTP(93).EQ.3) THEN
19853 HA=PARP(99)**2
19854 HB=PARP(100)**2
19855 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
19856 ELSE
19857 HA=PARP(99)**2
19858 HB=PARP(100)**2
19859 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
19860 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
19861 ENDIF
19862 IF(PT.GT.PARP(100)) GOTO 120
19863 ELSE
19864 PT=0D0
19865 ENDIF
19866 VINT(156+JT)=PT
19867 PHI=PARU(2)*PYR(0)
19868 P(I,1)=PT*COS(PHI)
19869 P(I,2)=PT*SIN(PHI)
19870 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
19871 ENDIF
19872 130 CONTINUE
19873 IF(MINT(47).EQ.1) RETURN
19874
19875C...Kinematics construction for initial partons.
19876 I1=MINT(83)+3
19877 I2=MINT(83)+4
19878 IF(ISUB.EQ.95) THEN
19879 SHS=0D0
19880 SHR=0D0
19881 ELSE
19882 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
19883 & (P(I1,2)+P(I2,2))**2
19884 SHR=SQRT(MAX(0D0,SHS))
19885 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
19886 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
19887 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
19888 P(I2,4)=SHR-P(I1,4)
19889 P(I2,3)=-P(I1,3)
19890
19891C...Transform partons to overall CM-frame.
19892 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
19893 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
19894 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
19895 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
19896 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
19897 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
19898 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
19899 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
19900 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
19901 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
19902 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
19903 ENDIF
19904
19905C...Optionally fix up x and Q2 definitions for leptoproduction.
19906 IDISXQ=0
19907 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
19908 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
19909 IF(IDISXQ.EQ.1) THEN
19910
19911C...Find where incoming and outgoing leptons/partons are sitting.
19912 LESD=1
19913 IF(MINT(42).EQ.1) LESD=2
19914 LPIN=MINT(83)+3-LESD
19915 LEIN=MINT(84)+LESD
19916 LQIN=MINT(84)+3-LESD
19917 LEOUT=MINT(84)+2+LESD
19918 LQOUT=MINT(84)+5-LESD
19919 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
19920 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
19921 LSCMS=0
19922 DO 140 I=MINT(84)+5,N
19923 IF(K(I,2).EQ.94) THEN
19924 LSCMS=I
19925 LEOUT=I+LESD
19926 LQOUT=I+3-LESD
19927 ENDIF
19928 140 CONTINUE
19929 LQBG=IPU1
19930 IF(LESD.EQ.1) LQBG=IPU2
19931
19932C...Calculate actual and wanted momentum transfer.
19933 XNOM=VINT(43-LESD)
19934 Q2NOM=-VINT(45)
19935 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
19936 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
19937 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
19938 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
19939 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
19940 P(N+1,1)=FAC*P(LEOUT,1)
19941 P(N+1,2)=FAC*P(LEOUT,2)
19942 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
19943 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
19944 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
19945 & P(N+1,3)**2)
19946 DO 150 J=1,4
19947 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
19948 QNEW(J)=P(LEIN,J)-P(N+1,J)
19949 150 CONTINUE
19950
19951C...Boost outgoing electron and daughters.
19952 IF(LSCMS.EQ.0) THEN
19953 DO 160 J=1,4
19954 P(LEOUT,J)=P(N+1,J)
19955 160 CONTINUE
19956 ELSE
19957 DO 170 J=1,3
19958 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
19959 170 CONTINUE
19960 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
19961 DO 180 J=1,3
19962 DBE(J)=PINV*P(N+2,J)
19963 180 CONTINUE
19964 DO 200 I=LSCMS+1,N
19965 IORIG=I
19966 190 IORIG=K(IORIG,3)
19967 IF(IORIG.GT.LEOUT) GOTO 190
19968 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
19969 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
19970 200 CONTINUE
19971 ENDIF
19972
19973C...Copy shower initiator and all outgoing partons.
19974 NCOP=N+1
19975 K(NCOP,3)=LQBG
19976 DO 210 J=1,5
19977 P(NCOP,J)=P(LQBG,J)
19978 210 CONTINUE
19979 DO 240 I=MINT(84)+1,N
19980 ICOP=0
19981 IF(K(I,1).GT.10) GOTO 240
19982 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
19983 ICOP=I
19984 ELSE
19985 IORIG=I
19986 220 IORIG=K(IORIG,3)
19987 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
19988 ICOP=IORIG
19989 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
19990 GOTO 220
19991 ENDIF
19992 ENDIF
19993 IF(ICOP.NE.0) THEN
19994 NCOP=NCOP+1
19995 K(NCOP,3)=I
19996 DO 230 J=1,5
19997 P(NCOP,J)=P(I,J)
19998 230 CONTINUE
19999 ENDIF
20000 240 CONTINUE
20001
20002C...Calculate relative rescaling factors.
20003 SLC=3-2*LESD
20004 PLCSUM=0D0
20005 DO 250 I=N+2,NCOP
20006 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20007 250 CONTINUE
20008 DO 260 I=N+2,NCOP
20009 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20010 260 CONTINUE
20011
20012C...Transfer extra three-momentum of current.
20013 DO 280 I=N+2,NCOP
20014 DO 270 J=1,3
20015 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20016 270 CONTINUE
20017 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20018 280 CONTINUE
20019
20020C...Iterate change of initiator momentum to get energy right.
20021 ITER=0
20022 290 ITER=ITER+1
20023 PEEX=-P(N+1,4)-QNEW(4)
20024 PEMV=-P(N+1,3)/P(N+1,4)
20025 DO 300 I=N+2,NCOP
20026 PEEX=PEEX+P(I,4)
20027 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20028 300 CONTINUE
20029 IF(ABS(PEMV).LT.1D-10) THEN
20030 MINT(51)=1
20031 MINT(57)=MINT(57)+1
20032 RETURN
20033 ENDIF
20034 PZCH=-PEEX/PEMV
20035 P(N+1,3)=P(N+1,3)+PZCH
20036 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)
20037 DO 310 I=N+2,NCOP
20038 P(I,3)=P(I,3)+V(I,1)*PZCH
20039 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20040 310 CONTINUE
20041 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20042
20043C...Modify momenta in event record.
20044 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20045 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20046 IF(ABS(HBE).GE.1D0) THEN
20047 MINT(51)=1
20048 MINT(57)=MINT(57)+1
20049 RETURN
20050 ENDIF
20051 I=MINT(83)+5-LESD
20052 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20053 DO 330 I=N+1,NCOP
20054 ICOP=K(I,3)
20055 DO 320 J=1,4
20056 P(ICOP,J)=P(I,J)
20057 320 CONTINUE
20058 330 CONTINUE
20059 ENDIF
20060
20061C...Check minimum invariant mass of remnant system(s).
20062 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20063 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20064 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20065 PMIN(0)=SQRT(PMS(0))
20066 DO 340 JT=1,2
20067 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20068 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20069 PMIN(JT)=0D0
20070 IF(MINT(44+JT).EQ.1) GOTO 340
20071 MINT(105)=MINT(102+JT)
20072 MINT(109)=MINT(106+JT)
20073 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20074 IF(MINT(51).NE.0) THEN
20075 MINT(57)=MINT(57)+1
20076 RETURN
20077 ENDIF
20078 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20079 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20080 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20081 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20082 & P(MINT(83)+JT+2,2)**2)
20083 340 CONTINUE
20084 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20085 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20086 &PSYS(2,4))) THEN
20087 MINT(51)=1
20088 MINT(57)=MINT(57)+1
20089 RETURN
20090 ENDIF
20091
20092C...Loop over two remnants; skip if none there.
20093 I=NS
20094 DO 410 JT=1,2
20095 ISN(JT)=0
20096 IF(MINT(44+JT).EQ.1) GOTO 410
20097 IF(JT.EQ.1) IPU=IPU1
20098 IF(JT.EQ.2) IPU=IPU2
20099
20100C...Store first remnant parton.
20101 I=I+1
20102 IS(JT)=I
20103 ISN(JT)=1
20104 DO 350 J=1,5
20105 K(I,J)=0
20106 P(I,J)=0D0
20107 V(I,J)=0D0
20108 350 CONTINUE
20109 K(I,1)=1
20110 K(I,2)=KFLSP(JT)
20111 K(I,3)=MINT(83)+JT
20112 P(I,5)=PYMASS(K(I,2))
20113
20114C...First parton colour connections and kinematics.
20115 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20116 IF(KCOL.EQ.2) THEN
20117 K(I,1)=3
20118 K(I,4)=MSTU(5)*IPU+IPU
20119 K(I,5)=MSTU(5)*IPU+IPU
20120 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20121 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20122 ELSEIF(KCOL.NE.0) THEN
20123 K(I,1)=3
20124 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20125 K(I,KFLS+3)=IPU
20126 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20127 ENDIF
20128 IF(KFLCH(JT).EQ.0) THEN
20129 P(I,1)=-P(MINT(83)+JT+2,1)
20130 P(I,2)=-P(MINT(83)+JT+2,2)
20131 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20132 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20133 P(I,3)=PSYS(JT,3)
20134 P(I,4)=PSYS(JT,4)
20135
20136C...When extra remnant parton or hadron: store extra remnant.
20137 ELSE
20138 I=I+1
20139 ISN(JT)=2
20140 DO 360 J=1,5
20141 K(I,J)=0
20142 P(I,J)=0D0
20143 V(I,J)=0D0
20144 360 CONTINUE
20145 K(I,1)=1
20146 K(I,2)=KFLCH(JT)
20147 K(I,3)=MINT(83)+JT
20148 P(I,5)=PYMASS(K(I,2))
20149
20150C...Find parton colour connections of extra remnant.
20151 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20152 IF(KCOL.EQ.2) THEN
20153 K(I,1)=3
20154 K(I,4)=MSTU(5)*IPU+IPU
20155 K(I,5)=MSTU(5)*IPU+IPU
20156 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20157 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20158 ELSEIF(KCOL.NE.0) THEN
20159 K(I,1)=3
20160 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20161 K(I,KFLS+3)=IPU
20162 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20163 ENDIF
20164
20165C...Relative transverse momentum when two remnants.
20166 LOOP=0
20167 370 LOOP=LOOP+1
20168 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20169 IF(IABS(MINT(10+JT)).LT.20) THEN
20170 P(I-1,1)=0D0
20171 P(I-1,2)=0D0
20172 ELSE
20173 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20174 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20175 ENDIF
20176 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20177 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20178 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20179 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20180
20181C...Meson or baryon; photon as meson. For splitup below.
20182 IMB=1
20183 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20184
20185C***Relative distribution for electron into two electrons. Temporary!
20186 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20187 & THEN
20188 CHI(JT)=PYR(0)
20189
20190C...Relative distribution of electron energy into electron plus parton.
20191 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20192 XHRD=VINT(140+JT)
20193 XE=VINT(154+JT)
20194 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20195
20196C...Relative distribution of energy for particle into two jets.
20197 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20198 CHIK=PARP(92+2*IMB)
20199 IF(MSTP(92).LE.1) THEN
20200 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20201 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20202 ELSEIF(MSTP(92).EQ.2) THEN
20203 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20204 ELSEIF(MSTP(92).EQ.3) THEN
20205 CUT=2D0*0.3D0/VINT(1)
20206 380 CHI(JT)=PYR(0)**2
20207 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20208 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20209 ELSEIF(MSTP(92).EQ.4) THEN
20210 CUT=2D0*0.3D0/VINT(1)
20211 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20212 390 CHIR=CUT*CUTR**PYR(0)
20213 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20214 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20215 ELSE
20216 CUT=2D0*0.3D0/VINT(1)
20217 CUTA=CUT**(1D0-PARP(98))
20218 CUTB=(1D0+CUT)**(1D0-PARP(98))
20219 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20220 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20221 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20222 ENDIF
20223
20224C...Relative distribution of energy for particle into jet plus particle.
20225 ELSE
20226 IF(MSTP(94).LE.1) THEN
20227 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20228 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20229 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20230 ELSEIF(MSTP(94).EQ.2) THEN
20231 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20232 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20233 ELSEIF(MSTP(94).EQ.3) THEN
20234 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20235 CHI(JT)=ZZ
20236 ELSE
20237 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20238 CHI(JT)=ZZ
20239 ENDIF
20240 ENDIF
20241
20242C...Construct total transverse mass; reject if too large.
20243 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20244 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20245 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20246 IF(LOOP.LT.100) THEN
20247 GOTO 370
20248 ELSE
20249 MINT(51)=1
20250 MINT(57)=MINT(57)+1
20251 RETURN
20252 ENDIF
20253 ENDIF
20254 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20255 VINT(158+JT)=CHI(JT)
20256
20257C...Subdivide longitudinal momentum according to value selected above.
20258 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20259 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20260 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20261 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20262 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20263 ENDIF
20264 410 CONTINUE
20265 N=I
20266
20267C...Check if longitudinal boosts needed - if so pick two systems.
20268 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20269 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20270 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20271 IF(ISN(1).EQ.0) THEN
20272 IR=0
20273 IL=2
20274 ELSEIF(ISN(2).EQ.0) THEN
20275 IR=1
20276 IL=0
20277 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20278 IR=1
20279 IL=2
20280 ELSEIF(VINT(143).GT.0.2D0) THEN
20281 IR=1
20282 IL=0
20283 ELSEIF(VINT(144).GT.0.2D0) THEN
20284 IR=0
20285 IL=2
20286 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20287 IR=1
20288 IL=0
20289 ELSE
20290 IR=0
20291 IL=2
20292 ENDIF
20293 IG=3-IR-IL
20294
20295C...E+-pL wanted for system to be modified.
20296 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20297 PPB=VINT(1)
20298 PNB=VINT(1)
20299 ELSE
20300 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20301 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20302 ENDIF
20303
20304C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20305 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20306 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20307 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20308 DO 420 J=1,4
20309 PSYS(0,J)=0D0
20310 420 CONTINUE
20311 DO 450 I=MINT(84)+1,NS
20312 IF(K(I,1).GT.10) GOTO 450
20313 INCL=0
20314 IORIG=I
20315 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20316 IORIG=K(IORIG,3)
20317 IF(IORIG.GT.LPIN) GOTO 430
20318 IF(INCL.EQ.0) GOTO 450
20319 DO 440 J=1,4
20320 PSYS(0,J)=PSYS(0,J)+P(I,J)
20321 440 CONTINUE
20322 450 CONTINUE
20323 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20324 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20325 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20326 ENDIF
20327
20328C...Construct longitudinal boosts.
20329 DPMTB=PPB*PNB
20330 DPMTR=PMS(IR)
20331 DPMTL=PMS(IL)
20332 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20333 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20334 MINT(51)=1
20335 MINT(57)=MINT(57)+1
20336 RETURN
20337 ENDIF
20338 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20339 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20340 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20341 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20342 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20343 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20344 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20345
20346C...Perform longitudinal boosts.
20347 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20348 P(IS(1),3)=0D0
20349 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20350 ELSEIF(IR.EQ.1) THEN
20351 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20352 ELSEIF(IDISXQ.EQ.1) THEN
20353 DO 470 I=I1,NS
20354 INCL=0
20355 IORIG=I
20356 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20357 IORIG=K(IORIG,3)
20358 IF(IORIG.GT.LPIN) GOTO 460
20359 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20360 470 CONTINUE
20361 ELSE
20362 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20363 ENDIF
20364 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20365 P(IS(2),3)=0D0
20366 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20367 ELSEIF(IL.EQ.2) THEN
20368 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20369 ELSEIF(IDISXQ.EQ.1) THEN
20370 DO 490 I=I1,NS
20371 INCL=0
20372 IORIG=I
20373 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20374 IORIG=K(IORIG,3)
20375 IF(IORIG.GT.LPIN) GOTO 480
20376 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20377 490 CONTINUE
20378 ELSE
20379 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20380 ENDIF
20381
20382C...Final check that energy-momentum conservation worked.
20383 PESUM=0D0
20384 PZSUM=0D0
20385 DO 500 I=MINT(84)+1,N
20386 IF(K(I,1).GT.10) GOTO 500
20387 PESUM=PESUM+P(I,4)
20388 PZSUM=PZSUM+P(I,3)
20389 500 CONTINUE
20390 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20391 IF(PDEV.GT.1D-4*VINT(1)) THEN
20392 MINT(51)=1
20393 MINT(57)=MINT(57)+1
20394 RETURN
20395 ENDIF
20396
20397C...Calculate rotation and boost from overall CM frame to
20398C...hadronic CM frame in leptoproduction.
20399 MINT(91)=0
20400 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20401 MINT(91)=1
20402 LESD=1
20403 IF(MINT(42).EQ.1) LESD=2
20404 LPIN=MINT(83)+3-LESD
20405
20406C...Sum upp momenta of everything not lepton or photon to define boost.
20407 DO 510 J=1,4
20408 PSUM(J)=0D0
20409 510 CONTINUE
20410 DO 530 I=1,N
20411 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20412 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20413 IF(K(I,2).EQ.22) GOTO 530
20414 DO 520 J=1,4
20415 PSUM(J)=PSUM(J)+P(I,J)
20416 520 CONTINUE
20417 530 CONTINUE
20418 VINT(223)=-PSUM(1)/PSUM(4)
20419 VINT(224)=-PSUM(2)/PSUM(4)
20420 VINT(225)=-PSUM(3)/PSUM(4)
20421
20422C...Boost incoming hadron to hadronic CM frame to determine rotations.
20423 K(N+1,1)=1
20424 DO 540 J=1,5
20425 P(N+1,J)=P(LPIN,J)
20426 V(N+1,J)=V(LPIN,J)
20427 540 CONTINUE
20428 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20429 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20430 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20431 IF(LESD.EQ.2) THEN
20432 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20433 ELSE
20434 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20435 ENDIF
20436 ENDIF
20437
20438 RETURN
20439 END
20440
20441C*********************************************************************
20442
20443C...PYMIGN
20444C...Initializes treatment of new multiple interactions scenario,
20445C...selects kinematics of hardest interaction if low-pT physics
20446C...included in run, and generates all non-hardest interactions.
20447
20448 SUBROUTINE PYMIGN(MMUL)
20449
20450C...Double precision and integer declarations.
20451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20452 IMPLICIT INTEGER(I-N)
20453 INTEGER PYK,PYCHGE,PYCOMP
20454 EXTERNAL PYALPS
20455 DOUBLE PRECISION PYALPS
20456C...Commonblocks.
20457 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20458 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20459 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20460 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20461 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20462 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20463 COMMON/PYINT1/MINT(400),VINT(400)
20464 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20465 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20466 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20467 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20468 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20469 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20470 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20471 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20472 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20473C...Local arrays and saved variables.
20474 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20475 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20476 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20477 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20478 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20479
20480C...Initialization of multiple interaction treatment.
20481 IF(MMUL.EQ.1) THEN
20482 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20483 ISUB=96
20484 MINT(1)=96
20485 VINT(63)=0D0
20486 VINT(64)=0D0
20487 VINT(143)=1D0
20488 VINT(144)=1D0
20489
20490C...Loop over phase space points: xT2 choice in 20 bins.
20491 100 SIGSUM=0D0
20492 DO 120 IXT2=1,20
20493 NMUL(IXT2)=MSTP(83)
20494 SIGM(IXT2)=0D0
20495 DO 110 ITRY=1,MSTP(83)
20496 RSCA=0.05D0*((21-IXT2)-PYR(0))
20497 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20498 XT2=MAX(0.01D0*VINT(149),XT2)
20499 VINT(25)=XT2
20500
20501C...Choose tau and y*. Calculate cos(theta-hat).
20502 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20503 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20504 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20505 ELSE
20506 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20507 ENDIF
20508 VINT(21)=TAU
20509 CALL PYKLIM(2)
20510 RYST=PYR(0)
20511 MYST=1
20512 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20513 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20514 CALL PYKMAP(2,MYST,PYR(0))
20515 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20516
20517C...Calculate differential cross-section.
20518 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20519 CALL PYSIGH(NCHN,SIGS)
20520 SIGM(IXT2)=SIGM(IXT2)+SIGS
20521 110 CONTINUE
20522 SIGSUM=SIGSUM+SIGM(IXT2)
20523 120 CONTINUE
20524 SIGSUM=SIGSUM/(20D0*MSTP(83))
20525
20526C...Reject result if sigma(parton-parton) is smaller than hadronic one.
20527 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
20528 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
20529 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
20530 PARP(82)=0.9D0*PARP(82)
20531 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
20532 & VINT(2)
20533 GOTO 100
20534 ENDIF
20535 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
20536 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
20537
20538C...Start iteration to find k factor.
20539 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
20540 P83A=(1D0-PARP(83))**2
20541 P83B=2D0*PARP(83)*(1D0-PARP(83))
20542 P83C=PARP(83)**2
20543 CQ2I=1D0/PARP(84)**2
20544 CQ2R=2D0/(1D0+PARP(84)**2)
20545 SO=0.5D0
20546 XI=0D0
20547 YI=0D0
20548 XF=0D0
20549 YF=0D0
20550 XK=0.5D0
20551 IIT=0
20552 130 IF(IIT.EQ.0) THEN
20553 XK=2D0*XK
20554 ELSEIF(IIT.EQ.1) THEN
20555 XK=0.5D0*XK
20556 ELSE
20557 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
20558 ENDIF
20559
20560C...Evaluate overlap integrals. Find where to divide the b range.
20561 IF(MSTP(82).EQ.2) THEN
20562 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
20563 SOP=SP/PARU(1)
20564 ELSE
20565 IF(MSTP(82).EQ.3) THEN
20566 DELTAB=0.02D0
20567 ELSEIF(MSTP(82).EQ.4) THEN
20568 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
20569 ELSE
20570 POWIP=MAX(0.4D0,PARP(83))
20571 RPWIP=2D0/POWIP-1D0
20572 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
20573 SO=0D0
20574 ENDIF
20575 SP=0D0
20576 SOP=0D0
20577 BSP=0D0
20578 SOHIGH=0D0
20579 IBDIV=0
20580 B=-0.5D0*DELTAB
20581 140 B=B+DELTAB
20582 IF(MSTP(82).EQ.3) THEN
20583 OV=EXP(-B**2)/PARU(2)
20584 ELSEIF(MSTP(82).EQ.4) THEN
20585 OV=(P83A*EXP(-MIN(50D0,B**2))+
20586 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20587 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20588 ELSE
20589 OV=EXP(-B**POWIP)/PARU(2)
20590 SO=SO+PARU(2)*B*DELTAB*OV
20591 ENDIF
20592 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
20593 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
20594 SP=SP+PARU(2)*B*DELTAB*PACC
20595 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
20596 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
20597 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
20598 IBDIV=1
20599 BDIV=B+0.5D0*DELTAB
20600 ENDIF
20601 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
20602 ENDIF
20603 YK=PARU(1)*XK*SO/SP
20604
20605C...Continue iteration until convergence.
20606 IF(YK.LT.YKE) THEN
20607 XI=XK
20608 YI=YK
20609 IF(IIT.EQ.1) IIT=2
20610 ELSE
20611 XF=XK
20612 YF=YK
20613 IF(IIT.EQ.0) IIT=1
20614 ENDIF
20615 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
20616
20617C...Store some results for subsequent use.
20618 BAVG=BSP/SP
20619 VINT(145)=SIGSUM
20620 VINT(146)=SOP/SO
20621 VINT(147)=SOP/SP
20622 VNT145=VINT(145)
20623 VNT146=VINT(146)
20624 VNT147=VINT(147)
20625C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
20626 PIK=(VNT146/VNT147)*YKE
20627
20628C...Find relative weight for low and high impact parameter..
20629 PLOWB=PARU(1)*BDIV**2
20630 IF(MSTP(82).EQ.3) THEN
20631 PHIGHB=PIK*0.5*EXP(-BDIV**2)
20632 ELSEIF(MSTP(82).EQ.4) THEN
20633 S4A=P83A*EXP(-BDIV**2)
20634 S4B=P83B*EXP(-BDIV**2*CQ2R)
20635 S4C=P83C*EXP(-BDIV**2*CQ2I)
20636 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
20637 ELSEIF(PARP(83).GE.1.999D0) THEN
20638 PHIGHB=PIK*SOHIGH
20639 B2RPDV=BDIV**POWIP
20640 ELSE
20641 PHIGHB=PIK*SOHIGH
20642 B2RPDV=BDIV**POWIP
20643 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
20644 ENDIF
20645 PALLB=PLOWB+PHIGHB
20646
20647C...Initialize iteration in xT2 for hardest interaction.
20648 ELSEIF(MMUL.EQ.2) THEN
20649 VINT(145)=VNT145
20650 VINT(146)=VNT146
20651 VINT(147)=VNT147
20652 IF(MSTP(82).LE.0) THEN
20653 ELSEIF(MSTP(82).EQ.1) THEN
20654 XT2=1D0
20655 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20656 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20657 & VINT(317)/(VINT(318)*VINT(320))
20658 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20659 ELSEIF(MSTP(82).EQ.2) THEN
20660 XT2=1D0
20661 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20662 & VINT(149)*(1D0+VINT(149))
20663 ELSE
20664 XC2=4D0*CKIN(3)**2/VINT(2)
20665 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
20666 ENDIF
20667
20668C...Select impact parameter for hardest interaction.
20669 IF(MSTP(82).LE.2) RETURN
20670 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
20671C...Treatment in low b region.
20672 MINT(39)=1
20673 B=BDIV*SQRT(PYR(0))
20674 IF(MSTP(82).EQ.3) THEN
20675 OV=EXP(-B**2)/PARU(2)
20676 ELSEIF(MSTP(82).EQ.4) THEN
20677 OV=(P83A*EXP(-MIN(50D0,B**2))+
20678 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20679 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20680 ELSE
20681 OV=EXP(-B**POWIP)/PARU(2)
20682 ENDIF
20683 VINT(148)=OV/VNT147
20684 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
20685 XT2=1D0
20686 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
20687 & VINT(149)*(1D0+VINT(149))
20688 ELSE
20689C...Treatment in high b region.
20690 MINT(39)=2
20691 IF(MSTP(82).EQ.3) THEN
20692 B=SQRT(BDIV**2-LOG(PYR(0)))
20693 OV=EXP(-B**2)/PARU(2)
20694 ELSEIF(MSTP(82).EQ.4) THEN
20695 S4RNDM=PYR(0)*(S4A+S4B+S4C)
20696 IF(S4RNDM.LT.S4A) THEN
20697 B=SQRT(BDIV**2-LOG(PYR(0)))
20698 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
20699 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
20700 ELSE
20701 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
20702 ENDIF
20703 OV=(P83A*EXP(-MIN(50D0,B**2))+
20704 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
20705 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
20706 ELSEIF(PARP(83).GE.1.999D0) THEN
20707 144 B2RPW=B2RPDV-LOG(PYR(0))
20708 ACCIP=(B2RPW/B2RPDV)**RPWIP
20709 IF(ACCIP.LT.PYR(0)) GOTO 144
20710 OV=EXP(-B2RPW)/PARU(2)
20711 B=B2RPW**(1D0/POWIP)
20712 ELSE
20713 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
20714 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
20715 IF(ACCIP.LT.PYR(0)) GOTO 146
20716 OV=EXP(-B2RPW)/PARU(2)
20717 B=B2RPW**(1D0/POWIP)
20718 ENDIF
20719 VINT(148)=OV/VNT147
20720 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
20721 ENDIF
20722 IF(PACC.LT.PYR(0)) GOTO 142
20723 VINT(139)=B/BAVG
20724
20725 ELSEIF(MMUL.EQ.3) THEN
20726C...Low-pT or multiple interactions (first semihard interaction):
20727C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
20728C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
20729 ISUB=MINT(1)
20730 VINT(145)=VNT145
20731 VINT(146)=VNT146
20732 VINT(147)=VNT147
20733 IF(MSTP(82).LE.0) THEN
20734 XT2=0D0
20735 ELSEIF(MSTP(82).EQ.1) THEN
20736 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20737C...Use with "Sudakov" for low b values when impact parameter dependence.
20738 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
20739 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
20740 & VINT(149)))).GT.PYR(0)) XT2=1D0
20741 IF(XT2.GE.1D0) THEN
20742 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
20743 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
20744 & VINT(149)
20745 ELSE
20746 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
20747 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
20748 & VINT(149)
20749 ENDIF
20750 XT2=MAX(0.01D0*VINT(149),XT2)
20751C...Use without "Sudakov" for high b values when impact parameter dep.
20752 ELSE
20753 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
20754 & PYR(0)*(1D0-XC2))-VINT(149)
20755 XT2=MAX(0.01D0*VINT(149),XT2)
20756 ENDIF
20757 VINT(25)=XT2
20758
20759C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
20760 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
20761 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
20762 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
20763 ISUB=95
20764 MINT(1)=ISUB
20765 VINT(21)=1D-12*VINT(149)
20766 VINT(22)=0D0
20767 VINT(23)=0D0
20768 VINT(25)=1D-12*VINT(149)
20769
20770 ELSE
20771C...Multiple interactions (first semihard interaction).
20772C...Choose tau and y*. Calculate cos(theta-hat).
20773 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20774 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20775 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20776 ELSE
20777 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20778 ENDIF
20779 VINT(21)=TAU
20780 CALL PYKLIM(2)
20781 RYST=PYR(0)
20782 MYST=1
20783 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20784 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20785 CALL PYKMAP(2,MYST,PYR(0))
20786 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20787 ENDIF
20788 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
20789
20790C...Store results of cross-section calculation.
20791 ELSEIF(MMUL.EQ.4) THEN
20792 ISUB=MINT(1)
20793 VINT(145)=VNT145
20794 VINT(146)=VNT146
20795 VINT(147)=VNT147
20796 XTS=VINT(25)
20797 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
20798 IF(ISET(ISUB).EQ.2)
20799 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
20800 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
20801 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
20802 & (XTS+VINT(149))))
20803 IRBIN=INT(1D0+20D0*RBIN)
20804 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
20805 NMUL(IRBIN)=NMUL(IRBIN)+1
20806 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
20807 ENDIF
20808
20809C...Choose impact parameter if not already done.
20810 ELSEIF(MMUL.EQ.5) THEN
20811 ISUB=MINT(1)
20812 VINT(145)=VNT145
20813 VINT(146)=VNT146
20814 VINT(147)=VNT147
20815 150 IF(MINT(39).GT.0) THEN
20816 ELSEIF(MSTP(82).EQ.3) THEN
20817 EXPB2=PYR(0)
20818 B2=-LOG(PYR(0))
20819 VINT(148)=EXPB2/(PARU(2)*VNT147)
20820 VINT(139)=SQRT(B2)/BAVG
20821 ELSEIF(MSTP(82).EQ.4) THEN
20822 RTYPE=PYR(0)
20823 IF(RTYPE.LT.P83A) THEN
20824 B2=-LOG(PYR(0))
20825 ELSEIF(RTYPE.LT.P83A+P83B) THEN
20826 B2=-LOG(PYR(0))/CQ2R
20827 ELSE
20828 B2=-LOG(PYR(0))/CQ2I
20829 ENDIF
20830 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
20831 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
20832 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
20833 VINT(139)=SQRT(B2)/BAVG
20834 ELSEIF(PARP(83).GE.1.999D0) THEN
20835 POWIP=MAX(2D0,PARP(83))
20836 RPWIP=2D0/POWIP-1D0
20837 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
20838 160 IF(PYR(0).LT.PROB1) THEN
20839 B2RPW=PYR(0)**(0.5D0*POWIP)
20840 ACCIP=EXP(-B2RPW)
20841 ELSE
20842 B2RPW=1D0-LOG(PYR(0))
20843 ACCIP=B2RPW**RPWIP
20844 ENDIF
20845 IF(ACCIP.LT.PYR(0)) GOTO 160
20846 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20847 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20848 ELSE
20849 POWIP=MAX(0.4D0,PARP(83))
20850 RPWIP=2D0/POWIP-1D0
20851 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
20852 170 IF(PYR(0).LT.PROB1) THEN
20853 B2RPW=2D0*RPWIP*PYR(0)
20854 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
20855 ELSE
20856 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
20857 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
20858 ENDIF
20859 IF(ACCIP.LT .PYR(0)) GOTO 170
20860 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
20861 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
20862 ENDIF
20863
20864C...Multiple interactions (variable impact parameter) : reject with
20865C...probability exp(-overlap*cross-section above pT/normalization).
20866C...Does not apply to low-b region, where "Sudakov" already included.
20867 VINT(150)=1D0
20868 IF(MINT(39).NE.1) THEN
20869 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20870 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20871 DO 180 IBIN=IRBIN+1,20
20872 RNCOR=RNCOR+NMUL(IBIN)
20873 SIGCOR=SIGCOR+SIGM(IBIN)
20874 180 CONTINUE
20875 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20876 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20877 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20878 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20879 ENDIF
20880 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20881 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20882 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20883 IF(VINT(150).LT.PYR(0)) GOTO 150
20884 VINT(150)=1D0
20885 ENDIF
20886
20887C...Generate additional multiple semihard interactions.
20888 ELSEIF(MMUL.EQ.6) THEN
20889
20890C...Save data for hardest initeraction, to be restored.
20891 ISUBSV=MINT(1)
20892 VINT(145)=VNT145
20893 VINT(146)=VNT146
20894 VINT(147)=VNT147
20895 M13SV=MINT(13)
20896 M14SV=MINT(14)
20897 M15SV=MINT(15)
20898 M16SV=MINT(16)
20899 M21SV=MINT(21)
20900 M22SV=MINT(22)
20901 DO 190 J=11,80
20902 VINTSV(J)=VINT(J)
20903 190 CONTINUE
20904 V141SV=VINT(141)
20905 V142SV=VINT(142)
20906
20907C...Store data on hardest interaction.
20908 XMI(1,1)=VINT(141)
20909 XMI(2,1)=VINT(142)
20910 PT2MI(1)=VINT(54)
20911 IMISEP(0)=MINT(84)
20912 IMISEP(1)=N
20913
20914C...Change process to generate; sum of x values so far.
20915 ISUB=96
20916 MINT(1)=96
20917 VINT(143)=1D0-VINT(141)
20918 VINT(144)=1D0-VINT(142)
20919 VINT(151)=0D0
20920 VINT(152)=0D0
20921
20922C...Initialize factors for PDF reshaping.
20923 DO 230 JS=1,2
20924 KFBEAM=MINT(10+JS)
20925 KFABM=IABS(KFBEAM)
20926 KFSBM=ISIGN(1,KFBEAM)
20927
20928C...Zero flavour content of incoming beam particle.
20929 KFIVAL(JS,1)=0
20930 KFIVAL(JS,2)=0
20931 KFIVAL(JS,3)=0
20932C...Flavour content of baryon.
20933 IF(KFABM.GT.1000) THEN
20934 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
20935 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
20936 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
20937C...Flavour content of pi+-, K+-.
20938 ELSEIF(KFABM.EQ.211) THEN
20939 KFIVAL(JS,1)=KFSBM*2
20940 KFIVAL(JS,2)=-KFSBM
20941 ELSEIF(KFABM.EQ.321) THEN
20942 KFIVAL(JS,1)=-KFSBM*3
20943 KFIVAL(JS,2)=KFSBM*2
20944C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
20945 ENDIF
20946
20947C...Zero initial valence and companion content.
20948 DO 200 IFL=-6,6
20949 NVC(JS,IFL)=0
20950 200 CONTINUE
20951
20952C...Initiate listing of all incoming partons from two sides.
20953 NMI(JS)=0
20954 DO 210 I=MINT(84)+1,N
20955 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
20956 IMI(JS,1,1)=I
20957 IMI(JS,1,2)=0
20958 ENDIF
20959 210 CONTINUE
20960
20961C...Decide whether quarks in hard scattering were valence or sea.
20962 IFL=K(IMI(JS,1,1),2)
20963 IF (IABS(IFL).GT.6) GOTO 230
20964
20965C...Get PDFs at X and Q2 of the parton shower initiator for the
20966C...hard scattering.
20967 X=VINT(140+JS)
20968 IF(MSTP(61).GE.1) THEN
20969 Q2=PARP(62)**2
20970 ELSE
20971 Q2=VINT(54)
20972 ENDIF
20973C...Note: XPSVC = x*pdf.
20974 MINT(30)=JS
20975C.... ALICE
20976C.... Store side in MINT(124)
20977 MINT(124) = JS
20978C....
20979 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
20980 SEA=XPSVC(IFL,-1)
20981 VAL=XPSVC(IFL,0)
20982
20983C...Decide (Extra factor x cancels in the division).
20984 RVCS=PYR(0)*(SEA+VAL)
20985 IVNOW=1
20986 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
20987C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
20988 IVNOW=0
20989 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
20990 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
20991 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
20992 IF(KFIVAL(JS,1).EQ.0) THEN
20993 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
20994 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
20995 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
20996 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
20997 ENDIF
20998 IF(IVNOW.EQ.0) GOTO 220
20999C...Mark valence.
21000 IMI(JS,1,2)=0
21001C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21002 IF(KFIVAL(JS,1).EQ.0) THEN
21003 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21004 KFIVAL(JS,1)=IFL
21005 KFIVAL(JS,2)=-IFL
21006 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21007 KFIVAL(JS,1)=IFL
21008 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21009 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21010 ENDIF
21011 ENDIF
21012
21013C...If sea, add opposite sign companion parton. Store X and I.
21014 ELSE
21015 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21016 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21017C...Set pointer to companion
21018 IMI(JS,1,2)=-NVC(JS,-IFL)
21019 ENDIF
21020 230 CONTINUE
21021
21022C...Update counter number of multiple interactions.
21023 NMI(1)=1
21024 NMI(2)=1
21025
21026C...Set up starting values for iteration in xT2.
21027 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21028 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21029 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21030 & ISUBSV.NE.96)) THEN
21031 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21032 ELSE
21033 XT2=VINT(25)
21034 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21035 IF(ISET(ISUBSV).EQ.2)
21036 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21037 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21038 ENDIF
21039 IF(MSTP(82).LE.1) THEN
21040 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21041 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21042 & VINT(317)/(VINT(318)*VINT(320))
21043 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21044 ELSE
21045 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21046 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21047 ENDIF
21048 VINT(63)=0D0
21049 VINT(64)=0D0
21050
21051C...Iterate downwards in xT2.
21052 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21053 XT2=0D0
21054 GOTO 440
21055 ELSEIF(MSTP(82).LE.1) THEN
21056 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21057 IF(XT2.LT.VINT(149)) GOTO 440
21058 ELSE
21059 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21060 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21061 & LOG(PYR(0)))-VINT(149)
21062 IF(XT2.LE.0D0) GOTO 440
21063 XT2=MAX(0.01D0*VINT(149),XT2)
21064 ENDIF
21065 VINT(25)=XT2
21066
21067C...Choose tau and y*. Calculate cos(theta-hat).
21068 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21069 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21070 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21071 ELSE
21072 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21073 ENDIF
21074 VINT(21)=TAU
21075C...New: require shat > 1.
21076 IF(TAU*VINT(2).LT.1D0) GOTO 240
21077 CALL PYKLIM(2)
21078 RYST=PYR(0)
21079 MYST=1
21080 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21081 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21082 CALL PYKMAP(2,MYST,PYR(0))
21083 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21084
21085C...Check that x not used up. Accept or reject kinematical variables.
21086 X1M=SQRT(TAU)*EXP(VINT(22))
21087 X2M=SQRT(TAU)*EXP(-VINT(22))
21088 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21089 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21090 CALL PYSIGH(NCHN,SIGS)
21091 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21092 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21093 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21094
21095C...Reset K, P and V vectors.
21096 DO 260 I=N+1,N+4
21097 DO 250 J=1,5
21098 K(I,J)=0
21099 P(I,J)=0D0
21100 V(I,J)=0D0
21101 250 CONTINUE
21102 260 CONTINUE
21103 PT=0.5D0*VINT(1)*SQRT(XT2)
21104
21105C...Choose flavour of reacting partons (and subprocess).
21106 RSIGS=SIGS*PYR(0)
21107 DO 270 ICHN=1,NCHN
21108 KFL1=ISIG(ICHN,1)
21109 KFL2=ISIG(ICHN,2)
21110 ICONMI=ISIG(ICHN,3)
21111 RSIGS=RSIGS-SIGH(ICHN)
21112 IF(RSIGS.LE.0D0) GOTO 280
21113 270 CONTINUE
21114
21115C...Reassign to appropriate process codes.
21116 280 ISUBMI=ICONMI/10
21117 ICONMI=MOD(ICONMI,10)
21118
21119C...Choose new quark flavour for annihilation graphs
21120 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21121 SH=TAU*VINT(2)
21122 CALL PYWIDT(21,SH,WDTP,WDTE)
21123 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21124 DO 300 I=1,MDCY(21,3)
21125 KFLF=KFDP(I+MDCY(21,2)-1,1)
21126 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21127 IF(RKFL.LE.0D0) GOTO 310
21128 300 CONTINUE
21129 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21130 IF(KFLF.GE.4) GOTO 290
21131 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21132 KFLF=4
21133 ICONMI=ICONMI-2
21134 ELSEIF(ISUBMI.EQ.53) THEN
21135 KFLF=5
21136 ICONMI=ICONMI-4
21137 ENDIF
21138 ENDIF
21139
21140C...Final state flavours and colour flow: default values
21141 JS=1
21142 KFL3=KFL1
21143 KFL4=KFL2
21144 KCC=20
21145 KCS=ISIGN(1,KFL1)
21146
21147 IF(ISUBMI.EQ.11) THEN
21148C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21149 KCC=ICONMI
21150 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21151
21152 ELSEIF(ISUBMI.EQ.12) THEN
21153C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21154 KFL3=ISIGN(KFLF,KFL1)
21155 KFL4=-KFL3
21156 KCC=4
21157
21158 ELSEIF(ISUBMI.EQ.13) THEN
21159C...f + fbar -> g + g; th arbitrary
21160 KFL3=21
21161 KFL4=21
21162 KCC=ICONMI+4
21163
21164 ELSEIF(ISUBMI.EQ.28) THEN
21165C...f + g -> f + g; th = (p(f)-p(f))**2
21166 IF(KFL1.EQ.21) JS=2
21167 KCC=ICONMI+6
21168 IF(KFL1.EQ.21) KCC=KCC+2
21169 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21170 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21171
21172 ELSEIF(ISUBMI.EQ.53) THEN
21173C...g + g -> f + fbar; th arbitrary
21174 KCS=(-1)**INT(1.5D0+PYR(0))
21175 KFL3=ISIGN(KFLF,KCS)
21176 KFL4=-KFL3
21177 KCC=ICONMI+10
21178
21179 ELSEIF(ISUBMI.EQ.68) THEN
21180C...g + g -> g + g; th arbitrary
21181 KCC=ICONMI+12
21182 KCS=(-1)**INT(1.5D0+PYR(0))
21183 ENDIF
21184
21185C...Store flavours of scattering.
21186 MINT(13)=KFL1
21187 MINT(14)=KFL2
21188 MINT(15)=KFL1
21189 MINT(16)=KFL2
21190 MINT(21)=KFL3
21191 MINT(22)=KFL4
21192
21193C...Set flavours and mothers of scattering partons.
21194 K(N+1,1)=14
21195 K(N+2,1)=14
21196 K(N+3,1)=3
21197 K(N+4,1)=3
21198 K(N+1,2)=KFL1
21199 K(N+2,2)=KFL2
21200 K(N+3,2)=KFL3
21201 K(N+4,2)=KFL4
21202 K(N+1,3)=MINT(83)+1
21203 K(N+2,3)=MINT(83)+2
21204 K(N+3,3)=N+1
21205 K(N+4,3)=N+2
21206
21207C...Store colour connection indices.
21208 DO 320 J=1,2
21209 JC=J
21210 IF(KCS.EQ.-1) JC=3-J
21211 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21212 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21213 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21214 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21215 320 CONTINUE
21216
21217C...Store incoming and outgoing partons in their CM-frame.
21218 SHR=SQRT(TAU)*VINT(1)
21219 P(N+1,3)=0.5D0*SHR
21220 P(N+1,4)=0.5D0*SHR
21221 P(N+2,3)=-0.5D0*SHR
21222 P(N+2,4)=0.5D0*SHR
21223 P(N+3,5)=PYMASS(K(N+3,2))
21224 P(N+4,5)=PYMASS(K(N+4,2))
21225 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21226 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21227 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21228 P(N+4,4)=SHR-P(N+3,4)
21229 P(N+4,3)=-P(N+3,3)
21230
21231C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21232 PHI=PARU(2)*PYR(0)
21233 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21234
21235C...Set up default values before showers.
21236 MINT(31)=MINT(31)+1
21237 IPU1=N+1
21238 IPU2=N+2
21239 IPU3=N+3
21240 IPU4=N+4
21241 VINT(141)=VINT(41)
21242 VINT(142)=VINT(42)
21243 N=N+4
21244
21245C...Showering of initial state partons (optional).
21246C...Note: no showering of final state partons here; it comes later.
21247 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21248 MINT(51)=0
21249 ALAMSV=PARJ(81)
21250 PARJ(81)=PARP(72)
21251 NSAV=N
21252 DO 340 I=1,4
21253 DO 330 J=1,5
21254 KSAV(I,J)=K(N-4+I,J)
21255 PSAV(I,J)=P(N-4+I,J)
21256 330 CONTINUE
21257 340 CONTINUE
21258 CALL PYSSPA(IPU1,IPU2)
21259 PARJ(81)=ALAMSV
21260C...If shower failed then restore to situation before shower.
21261 IF(MINT(51).GE.1) THEN
21262 N=NSAV
21263 DO 360 I=1,4
21264 DO 350 J=1,5
21265 K(N-4+I,J)=KSAV(I,J)
21266 P(N-4+I,J)=PSAV(I,J)
21267 350 CONTINUE
21268 360 CONTINUE
21269 IPU1=N-3
21270 IPU2=N-2
21271 VINT(141)=VINT(41)
21272 VINT(142)=VINT(42)
21273 ENDIF
21274 ENDIF
21275
21276C...Keep track of loose colour ends and information on scattering.
21277 370 IMI(1,MINT(31),1)=IPU1
21278 IMI(2,MINT(31),1)=IPU2
21279 IMI(1,MINT(31),2)=0
21280 IMI(2,MINT(31),2)=0
21281 XMI(1,MINT(31))=VINT(141)
21282 XMI(2,MINT(31))=VINT(142)
21283 PT2MI(MINT(31))=VINT(54)
21284 IMISEP(MINT(31))=N
21285
21286C...Decide whether quarks in last scattering were valence, companion or
21287C...sea.
21288 DO 430 JS=1,2
21289 KFBEAM=MINT(10+JS)
21290 KFSBM=ISIGN(1,MINT(10+JS))
21291 IFL=K(IMI(JS,MINT(31),1),2)
21292 IMI(JS,MINT(31),2)=0
21293 IF (IABS(IFL).GT.6) GOTO 430
21294
21295C...Get PDFs at X and Q2 of the parton shower initiator for the
21296C...last scattering. At this point VINT(143:144) do not yet
21297C...include the scattered x values VINT(141:142).
21298 X=VINT(140+JS)/VINT(142+JS)
21299 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21300 Q2=PARP(62)**2
21301 ELSE
21302 Q2=VINT(54)
21303 ENDIF
21304C...Note: XPSVC = x*pdf.
21305 MINT(30)=JS
21306C.... ALICE
21307C.... Store side in MINT(124)
21308 MINT(124) = JS
21309C....
21310 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21311 SEA=XPSVC(IFL,-1)
21312 VAL=XPSVC(IFL,0)
21313 CMP=0D0
21314 DO 380 IVC=1,NVC(JS,IFL)
21315 CMP=CMP+XPSVC(IFL,IVC)
21316 380 CONTINUE
21317
21318C...Decide (Extra factor x cancels in the dvision).
21319 RVCS=PYR(0)*(SEA+VAL+CMP)
21320 IVNOW=1
21321 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21322C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21323 IVNOW=0
21324 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21325 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21326 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21327 IF(KFIVAL(JS,1).EQ.0) THEN
21328 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21329 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21330 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21331 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21332 ELSE
21333 DO 400 I1=1,NMI(JS)
21334 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21335 & IVNOW=IVNOW-1
21336 400 CONTINUE
21337 ENDIF
21338 IF(IVNOW.EQ.0) GOTO 390
21339C...Mark valence.
21340 IMI(JS,MINT(31),2)=0
21341C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21342 IF(KFIVAL(JS,1).EQ.0) THEN
21343 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21344 KFIVAL(JS,1)=IFL
21345 KFIVAL(JS,2)=-IFL
21346 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21347 KFIVAL(JS,1)=IFL
21348 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21349 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21350 ENDIF
21351 ENDIF
21352
21353 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21354C...If sea, add opposite sign companion parton. Store X and I.
21355 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21356 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21357C...Set pointer to companion
21358 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21359 ELSE
21360C...If companion, decide which one.
21361 CMPSUM=VAL+SEA
21362 ISEL=0
21363 410 ISEL=ISEL+1
21364 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21365 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21366C...Find original sea (anti-)quark:
21367 IASSOC=0
21368 DO 420 I1=1,NMI(JS)
21369 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21370 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21371 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21372 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21373 ENDIF
21374 420 CONTINUE
21375C...Change X to what associated companion had, so that the correct
21376C...amount of momentum can be subtracted from the companion sum below.
21377 X=XASSOC(JS,IFL,ISEL)
21378C...Mark companion read.
21379 XASSOC(JS,IFL,ISEL)=0D0
21380 ENDIF
21381 430 CONTINUE
21382
21383C...Global statistics.
21384 MINT(351)=MINT(351)+1
21385 VINT(351)=VINT(351)+PT
21386 IF (MINT(351).EQ.1) VINT(356)=PT
21387
21388C...Update remaining energy and other counters.
21389 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21390 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21391 MINT(51)=1
21392 RETURN
21393 ENDIF
21394 NMI(1)=NMI(1)+1
21395 NMI(2)=NMI(2)+1
21396 VINT(151)=VINT(151)+VINT(41)
21397 VINT(152)=VINT(152)+VINT(42)
21398 VINT(143)=VINT(143)-VINT(141)
21399 VINT(144)=VINT(144)-VINT(142)
21400
21401C...Iterate, with more interactions allowed.
21402 IF(MINT(31).LT.240) GOTO 240
21403 440 CONTINUE
21404
21405C...Restore saved quantities for hardest interaction.
21406 MINT(1)=ISUBSV
21407 MINT(13)=M13SV
21408 MINT(14)=M14SV
21409 MINT(15)=M15SV
21410 MINT(16)=M16SV
21411 MINT(21)=M21SV
21412 MINT(22)=M22SV
21413 DO 450 J=11,80
21414 VINT(J)=VINTSV(J)
21415 450 CONTINUE
21416 VINT(141)=V141SV
21417 VINT(142)=V142SV
21418
21419 ENDIF
21420
21421C...Format statements for printout.
21422 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21423 &'actions for MSTP(82) =',I2,' ******')
21424 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21425 &D9.2,' mb: rejected')
21426 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21427 &D9.2,' mb: accepted')
21428
21429 RETURN
21430 END
21431
21432C*********************************************************************
21433
21434C...PYMIHK
21435C...Finds left-behind remnant flavour content and hooks up
21436C...the colour flow between the hard scattering and remnants
21437
21438 SUBROUTINE PYMIHK
21439
21440C...Double precision and integer declarations.
21441 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21442 IMPLICIT INTEGER(I-N)
21443 INTEGER PYK,PYCHGE,PYCOMP
21444C...The event record
21445 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21446C...Parameters
21447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21450 COMMON/PYINT1/MINT(400),VINT(400)
21451C...The common block of dangling ends
21452 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21453 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21454 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21455 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21456C...Local variables
21457 PARAMETER (NERSIZ=4000)
21458 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21459 & ,MACCPT
21460 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21461 SAVE /PYCBLS/,/PYCTAG/
21462 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21463 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21464 DATA NERRPR/0/
21465 SAVE NERRPR
21466 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)
21467
21468C...Set up error checkers
21469 IBOOST=0
21470
21471C...Initialize colour arrays: MCO (Original) and MCT (New)
21472 DO 110 I=MINT(84)+1,NERSIZ
21473 DO 100 JC=1,2
21474 MCT(I,JC)=0
21475 MCO(I,JC)=0
21476 100 CONTINUE
21477C...Also zero colour tracing information, if existed.
21478 IF (I.LE.N) THEN
21479 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21480 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21481 ENDIF
21482 110 CONTINUE
21483
21484C...Initialize colour tag collapse arrays:
21485C...JCCO (Original) and JCCN (New).
21486 DO 130 MG=MINT(84)+1,NERSIZ
21487 DO 120 JC=1,2
21488 JCCO(MG,JC)=0
21489 JCCN(MG,JC)=0
21490 120 CONTINUE
21491 130 CONTINUE
21492
21493C...Zero gluon insertion array
21494 DO 150 IM=1,1000
21495 DO 140 J=1,3
21496 INSR(IM,J)=0
21497 140 CONTINUE
21498 150 CONTINUE
21499
21500C...Compute hard scattering system rapidities
21501 IF (MSTP(89).EQ.1) THEN
21502 DO 160 IM=1,240
21503 IF (IM.LE.MINT(31)) THEN
21504 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21505 ELSE
21506C...Set (unsigned) rapidity = 100 for beam remnant systems.
21507 YMI(IM)=100D0
21508 ENDIF
21509 160 CONTINUE
21510 ENDIF
21511
21512C...Treat each side separately
21513 DO 290 JS=1,2
21514
21515C...Initialize side.
21516 NG(JS)=0
21517 JV=0
21518 KFS=ISIGN(1,MINT(10+JS))
21519
21520C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
21521 IF(KFIVAL(JS,1).EQ.0) THEN
21522 IF(MINT(10+JS).EQ.111) THEN
21523 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
21524 KFIVAL(JS,2)=-KFIVAL(JS,1)
21525 ELSEIF(MINT(10+JS).EQ.22) THEN
21526 PYRKF=PYR(0)
21527 KFIVAL(JS,1)=1
21528 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
21529 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
21530 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
21531 KFIVAL(JS,2)=-KFIVAL(JS,1)
21532 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
21533 IF(PYR(0).GT.0.5D0) THEN
21534 KFIVAL(JS,1)=1
21535 KFIVAL(JS,2)=-3
21536 ELSE
21537 KFIVAL(JS,1)=3
21538 KFIVAL(JS,2)=-1
21539 ENDIF
21540 ENDIF
21541 ENDIF
21542
21543C...Initialize beam remnant sea and valence content flavour by flavour.
21544 NVSUM(JS)=0
21545 NBRTOT(JS)=0
21546 DO 210 JFA=1,6
21547C...Count up original number of JFA valence quarks and antiquarks.
21548 NVALQ=0
21549 NVALQB=0
21550 NSEA=0
21551 DO 170 J=1,3
21552 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
21553 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
21554 170 CONTINUE
21555 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
21556C...Subtract kicked out valence and determine sea from flavour cons.
21557 DO 180 IM=1,NMI(JS)
21558 IFL = K(IMI(JS,IM,1),2)
21559 IFA = IABS(IFL)
21560 IFS = ISIGN(1,IFL)
21561 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21562C...Subtract K.O. valence quark from remainder.
21563 NVALQ=NVALQ-1
21564 JV=NVSUM(JS)-NVALQ-NVALQB
21565 IV(JS,JV)=IMI(JS,IM,1)
21566 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
21567C...Subtract K.O. valence antiquark from remainder.
21568 NVALQB=NVALQB-1
21569 JV=NVSUM(JS)-NVALQ-NVALQB
21570 IV(JS,JV)=IMI(JS,IM,1)
21571 ELSEIF (IFA.EQ.JFA) THEN
21572C...Outside sea without companion: add opposite sea flavour inside.
21573 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
21574 ENDIF
21575 180 CONTINUE
21576C...Check if space left in PYJETS for additional BR flavours
21577 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
21578 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
21579 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
21580 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
21581 MINT(51)=1
21582 RETURN
21583 ENDIF
21584C...Add required val+sea content to beam remnant.
21585 IF (NFLSUM.GT.0) THEN
21586 DO 200 IA=1,NFLSUM
21587C...Insert beam remnant quark as p.t. symbolic parton in ER.
21588 N=N+1
21589 DO 190 IX=1,5
21590 K(N,IX)=0
21591 P(N,IX)=0D0
21592 V(N,IX)=0D0
21593 190 CONTINUE
21594 K(N,1)=3
21595 K(N,2)=ISIGN(JFA,NSEA)
21596 IF (IA.LE.NVALQ) K(N,2)=JFA
21597 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
21598 K(N,3)=MINT(83)+JS
21599C...Also update NMI, IMI, and IV arrays.
21600 NMI(JS)=NMI(JS)+1
21601 IMI(JS,NMI(JS),1)=N
21602 IMI(JS,NMI(JS),2)=-1
21603 IF (IA.LE.NVALQ+NVALQB) THEN
21604 IMI(JS,NMI(JS),2)=0
21605 JV=JV+1
21606 IV(JS,JV)=IMI(JS,NMI(JS),1)
21607 ENDIF
21608 200 CONTINUE
21609 ENDIF
21610 210 CONTINUE
21611
21612 IM=0
21613 220 IM=IM+1
21614 IF (IM.LE.NMI(JS)) THEN
21615 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
21616 NG(JS)=NG(JS)+1
21617C...Add fictitious parent gluons for companion pairs.
21618 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
21619C...Randomly assign companions to sea quarks which have none.
21620 IF (IMI(JS,IM,2).LT.0) THEN
21621 IMC=PYR(0)*NMI(JS)
21622 230 IMC=MOD(IMC,NMI(JS))+1
21623 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
21624 IF (IMI(JS,IMC,2).GE.0) GOTO 230
21625 IMI(JS, IM,2) = IMI(JS,IMC,1)
21626 IMI(JS,IMC,2) = IMI(JS, IM,1)
21627 ENDIF
21628C...Add fictitious parent gluon
21629 N=N+1
21630 DO 240 IX=1,5
21631 K(N,IX)=0
21632 P(N,IX)=0D0
21633 V(N,IX)=0D0
21634 240 CONTINUE
21635 K(N,1)=14
21636 K(N,2)=21
21637 K(N,3)=MINT(83)+JS
21638C...Set gluon (anti-)colour daughter pointers
21639 K(N,4)=IMI(JS, IM,1)
21640 K(N,5)=IMI(JS, IM,2)
21641C...Set quark (anti-)colour parent pointers
21642 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
21643 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
21644C...Add gluon to IMI
21645 NMI(JS)=NMI(JS)+1
21646 IMI(JS,NMI(JS),1)=N
21647 IMI(JS,NMI(JS),2)=0
21648 ENDIF
21649 GOTO 220
21650 ENDIF
21651
21652C...If incoming (anti-)baryon, insert inside (anti-)junction.
21653C...Set up initial v-v-j-v configuration. Otherwise set up
21654C...mesonic v-vbar configuration
21655 IF (IABS(MINT(10+JS)).GT.1000) THEN
21656C...Determine junction type (1: B=1 2: B=-1)
21657 ITJUNC(JS) = (3-KFS)/2
21658C...Insert junction.
21659 N=N+1
21660 DO 250 IX=1,5
21661 K(N,IX)=0
21662 P(N,IX)=0D0
21663 V(N,IX)=0D0
21664 250 CONTINUE
21665C...Set special junction codes:
21666 K(N,1)=42
21667 K(N,2)=88
21668C...Set parent to side.
21669 K(N,3)=MINT(83)+JS
21670 K(N,4)=ITJUNC(JS)*MSTU(5)
21671 K(N,5)=0
21672C...Connect valence quarks to junction.
21673 MOUT(JS)=0
21674 MANTI=ITJUNC(JS)-1
21675C...Set (anti)colour mother = junction.
21676 DO 260 JV=1,3
21677 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
21678 & +MSTU(5)*N
21679C...Keep track of partons adjacent to junction:
21680 JST(JS,JV)=IV(JS,JV)
21681 260 CONTINUE
21682 ELSE
21683C...Mesons: set up initial q-qbar topology
21684 ITJUNC(JS)=0
21685 IF (K(IV(JS,1),2).GT.0) THEN
21686 IQ=IV(JS,1)
21687 IQBAR=IV(JS,2)
21688 ELSE
21689 IQ=IV(JS,2)
21690 IQBAR=IV(JS,1)
21691 ENDIF
21692 IV(JS,3)=0
21693 JST(JS,1)=IQ
21694 JST(JS,2)=IQBAR
21695 JST(JS,3)=0
21696 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
21697 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
21698C...Special for mesons. Insert gluon if BR empty.
21699 IF (NBRTOT(JS).EQ.0) THEN
21700 N=N+1
21701 DO 270 IX=1,5
21702 K(N,IX)=0
21703 P(N,IX)=0D0
21704 V(N,IX)=0D0
21705 270 CONTINUE
21706 K(N,1)=3
21707 K(N,2)=21
21708 K(N,3)=MINT(83)+JS
21709 K(N,4)=0
21710 K(N,5)=0
21711 NBRTOT(JS)=1
21712 NG(JS)=NG(JS)+1
21713C...Add gluon to IMI
21714 NMI(JS)=NMI(JS)+1
21715 IMI(JS,NMI(JS),1)=N
21716 IMI(JS,NMI(JS),2)=0
21717 ENDIF
21718 MOUT(JS)=0
21719 ENDIF
21720
21721C...Count up number of valence quarks outside BR.
21722 DO 280 JV=1,3
21723 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
21724 & MOUT(JS)=MOUT(JS)+1
21725 280 CONTINUE
21726
21727 290 CONTINUE
21728
21729C...Now both sides have been prepared in an initial vvjv (baryonic) or
21730C...v(g)vbar (mesonic) configuration.
21731
21732C...Create colour line tags starting from initiators.
21733 NCT=0
21734 DO 320 IM=1,MINT(31)
21735C...Consider each side in turn.
21736 DO 310 JS=1,2
21737 I1=IMI(JS,IM,1)
21738 I2=IMI(3-JS,IM,1)
21739 DO 300 JCS=4,5
21740 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
21741 & GOTO 300
21742 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
21743
21744 KCS=JCS
21745 CALL PYCTTR(I1,KCS,I2)
21746 IF(MINT(51).NE.0) RETURN
21747
21748 300 CONTINUE
21749 310 CONTINUE
21750 320 CONTINUE
21751
21752 DO 340 JS=1,2
21753C...Create colour tags for beam remnant partons.
21754 DO 330 IM=MINT(31)+1,NMI(JS)
21755 IP=IMI(JS,IM,1)
21756 IF (K(IP,2).NE.21) THEN
21757 JC=(3-ISIGN(1,K(IP,2)))/2
21758 IF (MCT(IP,JC).EQ.0) THEN
21759 NCT=NCT+1
21760 MCT(IP,JC)=NCT
21761 ENDIF
21762 ELSE
21763C...Gluons
21764 ICD=K(IP,4)
21765 IAD=K(IP,5)
21766 IF (ICD.NE.0) THEN
21767C...Fictituous gluons just inherit from their quark daughters.
21768 ICC=MCT(ICD,1)
21769 IAC=MCT(IAD,2)
21770 ELSE
21771C...Real beam remnant gluons get their own colours
21772 ICC=NCT+1
21773 IAC=NCT+2
21774 NCT=NCT+2
21775 ENDIF
21776 MCT(IP,1)=ICC
21777 MCT(IP,2)=IAC
21778 ENDIF
21779 330 CONTINUE
21780 340 CONTINUE
21781
21782C...Create colour tags for colour lines which are detached from the
21783C...initial state.
21784
21785 DO 360 MQGST=1,2
21786 DO 350 I=MINT(84)+1,N
21787
21788C...Look for coloured string endpoint, or (later) leftover gluon.
21789 IF (K(I,1).NE.3) GOTO 350
21790 KC=PYCOMP(K(I,2))
21791 IF(KC.EQ.0) GOTO 350
21792 KQ=KCHG(KC,2)
21793 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
21794
21795C...Pick up loose string end with no previous tag.
21796 KCS=4
21797 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
21798 IF(MCT(I,KCS-3).NE.0) GOTO 350
21799
21800 CALL PYCTTR(I,KCS,I)
21801 IF(MINT(51).NE.0) RETURN
21802
21803 350 CONTINUE
21804 360 CONTINUE
21805
21806C...Store original colour tags
21807 DO 370 I=MINT(84)+1,N
21808 MCO(I,1)=MCT(I,1)
21809 MCO(I,2)=MCT(I,2)
21810 370 CONTINUE
21811
21812C...Iteratively add gluons to already existing string pieces, enforcing
21813C...various possible orderings, and rejecting insertions that would give
21814C...rise to singlet gluons.
21815C...<kappa tau> normalization.
21816 RM0=1.5D0
21817 MRETRY=0
21818 PARP80=PARP(80)
21819
21820C...Set up simplified kinematics.
21821C...Boost hard interaction systems.
21822 IBOOST=IBOOST+1
21823 DO 380 IM=1,MINT(31)
21824 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
21825 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
21826 380 CONTINUE
21827C...Assign preliminary beam remnant momenta.
21828 DO 390 I=MINT(53)+1,N
21829 JS=K(I,3)
21830 P(I,1)=0D0
21831 P(I,2)=0D0
21832 IF (K(I,2).NE.88) THEN
21833 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
21834 P(I,3)=P(I,4)
21835 IF (JS.EQ.2) P(I,3)=-P(I,3)
21836 ELSE
21837C...Junctions are wildcards for the present.
21838 P(I,4)=0D0
21839 P(I,3)=0D0
21840 ENDIF
21841 390 CONTINUE
21842
21843C...Reset colour processing information.
21844 400 DO 410 I=MINT(84)+1,N
21845 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21846 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21847 410 CONTINUE
21848
21849 NCC=0
21850 DO 430 JS=1,2
21851C...If meson, without gluon in BR, collapse q-qbar colour tags:
21852 IF (ITJUNC(JS).EQ.0) THEN
21853 JC1=MCT(JST(JS,1),1)
21854 JC2=MCT(JST(JS,2),2)
21855 NCC=NCC+1
21856 JCCO(NCC,1)=MAX(JC1,JC2)
21857 JCCO(NCC,2)=MIN(JC1,JC2)
21858C...Collapse colour tags in event record
21859 DO 420 I=MINT(84)+1,N
21860 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
21861 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
21862 420 CONTINUE
21863 ENDIF
21864 430 CONTINUE
21865
21866 440 JS=1
21867 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
21868 IF (NG(JS).GT.0) THEN
21869 NOPT=0
21870 RLOPT=1D9
21871C...Start at random gluon (optimizes speed for random attachments)
21872 NMGL=0
21873 IMGL=PYR(0)*NMI(JS)+1
21874 450 IMGL=MOD(IMGL,NMI(JS))+1
21875 NMGL=NMGL+1
21876C...Only loop through NMI once (with upper limit to save time)
21877 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
21878 IGL = IMI(JS,IMGL,1)
21879C...If not gluon or if already connected, try next.
21880 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
21881 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
21882C...Now loop through all possible insertions of this gluon.
21883 NMP1=0
21884 IMP1=PYR(0)*NMI(JS)+1
21885 460 IMP1=MOD(IMP1,NMI(JS))+1
21886 NMP1=NMP1+1
21887 IF (IMP1.EQ.IMGL) GOTO 460
21888C...Only loop through NMI once (with upper limit to save time).
21889 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
21890 IP1 = IMI(JS,IMP1,1)
21891C...Try both colour mother and colour anti-mother.
21892C...Randomly select which one to try first.
21893 NANTI=0
21894 MANTI=PYR(0)*2
21895 470 MANTI=MOD(MANTI+1,2)
21896 NANTI=NANTI+1
21897 IF (NANTI.LE.2) THEN
21898 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
21899C...Reject if no appropriate mother (or if mother is fictitious
21900C...parent gluon.)
21901 IF (IP2.LE.0) GOTO 470
21902 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
21903C...Also reject if this link has already been tried.
21904 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21905 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
21906C...Set flag to indicate that this link has now been tried for this
21907C...gluon. IP2 may be junction, which has several mothers.
21908 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
21909 IF (K(IP2,2).NE.88) THEN
21910 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
21911 ENDIF
21912
21913C...JCG1: Original colour tag of gluon on IP1 side
21914C...JCG2: Original colour tag of gluon on IP2 side
21915C...JCP1: Original colour tag of IP1 on gluon side
21916C...JCP2: Original colour tag of IP2 on gluon side.
21917 JCG1=MCO(IGL,2-MANTI)
21918 JCG2=MCO(IGL,1+MANTI)
21919 JCP1=MCO(IP1,1+MANTI)
21920 JCP2=MCO(IP2,2-MANTI)
21921
21922 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
21923C...Reject gluon attachments that give rise to singlet gluons.
21924 IF (MACCPT.EQ.0) GOTO 470
21925
21926C...Update colours
21927 JCG1=MCT(IGL,2-MANTI)
21928 JCG2=MCT(IGL,1+MANTI)
21929 JCP1=MCT(IP1,1+MANTI)
21930 JCP2=MCT(IP2,2-MANTI)
21931
21932C...Select whether to accept this insertion
21933 IF (MSTP(89).EQ.0) THEN
21934C...Random insertions: no measure.
21935 RL=1D0
21936C...For random ordering, we want to suppress beam remnant breakups
21937C...already at this point.
21938 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
21939 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
21940 NMP1=0
21941 NMGL=0
21942 GOTO 470
21943 ENDIF
21944 ELSEIF (MSTP(89).EQ.1) THEN
21945C...Rapidity ordering:
21946C...YGL = Rapidity of gluon.
21947 YGL=YMI(IMGL)
21948C...If fictitious gluon
21949 IF (YGL.EQ.100D0) THEN
21950 YGL=(3-2*JS)*100D0
21951 IDA1=MOD(K(IGL,4),MSTU(5))
21952 IDA2=MOD(K(IGL,5),MSTU(5))
21953 DO 480 IMT=1,NMI(JS)
21954C...Select (arbitrarily) the most central daughter.
21955 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21956 & THEN
21957 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
21958 ENDIF
21959 480 CONTINUE
21960 ENDIF
21961C...YP1 = Rapidity IP1
21962 YP1=YMI(IMP1)
21963C...If fictitious gluon
21964 IF (YP1.EQ.100D0) THEN
21965 YP1=(3-2*JS)*YP1
21966 IDA1=MOD(K(IP1,4),MSTU(5))
21967 IDA2=MOD(K(IP1,5),MSTU(5))
21968 DO 490 IMT=1,NMI(JS)
21969C...Select (arbitrarily) the most central daughter.
21970 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
21971 & THEN
21972 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
21973 ENDIF
21974 490 CONTINUE
21975 ENDIF
21976C...YP2 = Rapidity of mother system
21977 IF (K(IP2,2).NE.88) THEN
21978 DO 500 IMT=1,NMI(JS)
21979 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
21980 500 CONTINUE
21981C...If fictitious gluon
21982 IF (YP2.EQ.100D0) THEN
21983 YP2=(3-2*JS)*YP2
21984 IDA1=MOD(K(IP2,4),MSTU(5))
21985 IDA2=MOD(K(IP2,5),MSTU(5))
21986 DO 510 IMT=1,NMI(JS)
21987C...Select (arbitrarily) the most central daughter.
21988 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
21989 & ) THEN
21990 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
21991 ENDIF
21992 510 CONTINUE
21993 ENDIF
21994C...Assign (arbitrarily) 100D0 to junction also
21995 ELSE
21996 YP2=(3-2*JS)*100D0
21997 ENDIF
21998 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
21999 ELSEIF (MSTP(89).EQ.2) THEN
22000C...Lambda ordering:
22001C...Compute lambda measure for this insertion.
22002 RL=1D0
22003 DO 520 IST=1,6
22004 ISTR(IST)=0
22005 520 CONTINUE
22006C...If IP2 is junction, not caught below.
22007 IF (JCP2.EQ.0) THEN
22008 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22009C...Anti-junction is colour endpoint et vv., always on JCG2.
22010 ISTR(5-ITJU)=IP2
22011 ENDIF
22012 DO 530 I=MINT(84)+1,N
22013 IF (K(I,1).LT.10) THEN
22014C...The new string pieces
22015 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22016 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22017 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22018 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22019 ENDIF
22020 530 CONTINUE
22021C...Also identify junctions as string endpoints.
22022 DO 540 I=MINT(84)+1,N
22023 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22024 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22025C...Find partons adjacent to junctions.
22026 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22027 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22028 & .EQ.0) ISTR(2) = ICMO
22029 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22030 & .EQ.0) ISTR(4) = ICMO
22031 ENDIF
22032 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22033 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22034 & .EQ.0) ISTR(1) = IAMO
22035 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22036 & .EQ.0) ISTR(3) = IAMO
22037 ENDIF
22038 540 CONTINUE
22039C...The old string piece
22040 ISTR(5)=ISTR(1+2*MANTI)
22041 ISTR(6)=ISTR(4-2*MANTI)
22042 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22043 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22044C...If one or more of the colour tags for this connection is/are still
22045C...dangling, skip this attempt for the time being.
22046 RL=1D6
22047 ELSE
22048 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22049 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22050 RL=LOG(RL)
22051 ENDIF
22052 ENDIF
22053C...Allow some breadth to speed things up.
22054 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22055 NOPT=NOPT+1
22056 ELSEIF (RL.GT.RLOPT) THEN
22057 GOTO 470
22058 ELSE
22059 NOPT=1
22060 RLOPT=RL
22061 ENDIF
22062C...INSR(NOPT,1)=Gluon colour mother
22063C...INSR(NOPT,2)=Gluon
22064C...INSR(NOPT,3)=Gluon anticolour mother
22065 IF (NOPT.GT.1000) GOTO 470
22066 INSR(NOPT,1+2*MANTI)=IP2
22067 INSR(NOPT,2)=IGL
22068 INSR(NOPT,3-2*MANTI)=IP1
22069 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22070 ENDIF
22071 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22072 ENDIF
22073C...Reset link test information.
22074 DO 550 I=MINT(84)+1,N
22075 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22076 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22077 550 CONTINUE
22078 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22079 ENDIF
22080C...Now we have a list of best gluon insertions, none of which cause
22081C...singlets to arise. If list is empty, try again a few times. Note:
22082C...this should never happen if we have a meson with a gluon inserted
22083C...in the beam remnant, since that breaks up the colour line.
22084 IF (NOPT.EQ.0) THEN
22085C...Abandon BR-g-BR suppression for retries. This is not serious, it
22086C...just means we happened to start with trying a bad sequence.
22087 PARP80=1D0
22088 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22089 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22090 MRETRY=MRETRY+1
22091 DO 590 JS=1,2
22092 IF (ITJUNC(JS).NE.0) THEN
22093 JST(JS,1)=IV(JS,1)
22094 JST(JS,2)=IV(JS,2)
22095 JST(JS,3)=IV(JS,3)
22096C...Reset valence quark parent pointers
22097 DO 560 I=MINT(53)+1,N
22098 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22099 560 CONTINUE
22100 MANTI=ITJUNC(JS)-1
22101C...Set (anti)colour mother = junction.
22102 DO 570 JV=1,3
22103 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22104 & +MSTU(5)*IJU
22105 570 CONTINUE
22106 ELSE
22107C...Same for mesons. JST unchanged, so needn't be restored.
22108 IQ=JST(JS,1)
22109 IQBAR=JST(JS,2)
22110 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22111 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22112 ENDIF
22113C...Also reset gluon parent pointers.
22114 NG(JS)=0
22115 DO 580 IM=1,NMI(JS)
22116 I=IMI(JS,IM,1)
22117 IF (K(I,2).EQ.21) THEN
22118 K(I,4)=MOD(K(I,4),MSTU(5))
22119 K(I,5)=MOD(K(I,5),MSTU(5))
22120 NG(JS)=NG(JS)+1
22121 ENDIF
22122 580 CONTINUE
22123 590 CONTINUE
22124C...Reset colour tags
22125 DO 600 I=MINT(84)+1,N
22126 MCT(I,1)=MCO(I,1)
22127 MCT(I,2)=MCO(I,2)
22128 600 CONTINUE
22129 GOTO 400
22130 ELSE
22131 IF(NERRPR.LT.5) THEN
22132 NERRPR=NERRPR+1
22133 CALL PYLIST(4)
22134 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22135 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22136 ENDIF
22137C...Kill event and start another.
22138 MINT(51)=1
22139 RETURN
22140 ENDIF
22141 ELSE
22142C...Select between insertions, suppressing insertions wholly in the BR.
22143 IIN=PYR(0)*NOPT+1
22144 610 IIN=MOD(IIN,NOPT)+1
22145 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22146 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22147 ENDIF
22148
22149C...Now we know which gluon to insert where. Colour tags in JCCO and
22150C...colour connection information should be updated, NG(JS) should be
22151C...counted down, and a new loop performed if there are still gluons
22152C...left on any side.
22153 ICM=INSR(IIN,1)
22154 IACM=INSR(IIN,3)
22155 IGL=INSR(IIN,2)
22156C...JCG : Original gluon colour tag
22157C...JCAG: Original gluon anticolour tag.
22158C...JCM : Original anticolour tag of gluon colour mother
22159C...JACM: Original colour tag of gluon anticolour mother
22160 JCG=MCO(IGL,1)
22161 JCM=MCO(ICM,2)
22162 JACG=MCO(IGL,2)
22163 JACM=MCO(IACM,1)
22164
22165 CALL PYMIHG(JACM,JACG,JCM,JCG)
22166 IF (MACCPT.EQ.0) THEN
22167 IF(NERRPR.LT.5) THEN
22168 NERRPR=NERRPR+1
22169 CALL PYLIST(4)
22170 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22171 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22172 ENDIF
22173C...Kill event and start another.
22174 MINT(51)=1
22175 RETURN
22176 ELSE
22177C...If everything went fine, store new JCCN in JCCO.
22178 NCC=NCC+1
22179 DO 620 ICC=1,NCC
22180 JCCO(ICC,1)=JCCN(ICC,1)
22181 JCCO(ICC,2)=JCCN(ICC,2)
22182 620 CONTINUE
22183 ENDIF
22184
22185C...One gluon attached is counted as equivalent to one end outside.
22186 MOUT(JS)=1
22187C...Set IGL colour mother = ICM.
22188 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22189C...Set ICM anticolour mother = IGL colour.
22190 IF (K(ICM,2).NE.88) THEN
22191 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22192 ELSE
22193C...If ICM is junction, just update JST array for now.
22194 DO 630 MSJ=1,3
22195 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22196 630 CONTINUE
22197 ENDIF
22198C...Set IGL anticolour mother = IACM.
22199 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22200C...Set IACM anticolour mother = IGL anticolour.
22201 IF (K(IACM,2).NE.88) THEN
22202 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22203 ELSE
22204C...If IACM is junction, just update JST array for now.
22205 DO 640 MSJ=1,3
22206 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22207 640 CONTINUE
22208 ENDIF
22209C...Count down # unconnected gluons.
22210 NG(JS)=NG(JS)-1
22211 ENDIF
22212 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22213
22214 DO 840 JS=1,2
22215C...Collapse fictitious gluons.
22216 DO 670 IGL=MINT(53)+1,N
22217 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22218 & K(IGL,1).EQ.14) THEN
22219 ICM=K(IGL,4)/MSTU(5)
22220 IAM=K(IGL,5)/MSTU(5)
22221 ICD=MOD(K(IGL,4),MSTU(5))
22222 IAD=MOD(K(IGL,5),MSTU(5))
22223C...Set gluon daughters pointing to gluon mothers
22224 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22225 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22226C...Set gluon mothers pointing to gluon daughters.
22227 IF (K(ICM,2).NE.88) THEN
22228 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22229 ELSE
22230C...Special case: mother=junction. Just update JST array for now.
22231 DO 650 MSJ=1,3
22232 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22233 650 CONTINUE
22234 ENDIF
22235 IF (K(IAM,2).NE.88) THEN
22236 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22237 ELSE
22238 DO 660 MSJ=1,3
22239 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22240 660 CONTINUE
22241 ENDIF
22242 ENDIF
22243 670 CONTINUE
22244
22245C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22246 IM=NMI(JS)+1
22247 680 IM=IM-1
22248 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22249 IF (IM.GT.MINT(31)) THEN
22250 NMI(JS)=NMI(JS)-1
22251 DO 690 IMR=IM,NMI(JS)
22252 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22253 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22254 690 CONTINUE
22255 GOTO 680
22256 ENDIF
22257
22258C...Finally, connect junction.
22259 IF (ITJUNC(JS).NE.0) THEN
22260 DO 700 I=MINT(53)+1,N
22261 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22262 700 CONTINUE
22263C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22264 NBRJQ =0
22265 NBRVQ =0
22266 DO 720 MSJ=1,3
22267 IDQ(MSJ)=0
22268C...Find jq with no glue inbetween inside beam remnant.
22269 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22270 & THEN
22271 NBRJQ=NBRJQ+1
22272C...Set IDQ = -I if q non-valence and = +I if q valence.
22273 IDQ(NBRJQ)=-JST(JS,MSJ)
22274 DO 710 JV=1,3
22275 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22276 IDQ(NBRJQ)=JST(JS,MSJ)
22277 NBRVQ=NBRVQ+1
22278 ENDIF
22279 710 CONTINUE
22280 ENDIF
22281 I12=MOD(MSJ+1,2)
22282 I45=5
22283 IF (MSJ.EQ.3) I45=4
22284 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22285 720 CONTINUE
22286
22287C...Check if diquark can be formed.
22288 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22289 & .GE.1)) THEN
22290C...If there is less than 2 valence quarks connected to junction
22291C...and MSTP(88)>1, use random non-valence quarks to fill up.
22292 IF (NBRVQ.LE.1) THEN
22293 NDIQ=NBRVQ
22294 730 JFLIP=NBRJQ*PYR(0)+1
22295 IF (IDQ(JFLIP).LT.0) THEN
22296 IDQ(JFLIP)=-IDQ(JFLIP)
22297 NDIQ=NDIQ+1
22298 ENDIF
22299 IF (NDIQ.LE.1) GOTO 730
22300 ENDIF
22301C...Place selected quarks first in IDQ, ordered in flavour.
22302 DO 740 JDQ=1,3
22303 IF (IDQ(JDQ).LE.0) THEN
22304 ITEMP1 = IDQ(JDQ)
22305 IDQ(JDQ)= IDQ(3)
22306 IDQ(3) = -ITEMP1
22307 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22308 ITEMP1 = IDQ(1)
22309 IDQ(1) = IDQ(2)
22310 IDQ(2) = ITEMP1
22311 ENDIF
22312 ENDIF
22313 740 CONTINUE
22314C...Choose diquark spin.
22315 IF (NBRVQ.EQ.2) THEN
22316C...If the selected quarks are both valence, we may use SU(6) rules
22317C...to figure out which spin the diquark has, by a subdivision of the
22318C...original beam hadron into the selected diquark system plus a kicked
22319C...out quark, IKO.
22320 JKO=6
22321 DO 760 JDQ=1,2
22322 DO 750 JV=1,3
22323 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22324 750 CONTINUE
22325 760 CONTINUE
22326 IKO=IV(JS,JKO)
22327 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22328 ELSE
22329C...If one or more of the selected quarks are not valence, we cannot use
22330C...SU(6) subdivisions of the original beam hadron. Instead, with the
22331C...flavours of the diquark already selected, we assume for now
22332C...50:50 spin-1:spin-0 (where spin-0 possible).
22333 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22334 IS=3
22335 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22336 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22337 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22338 ENDIF
22339
22340C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22341C...Note: third quark can per definition not also be valence,
22342C...therefore we can only do this if we are allowed to use sea quarks.
22343 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22344 NTRY=0
22345 780 NTRY=NTRY+1
22346 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22347 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22348 GOTO 780
22349 ELSEIF(NTRY.GT.100) THEN
22350C...If no baryon can be found, give up and form diquark.
22351 IDQ(3)=0
22352 GOTO 770
22353 ELSE
22354C...Replace junction by baryon.
22355 K(IJU,1)=1
22356 K(IJU,2)=KFBAR
22357 K(IJU,3)=MINT(83)+JS
22358 K(IJU,4)=0
22359 K(IJU,5)=0
22360 P(IJU,5)=PYMASS(KFBAR)
22361 DO 790 MSJ=1,3
22362C...Prepare removal of participating quarks from ER.
22363 K(JST(JS,MSJ),1)=-1
22364 790 CONTINUE
22365 ENDIF
22366 ELSE
22367C...If collapse to baryon not possible or not allowed, replace junction
22368C...by diquark. This way, collapsed gluons that were pointing at the
22369C...junction will now point (correctly) at diquark.
22370 MANTI=ITJUNC(JS)-1
22371 K(IJU,1)=3
22372 K(IJU,2)=KFDQ
22373 K(IJU,3)=MINT(83)+JS
22374 K(IJU,4)=0
22375 K(IJU,5)=0
22376 DO 800 MSJ=1,3
22377 IP=JST(JS,MSJ)
22378 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22379 K(IJU,4+MANTI)=0
22380 K(IJU,5-MANTI)=IP*MSTU(5)
22381 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22382 & MSTU(5)*IJU
22383 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22384 ELSE
22385C...Prepare removal of participating quarks from ER.
22386 K(IP,1)=-1
22387 ENDIF
22388 800 CONTINUE
22389 ENDIF
22390
22391C...Update so ER pointers to collapsed quarks
22392C...now go to collapsed object.
22393 DO 820 I=MINT(84)+1,N
22394 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22395 & .K(I,1).GT.0) THEN
22396 DO 810 ISID=4,5
22397 IMO=K(I,ISID)/MSTU(5)
22398 IDA=MOD(K(I,ISID),MSTU(5))
22399 IF (IMO.GT.0) THEN
22400 IF (K(IMO,1).EQ.-1) IMO=IJU
22401 ENDIF
22402 IF (IDA.GT.0) THEN
22403 IF (K(IDA,1).EQ.-1) IDA=IJU
22404 ENDIF
22405 K(I,ISID)=IDA+MSTU(5)*IMO
22406 810 CONTINUE
22407 ENDIF
22408 820 CONTINUE
22409 ENDIF
22410 ENDIF
22411
22412C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22413C...(this only happens for baryons, where we want to force the gluon
22414C...to sit next to the junction. Mesons handled above.)
22415 IF (NBRTOT(JS).EQ.0) THEN
22416 N=N+1
22417 DO 830 IX=1,5
22418 K(N,IX)=0
22419 P(N,IX)=0D0
22420 V(N,IX)=0D0
22421 830 CONTINUE
22422 IGL=N
22423 K(IGL,1)=3
22424 K(IGL,2)=21
22425 K(IGL,3)=MINT(83)+JS
22426 IF (ITJUNC(JS).NE.0) THEN
22427C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22428 JLEG=PYR(0)*NVSUM(JS)+1
22429 I1=JST(JS,JLEG)
22430 JST(JS,JLEG)=IGL
22431 JCT=MCT(I1,ITJUNC(JS))
22432 MCT(IGL,3-ITJUNC(JS))=JCT
22433 NCT=NCT+1
22434 MCT(IGL,ITJUNC(JS))=NCT
22435 MANTI=ITJUNC(JS)-1
22436 ELSE
22437C...Meson. Should not happen.
22438 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22439 IF(NERRPR.LT.5) THEN
22440 WRITE(MSTU(11),*) 'This should not have been possible!'
22441 CALL PYLIST(4)
22442 NERRPR=NERRPR+1
22443 ENDIF
22444 MINT(51)=1
22445 RETURN
22446 ENDIF
22447 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22448 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22449 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22450 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22451 IF (K(I2,2).NE.88) THEN
22452 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22453 ELSE
22454 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22455 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22456 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22457 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22458 ELSE
22459 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22460 ENDIF
22461 ENDIF
22462 ENDIF
22463 840 CONTINUE
22464
22465C...Remove collapsed quarks and junctions from ER and update IMI.
22466 CALL PYEDIT(11)
22467
22468C...Also update beam remnant part of IMI.
22469 NMI(1)=MINT(31)
22470 NMI(2)=MINT(31)
22471 DO 850 I=MINT(53)+1,N
22472 IF (K(I,1).LE.0) GOTO 850
22473C...Restore BR quark/diquark/baryon pointers in IMI.
22474 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22475 JS=K(I,3)-MINT(83)
22476 NMI(JS)=NMI(JS)+1
22477 IMI(JS,NMI(JS),1)=I
22478 IMI(JS,NMI(JS),2)=0
22479 ENDIF
22480 850 CONTINUE
22481
22482C...Restore companion information from collapsed gluons.
22483 DO 870 I=MINT(53)+1,N
22484 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22485 JS=K(I,3)-MINT(83)
22486 JCD=MOD(K(I,4),MSTU(5))
22487 JAD=MOD(K(I,5),MSTU(5))
22488 DO 860 IM=1,NMI(JS)
22489 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22490 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22491 860 CONTINUE
22492 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22493 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22494 ENDIF
22495 870 CONTINUE
22496
22497C...Renumber colour lines (since some have disappeared)
22498 JCT=0
22499 JCD=0
22500 880 JCT=JCT+1
22501 MFOUND=0
22502 I=MINT(84)
22503 890 I=I+1
22504 IF (I.EQ.N+1) THEN
22505 IF (MFOUND.EQ.0) JCD=JCD+1
22506 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22507 MCT(I,1)=JCT-JCD
22508 MFOUND=1
22509 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22510 MCT(I,2)=JCT-JCD
22511 MFOUND=1
22512 ENDIF
22513 IF (I.LE.N) GOTO 890
22514 IF (JCT.LT.NCT) GOTO 880
22515 NCT=JCT-JCD
22516
22517C...Reset hard interaction subsystems to their CM frames.
22518 IF (IBOOST.EQ.1) THEN
22519 DO 900 IM=1,MINT(31)
22520 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22521 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22522 900 CONTINUE
22523C...Zero beam remnant longitudinal momenta and energies
22524 DO 910 I=MINT(53)+1,N
22525 P(I,3)=0D0
22526 P(I,4)=0D0
22527 910 CONTINUE
22528 ELSE
22529 CALL PYERRM(9
22530 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
22531C...Kill event and start another.
22532 MINT(51)=1
22533 RETURN
22534 ENDIF
22535
22536 9999 RETURN
22537 END
22538C*********************************************************************
22539
22540C...PYCTTR
22541C...Adapted from PYPREP.
22542C...Assigns LHA1 colour tags to coloured partons based on
22543C...K(I,4) and K(I,5) colour connection record.
22544C...KCS negative signifies that a previous tracing should be continued.
22545C...(in case the tag to be continued is empty, the routine exits)
22546C...Starts at I and ends at I or IEND.
22547C...Special considerations for systems with junctions.
22548C...Special: if IEND=-1, means trace this parton to its color partner,
22549C... then exit. If no partner found, exit with 0.
22550
22551 SUBROUTINE PYCTTR(I,KCS,IEND)
22552C...Double precision and integer declarations.
22553 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22554 INTEGER PYK,PYCHGE,PYCOMP
22555C...Commonblocks.
22556 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22557 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22558 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
22559 COMMON/PYINT1/MINT(400),VINT(400)
22560C...The common block of colour tags.
22561 COMMON/PYCTAG/NCT,MCT(4000,2)
22562 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
22563 DATA NERRPR/0/
22564 SAVE NERRPR
22565
22566C...Skip if parton not existing or does not have KCS
22567 IF (K(I,1).LE.0) GOTO 120
22568 KC=PYCOMP(K(I,2))
22569 IF (KC.EQ.0) GOTO 120
22570 KQ=KCHG(KC,2)
22571 IF (KQ.EQ.0) GOTO 120
22572 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
22573 & GOTO 120
22574
22575 IF (KCS.GT.0) THEN
22576 NCT=NCT+1
22577C...Set colour tag of first parton.
22578 MCT(I,KCS-3)=NCT
22579 NCS=NCT
22580 ELSE
22581 KCS=-KCS
22582 NCS=MCT(I,KCS-3)
22583 IF (NCS.EQ.0) GOTO 120
22584 ENDIF
22585
22586 IA=I
22587 NSTP=0
22588 100 NSTP=NSTP+1
22589 IF(NSTP.GT.4*N) THEN
22590 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
22591 GOTO 120
22592 ENDIF
22593
22594C...Finished if reached final-state triplet.
22595 IF(K(IA,1).EQ.3) THEN
22596 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
22597 ENDIF
22598
22599C...Also finished if reached junction.
22600 IF(K(IA,1).EQ.42) THEN
22601 GOTO 120
22602 ENDIF
22603
22604C...GOTO next parton in colour space.
22605 110 IB=IA
22606C...If IB's KCS daughter not traced and exists, goto KCS daughter.
22607 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
22608 & .NE.0) THEN
22609 IA=MOD(K(IB,KCS),MSTU(5))
22610 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
22611 MREV=0
22612 ELSE
22613C...If KCS mother traced or KCS mother nonexistent, switch colour.
22614 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
22615 & MSTU(5)).EQ.0) THEN
22616 KCS=9-KCS
22617 NCT=NCT+1
22618 NCS=NCT
22619C...Assign new colour tag on other side of old parton.
22620 MCT(IB,KCS-3)=NCT
22621 ENDIF
22622C...Goto (new) KCS mother, set mother traced tag
22623 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
22624 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
22625 MREV=1
22626 ENDIF
22627 IF(IA.LE.0.OR.IA.GT.N) THEN
22628 IF (IEND.EQ.-1) THEN
22629 IEND=0
22630 GOTO 120
22631 ENDIF
22632 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
22633 IF(NERRPR.LT.5) THEN
22634 write(*,*) 'began at ',I
22635 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
22636 & ' NCS=',NCS,' MREV=',MREV
22637 CALL PYLIST(4)
22638 NERRPR=NERRPR+1
22639 ENDIF
22640 MINT(51)=1
22641 RETURN
22642 ENDIF
22643 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
22644 & MSTU(5)).EQ.IB) THEN
22645 IF(MREV.EQ.1) KCS=9-KCS
22646 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
22647C...Set KSC mother traced tag for IA
22648 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
22649 ELSE
22650 IF(MREV.EQ.0) KCS=9-KCS
22651 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
22652C...Set KCS daughter traced tag for IA
22653 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
22654 ENDIF
22655C...Assign new colour tag
22656 MCT(IA,KCS-3)=NCS
22657C...Finish if IEND=-1 and found final-state color partner
22658 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
22659 IEND=IA
22660 GOTO 120
22661 ENDIF
22662 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
22663
22664 120 RETURN
22665 END
22666
22667*********************************************************************
22668
22669C...PYMIHG
22670C...Collapse JCP1 and connecting tags to JCG1.
22671C...Collapse JCP2 and connecting tags to JCG2.
22672
22673 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
22674C...Double precision and integer declarations.
22675 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22676 IMPLICIT INTEGER(I-N)
22677 INTEGER PYK,PYCHGE,PYCOMP
22678C...The event record
22679 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22680C...Parameters
22681 COMMON/PYINT1/MINT(400),VINT(400)
22682 SAVE /PYJETS/,/PYINT1/
22683C...Local variables
22684 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
22685 COMMON /PYCTAG/NCT,MCT(4000,2)
22686 SAVE /PYCBLS/,/PYCTAG/
22687
22688C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
22689C...in temporary tag collapse array JCCN. Only break up one connection.
22690 MACCPT=1
22691 MCLPS=0
22692 DO 100 ICC=1,NCC
22693 JCCN(ICC,1)=JCCO(ICC,1)
22694 JCCN(ICC,2)=JCCO(ICC,2)
22695C...If there was a mother, it was previously connected to JCP1.
22696C...Should be changed to JCP2.
22697 IF (MCLPS.EQ.0) THEN
22698 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
22699 & ,JCP2)) THEN
22700 JCCN(ICC,1)=MAX(JCG2,JCP2)
22701 JCCN(ICC,2)=MIN(JCG2,JCP2)
22702 MCLPS=1
22703 ENDIF
22704 ENDIF
22705 100 CONTINUE
22706C...Also collapse colours on JCP1 side of JCG1
22707 IF (JCP1.NE.0) THEN
22708 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
22709 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
22710 ELSE
22711 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
22712 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
22713 ENDIF
22714
22715C...Initialize event record colour tag array MCT array to MCO.
22716 DO 110 I=MINT(84)+1,N
22717 MCT(I,1)=MCO(I,1)
22718 MCT(I,2)=MCO(I,2)
22719 110 CONTINUE
22720
22721C...Collapse tags:
22722C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
22723C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
22724C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
22725C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
22726 DO 160 IS=1,4
22727C...Skip if junction.
22728 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
22729C...Define starting point in tag space.
22730C...JCA = previous tag
22731C...JCO = present tag
22732C...JCN = new tag
22733 IF (MOD(IS,2).EQ.1) THEN
22734 JCO=JCP1
22735 JCN=JCG1
22736 JCALL=JCG1
22737 ELSEIF (MOD(IS,2).EQ.0) THEN
22738 JCO=JCP2
22739 JCN=JCG2
22740 JCALL=JCG2
22741 ENDIF
22742 ITRACE=0
22743 120 ITRACE=ITRACE+1
22744 IF (ITRACE.GT.1000) THEN
22745C...NB: Proper error message should be defined here.
22746 CALL PYERRM(14
22747 & ,'(PYMIHG:) Inf loop when collapsing colours.')
22748 MINT(57)=MINT(57)+1
22749 MINT(51)=1
22750 RETURN
22751 ENDIF
22752C...Collapse all JCN tags to JCALL
22753 DO 130 I=MINT(84)+1,N
22754 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22755 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22756 130 CONTINUE
22757C...IS = 1,2: first step forward. IS = 3,4: first step backward.
22758 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
22759 JCA=JCN
22760 JCN=JCO
22761 ELSE
22762 JCA=JCO
22763 JCO=JCN
22764 ENDIF
22765C...If possible, step from JCO to new tag JCN not equal to JCA.
22766 DO 140 ICC=1,NCC+1
22767 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
22768 & JCCN(ICC,2)
22769 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
22770 & JCCN(ICC,1)
22771 140 CONTINUE
22772C...Iterate if new colour was arrived at, but don't go in circles.
22773 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
22774C...Change all JCN tags in MCO to JCALL in MCT.
22775 DO 150 I=MINT(84)+1,N
22776 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
22777 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
22778C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22779 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22780 & .NE.0) MACCPT=0
22781 150 CONTINUE
22782 160 CONTINUE
22783
22784 DO 200 JCL=NCT,1,-1
22785 JCA=0
22786 JCN=JCL
22787 170 JCO=JCN
22788 DO 180 ICC=1,NCC+1
22789 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
22790 & =JCCN(ICC,2)
22791 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
22792 & =JCCN(ICC,1)
22793 180 CONTINUE
22794C...Overpaint all JCN with JCL
22795 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
22796 DO 190 I=MINT(84)+1,N
22797 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
22798 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
22799C...If gluon and colour tag = anticolour tag (and not = 0) try again.
22800 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
22801 & .NE.0) MACCPT=0
22802 190 CONTINUE
22803 JCA=JCO
22804 GOTO 170
22805 ENDIF
22806 200 CONTINUE
22807
22808 RETURN
22809 END
22810
22811C*********************************************************************
22812
22813C...PYMIRM
22814C...Picks primordial kT and shares longitudinal momentum among
22815C...beam remnants.
22816
22817 SUBROUTINE PYMIRM
22818
22819C...Double precision and integer declarations.
22820 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
22821 IMPLICIT INTEGER(I-N)
22822 INTEGER PYK,PYCHGE,PYCOMP
22823C...The event record
22824 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
22825C...Parameters
22826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
22827 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
22828 COMMON/PYINT1/MINT(400),VINT(400)
22829C...The common block of colour tags.
22830 COMMON/PYCTAG/NCT,MCT(4000,2)
22831C...The common block of dangling ends
22832 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
22833 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
22834 & XMI(2,240),PT2MI(240),IMISEP(0:240)
22835 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
22836C...Local variables
22837 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
22838C...W(I,J)| J=0 | 1 | 2 |
22839C... I=0 | Wrem**2 | W+ | W- |
22840C... 1 | W1**2 | W1+ | W1- |
22841C... 2 | W2**2 | W2+ | W2- |
22842C...4-product
22843 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)
22844C...Tentative parametrization of <kT> as a function of Q.
22845 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
22846C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
22847C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
22848 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
22849C...Lambda kinematic function.
22850 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
22851
22852C...Beginning and end of beam remnant partons
22853 NOUT=MINT(53)
22854 ISUB=MINT(1)
22855
22856C...Loopback point if kinematic choices gives impossible configuration.
22857 NTRY=0
22858 100 NTRY=NTRY+1
22859
22860C...Assign kT values on each side separately.
22861 DO 180 JS=1,2
22862
22863C...First zero all kT on this side. Skip if no kT to generate.
22864 DO 110 IM=1,NMI(JS)
22865 P(IMI(JS,IM,1),1)=0D0
22866 P(IMI(JS,IM,1),2)=0D0
22867 110 CONTINUE
22868 IF(MSTP(91).LE.0) GOTO 180
22869
22870C...Now assign kT to each (non-collapsed) parton in IMI.
22871 DO 170 IM=1,NMI(JS)
22872 I=IMI(JS,IM,1)
22873C...Select kT according to truncated gaussian or 1/kt6 tails.
22874C...For first interaction, either use rms width = PARP(91) or fitted.
22875 IF (IM.EQ.1) THEN
22876 SIGMA=PARP(91)
22877 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
22878 Q=SQRT(PT2MI(IM))
22879 SIGMA=SIGPT(Q)
22880 ENDIF
22881 ELSE
22882C...For subsequent interactions and BR partons use fragmentation width.
22883 SIGMA=PARJ(21)
22884 ENDIF
22885 PHI=PARU(2)*PYR(0)
22886 PT=0D0
22887 IF(NTRY.LE.100) THEN
22888 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
22889 PT=GETPT(Q,SIGMA)
22890 PTX=PT*COS(PHI)
22891 PTY=PT*SIN(PHI)
22892 ELSEIF (MSTP(91).EQ.2) THEN
22893 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
22894 & 'available, using MSTP(91)=1.')
22895 CALL PYGIVE('MSTP(91)=1')
22896 GOTO 111
22897 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
22898C...Use distribution with kt**6 tails, rms width = PARP(91).
22899 EPS=SQRT(3D0/2D0)*SIGMA
22900C...Generate PTX and PTY separately, each propto 1/KT**6
22901 DO 119 IXY=1,2
22902C...Decide which interval to try
22903 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
22904 IF (PYR(0).LT.P12) THEN
22905C...Use flat approx with accept/reject up to EPS.
22906 PT=PYR(0)*EPS
22907 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
22908 IF (PYR(0).GT.WT) GOTO 112
22909 ELSE
22910C...Above EPS, use 1/kt**6 approx with accept/reject.
22911 PT=EPS/(PYR(0)**(1D0/5D0))
22912 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
22913 IF (PYR(0).GT.WT) GOTO 112
22914 ENDIF
22915 MSIGN=1
22916 IF (PYR(0).GT.0.5D0) MSIGN=-1
22917 IF (IXY.EQ.1) PTX=MSIGN*PT
22918 IF (IXY.EQ.2) PTY=MSIGN*PT
22919 119 CONTINUE
22920 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
22921 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22922 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
22923 ENDIF
22924C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
22925 PT=SQRT(PTX**2+PTY**2)
22926 WT=1D0
22927 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
22928 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
22929 PTX=PTX*WT
22930 PTY=PTY*WT
22931 PT=SQRT(PTX**2+PTY**2)
22932 ENDIF
22933
22934 P(I,1)=P(I,1)+PTX
22935 P(I,2)=P(I,2)+PTY
22936
22937C...Compensation kicks, with varying degree of local anticorrelations.
22938 MCORR=MSTP(90)
22939 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
22940 PTCX=-PTX/(NMI(JS)-1)
22941 PTCY=-PTY/(NMI(JS)-1)
22942 IF(ISUB.EQ.95) THEN
22943 PTCX=-PTX/(NMI(JS)-2)
22944 PTCY=-PTY/(NMI(JS)-2)
22945 ENDIF
22946 DO 120 IMC=1,NMI(JS)
22947 IF (IMC.EQ.IM) GOTO 120
22948 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
22949 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
22950 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
22951 120 CONTINUE
22952 ELSEIF (MCORR.GE.1) THEN
22953 DO 140 MSID=4,5
22954 NNXT(MSID-3)=0
22955C...Count up # of neighbours on either side
22956 IMO=I
22957 130 IMO=K(IMO,MSID)/MSTU(5)
22958 IF (IMO.EQ.0) GOTO 140
22959 NNXT(MSID-3)=NNXT(MSID-3)+1
22960C...Stop at quarks and junctions
22961 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
22962 140 CONTINUE
22963C...How should compensation be shared when unequal numbers on the
22964C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
22965 NSUM=NNXT(1)+NNXT(2)
22966 T1=0
22967 DO 160 MSID=4,5
22968C...Total momentum to be compensated on this side
22969 IF (NNXT(MSID-3).EQ.0) GOTO 160
22970 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
22971 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
22972C...RS: compensation supression factor as we go out from parton I.
22973C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
22974C...since (for now) MSTP(90) provides enough variability.
22975 RS=0.5D0
22976 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
22977 IMO=I
22978 150 IDA=IMO
22979 IMO=K(IMO,MSID)/MSTU(5)
22980 IF (IMO.EQ.0) GOTO 160
22981 FAC=FAC*RS
22982 IF (K(IMO,2).NE.88) THEN
22983 P(IMO,1)=P(IMO,1)+FAC*PTCX
22984 P(IMO,2)=P(IMO,2)+FAC*PTCY
22985 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
22986C...If we reach junction, divide out the kT that would have been
22987C...assigned to the junction on each of its other legs.
22988 ELSE
22989 L1=MOD(K(IMO,4),MSTU(5))
22990 L2=K(IMO,5)/MSTU(5)
22991 L3=MOD(K(IMO,5),MSTU(5))
22992 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
22993 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
22994 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
22995 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
22996 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
22997 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
22998 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
22999 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23000 ENDIF
23001
23002 160 CONTINUE
23003 ENDIF
23004 170 CONTINUE
23005C...End assignment of kT values to initiators and remnants.
23006 180 CONTINUE
23007
23008C...Check kinematics constraints for non-BR partons.
23009 DO 190 IM=1,MINT(31)
23010 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23011 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23012 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23013 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23014 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23015 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23016 IF(NTRY.GE.100) THEN
23017C...Kill this event and start another.
23018 CALL PYERRM(1,
23019 & '(PYMIRM:) No consistent (x,kT) sets found')
23020 MINT(51)=1
23021 RETURN
23022 ENDIF
23023 GOTO 100
23024 ENDIF
23025 190 CONTINUE
23026
23027C...Calculate W+ and W- available for combined remnant system.
23028 W(0,1)=VINT(1)
23029 W(0,2)=VINT(1)
23030 DO 200 IM=1,MINT(31)
23031 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23032 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23033 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23034 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23035 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23036 200 CONTINUE
23037C...Also store Wrem**2 = W+ * W-
23038 W(0,0)=W(0,1)*W(0,2)
23039
23040 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23041 IF(NTRY.GE.100) THEN
23042C...Kill this event and start another.
23043 CALL PYERRM(1,
23044 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23045 MINT(51)=1
23046 RETURN
23047 ENDIF
23048 GOTO 100
23049 ENDIF
23050
23051C...Assign unscaled x values to partons/hadrons in each of the
23052C...beam remnants and calculate unscaled W+ and W- from them.
23053 NTRYX=0
23054 210 NTRYX=NTRYX+1
23055 DO 280 JS=1,2
23056 W(JS,1)=0D0
23057 W(JS,2)=0D0
23058 DO 270 IM=MINT(31)+1,NMI(JS)
23059 I=IMI(JS,IM,1)
23060 KF=K(I,2)
23061 KFA=IABS(KF)
23062 ICOMP=IMI(JS,IM,2)
23063
23064C...Skip collapsed gluons and junctions. Reset.
23065 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23066 IF (KFA.EQ.88) GOTO 270
23067 X=0D0
23068 IVALQ(1)=0
23069 IVALQ(2)=0
23070 ICOMQ(1)=0
23071 ICOMQ(2)=0
23072
23073C...If gluon then only beam remnant, so takes all.
23074 IF(KFA.EQ.21) THEN
23075 X=1D0
23076C...If valence quark then use parametrized valence distribution.
23077 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23078 IVALQ(1)=KF
23079C...If companion quark then derive from companion x.
23080 ELSEIF(KFA.LE.6) THEN
23081 ICOMQ(1)=ICOMP
23082C...If valence diquark then use two parametrized valence distributions.
23083 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23084 & ICOMP.EQ.0) THEN
23085 IVALQ(1)=ISIGN(KFA/1000,KF)
23086 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23087C...If valence+sea diquark then combine valence + companion choices.
23088 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23089 & ICOMP.LT.MSTU(5)) THEN
23090 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23091 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23092 ELSE
23093 IVALQ(1)=ISIGN(KFA/1000,KF)
23094 ENDIF
23095 ICOMQ(1)=ICOMP
23096C...Extra code: workaround for diquark made out of two sea
23097C...quarks, but where not (yet) ICOMP > MSTU(5).
23098 DO 220 IM1=1,MINT(31)
23099 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23100 ICOMQ(2)=IMI(JS,IM1,1)
23101 IVALQ(1)=0
23102 ENDIF
23103 220 CONTINUE
23104C...If sea diquark then sum of two derived from companion x.
23105 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23106 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23107 ICOMQ(2)=ICOMP/MSTU(5)
23108C...If meson or baryon then use fragmentation function.
23109C...Somewhat arbitrary split into old and new flavour, but OK normally.
23110 ELSE
23111 KFL3=MOD(KFA/10,10)
23112 IF(MOD(KFA/1000,10).EQ.0) THEN
23113 KFL1=MOD(KFA/100,10)
23114 ELSE
23115 KFL1=MOD(KFA,10000)-10*KFL3-1
23116 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23117 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23118 ENDIF
23119 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23120 CALL PYZDIS(KFL1,KFL3,PR,X)
23121 ENDIF
23122
23123 DO 260 IQ=1,2
23124C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23125C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23126C...In other baryons combine u and d from proton appropriately.
23127 IF(IVALQ(IQ).NE.0) THEN
23128 NVAL=0
23129 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23130 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23131 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23132C...Meson.
23133 IF(KFIVAL(JS,3).EQ.0) THEN
23134 MDU=0
23135C...Baryon with three identical quarks: mix u and d forms.
23136 ELSEIF(NVAL.EQ.3) THEN
23137 MDU=INT(PYR(0)+5D0/3D0)
23138C...Baryon, one of two identical quarks: u form.
23139 ELSEIF(NVAL.EQ.2) THEN
23140 MDU=2
23141C...Baryon with two identical quarks, but not the one picked: d form.
23142 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23143 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23144 MDU=1
23145C...Baryon with three nonidentical quarks: mix u and d forms.
23146 ELSE
23147 MDU=INT(PYR(0)+5D0/3D0)
23148 ENDIF
23149 XPOW=0.8D0
23150 IF(MDU.EQ.1) XPOW=3.5D0
23151 IF(MDU.EQ.2) XPOW=2D0
23152 230 XX=PYR(0)**2
23153 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23154 X=X+XX
23155 ENDIF
23156
23157C...Calculation of x of companion quark.
23158 IF(ICOMQ(IQ).NE.0) THEN
23159 XCOMP=1D-4
23160 DO 240 IM1=1,MINT(31)
23161 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23162 240 CONTINUE
23163 NPOW=MAX(0,MIN(4,MSTP(87)))
23164 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23165 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23166 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23167 IF(CORR.LT.PYR(0)) GOTO 250
23168 X=X+XX
23169 ENDIF
23170 260 CONTINUE
23171
23172C...Optionally enchance x of composite systems (e.g. diquarks)
23173 IF (KFA.GT.100) X=PARP(79)*X
23174
23175C...Store x. Also calculate light cone energies of each system.
23176 XMI(JS,IM)=X
23177 W(JS,JS)=W(JS,JS)+X
23178 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23179 270 CONTINUE
23180 W(JS,JS)=W(JS,JS)*W(0,JS)
23181 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23182 W(JS,0)=W(JS,1)*W(JS,2)
23183 280 CONTINUE
23184
23185C...Check W1 W2 < Wrem (can be done before rescaling, since W
23186C...insensitive to global rescalings of the BR x values).
23187 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23188 & THEN
23189 GOTO 210
23190 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23191 GOTO 100
23192 ELSEIF (NTRYX.GT.100) THEN
23193 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23194 MINT(57)=MINT(57)+1
23195 MINT(51)=1
23196 RETURN
23197 ENDIF
23198
23199C...Compute x rescaling factors
23200 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23201 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23202 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23203
23204 IF (R1.LT.0.OR.R2.LT.0) THEN
23205 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23206 MINT(57)=MINT(57)+1
23207 MINT(51)=1
23208 ENDIF
23209
23210C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23211 W(1,1)=W(1,1)*R1
23212 W(1,2)=W(1,2)/R1
23213 W(2,1)=W(2,1)/R2
23214 W(2,2)=W(2,2)*R2
23215
23216C...Rescale BR x values.
23217 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23218 XMI(1,IM)=XMI(1,IM)*R1
23219 XMI(2,IM)=XMI(2,IM)*R2
23220 290 CONTINUE
23221
23222C...Now we have a consistent set of x and kT values.
23223C...First set up the initiators and their daughters correctly.
23224 DO 300 IM=1,MINT(31)
23225 I1=IMI(1,IM,1)
23226 I2=IMI(2,IM,1)
23227 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23228 & (P(I1,2)+P(I2,2))**2
23229 PT12=P(I1,1)**2+P(I1,2)**2
23230 PT22=P(I2,1)**2+P(I2,2)**2
23231C...p_z
23232 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23233 P(I2,3)=-P(I1,3)
23234C...Energies (masses should be zero at this stage)
23235 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23236 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23237
23238C...Transverse 12 system initiator velocity:
23239 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23240 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23241C...Boost to overall initiator system rest frame
23242 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23243 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23244
23245C...Compute phi,theta coordinates of I1 and rotate z axis.
23246 PHI=PYANGL(P(I1,1),P(I1,2))
23247 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23248 IMIN=IMISEP(IM-1)+1
23249C...(include documentation lines if MI = 1)
23250 IF (IM.EQ.1) IMIN=MINT(83)+5
23251 IMAX=IMISEP(IM)
23252C...Rotate entire system in phi
23253 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23254C...Only rotate 12 system in theta
23255 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23256 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23257
23258C...Now boost entire system back to LAB
23259 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23260 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23261 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23262
23263 300 CONTINUE
23264
23265
23266C...For the beam remnant partons/hadrons, we only need to set pz and E.
23267 DO 320 JS=1,2
23268 DO 310 IM=MINT(31)+1,NMI(JS)
23269 I=IMI(JS,IM,1)
23270C...Skip collapsed gluons and junctions.
23271 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23272 IF (KFA.EQ.88) GOTO 310
23273 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23274 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23275 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23276 IF (JS.EQ.2) P(I,3)=-P(I,3)
23277 310 CONTINUE
23278 320 CONTINUE
23279
23280
23281C...Documentation lines
23282 DO 340 JS=1,2
23283 IN=MINT(83)+JS+2
23284 IO=IMI(JS,1,1)
23285 K(IN,1)=21
23286 K(IN,2)=K(IO,2)
23287 K(IN,3)=MINT(83)+JS
23288 K(IN,4)=0
23289 K(IN,5)=0
23290 DO 330 J=1,5
23291 P(IN,J)=P(IO,J)
23292 V(IN,J)=V(IO,J)
23293 330 CONTINUE
23294 MCT(IN,1)=MCT(IO,1)
23295 MCT(IN,2)=MCT(IO,2)
23296 340 CONTINUE
23297
23298C...Final state colour reconnections.
23299 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23300
23301C...Number of colour tags for which a recoupling will be tried.
23302 NTOT=NCT
23303C...Number of recouplings to try
23304 MINT(34)=0
23305 NRECP=0
23306 NITER=0
23307 350 NRECP=MINT(34)
23308 NITER=NITER+1
23309 IITER=0
23310 360 IITER=IITER+1
23311 IF (IITER.LE.PARP(78)*NTOT) THEN
23312C...Select two colour tags at random
23313C...NB: jj strings do not have colour tags assigned to them,
23314C...thus they are as yet not affected by anything done here.
23315 JCT=PYR(0)*NCT+1
23316 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23317 IJ1=0
23318 IJ2=0
23319 IK1=0
23320 IK2=0
23321C...Find final state partons with this (anti)colour
23322 DO 370 I=MINT(84)+1,N
23323 IF (K(I,1).EQ.3) THEN
23324 IF (MCT(I,1).EQ.JCT) IJ1=I
23325 IF (MCT(I,2).EQ.JCT) IJ2=I
23326 IF (MCT(I,1).EQ.KCT) IK1=I
23327 IF (MCT(I,2).EQ.KCT) IK2=I
23328 ENDIF
23329 370 CONTINUE
23330C...Only consider recouplings not involving junctions for now.
23331 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23332
23333 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23334 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23335 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23336 MCT(IJ2,2)=KCT
23337 MCT(IK2,2)=JCT
23338C...Count up number of reconnections
23339 MINT(34)=MINT(34)+1
23340 ENDIF
23341 IF (MINT(34).LE.1000) THEN
23342 GOTO 360
23343 ELSE
23344 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23345 GOTO 380
23346 ENDIF
23347 ENDIF
23348 IF (NRECP.LT.MINT(34)) GOTO 350
23349
23350C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23351 380 MINT(33)=1
23352
23353 RETURN
23354 END
23355
23356C*********************************************************************
23357
23358C...PYFSCR
23359C...Performs colour annealing.
23360C...MSTP(95) : CR Type
23361C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23362C... = 2 : Type I(no gg loops); hadron-hadron only
23363C... = 3 : Type I(no gg loops); all beams
23364C... = 4 : Type II(gg loops) ; hadron-hadron only
23365C... = 5 : Type II(gg loops) ; all beams
23366C... = 6 : Type S ; hadron-hadron only
23367C... = 7 : Type S ; all beams
23368C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23369C...Type S is driven by starting only from free triplets, not octets.
23370C...A string piece remains unchanged with probability
23371C... PKEEP = (1-PARP(78))**N
23372C...This scaling corresponds to each string piece having to go through
23373C...N other ones, each with probability PARP(78) for reconnection, where
23374C...N is here chosen simply as the number of multiple interactions,
23375C...for a rough scaling with the general level of activity.
23376
23377 SUBROUTINE PYFSCR(IP)
23378C...Double precision and integer declarations.
23379 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23380 INTEGER PYK,PYCHGE,PYCOMP
23381C...Commonblocks.
23382 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23383 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23384 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23385 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23386 COMMON/PYINT1/MINT(400),VINT(400)
23387C...The common block of colour tags.
23388 COMMON/PYCTAG/NCT,MCT(4000,2)
23389 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23390 &/PYPARS/
23391C...MCN: Temporary storage of new colour tags
23392 INTEGER MCN(4000,2)
23393C...Arrays for storing color string lengths
23394 INTEGER ICR(4000),MSCR(4000)
23395 INTEGER IOPT(4000)
23396 DOUBLE PRECISION RLOPTC(4000)
23397
23398C...Function to give four-product.
23399 FOUR(I,J)=P(I,4)*P(J,4)
23400 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23401
23402C...Check valid range of MSTP(95), local copy
23403 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23404 MSTP95=MOD(MSTP(95),10)
23405C...Set whether CR allowed inside resonance systems or not
23406C...(not implemented yet)
23407C MRESCR=1
23408C IF (MSTP(95).GE.10) MRESCR=0
23409
23410C...Check whether colour tags already defined
23411 IF (MINT(33).EQ.0) THEN
23412C...Erase any existing colour tags for this event
23413 DO 100 I=1,N
23414 MCT(I,1)=0
23415 MCT(I,2)=0
23416 100 CONTINUE
23417C...Create colour tags for this event
23418 DO 120 I=1,N
23419 IF (K(I,1).EQ.3) THEN
23420 DO 110 KCS=4,5
23421 KCSIN=KCS
23422 IF (MCT(I,KCSIN-3).EQ.0) THEN
23423 CALL PYCTTR(I,KCSIN,I)
23424 ENDIF
23425 110 CONTINUE
23426 ENDIF
23427 120 CONTINUE
23428C...Instruct PYPREP to use colour tags
23429 MINT(33)=1
23430 ENDIF
23431
23432C...For MSTP(95) even, only apply to hadron-hadron
23433 KA1=IABS(MINT(11))
23434 KA2=IABS(MINT(12))
23435 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23436
23437C...Initialize new tag array (but do not delete old yet)
23438 LCT=NCT
23439 DO 130 I=MAX(1,IP),N
23440 MCN(I,1)=0
23441 MCN(I,2)=0
23442 130 CONTINUE
23443
23444C...For each final-state dipole, check whether string should be
23445C...preserved.
23446 NCR=0
23447 IA=0
23448 IC=0
23449
23450 DO 150 ICT=1,NCT
23451 IA=0
23452 IC=0
23453 DO 140 I=MAX(1,IP),N
23454 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23455 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23456 140 CONTINUE
23457 IF (IC.NE.0.AND.IA.NE.0) THEN
23458 CRMODF=1D0
23459C...Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23460C...(so far ignores the possibility that the whole "muck" may be moving.)
23461 IF (PARP(77).GT.0D0) THEN
23462 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
23463C...For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
23464 IF (KA1.LT.100.AND.KA2.LT.100) THEN
23465 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
23466 ELSE
23467 P2STR = 3D0/2D0 * PT2STR
23468 ENDIF
23469 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
23470 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
23471C...Estimate number of particles ~ log(M2), cut off at 1.
23472 RLOGM2=MAX(1D0,LOG(RM2STR))
23473 P2AVG=P2STR/RLOGM2
23474C...Supress reconnection probability by 1/(1+P77*P2AVG)
23475 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
23476 ENDIF
23477 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
23478 IF (PYR(0).LE.PKEEP) THEN
23479 LCT=LCT+1
23480 MCN(IC,1)=LCT
23481 MCN(IA,2)=LCT
23482 ELSE
23483C...Add coloured parton
23484 NCR=NCR+1
23485 ICR(NCR)=IC
23486 MSCR(NCR)=1
23487 IOPT(NCR)=0
23488 RLOPTC(NCR)=1D19
23489C...Add anti-coloured parton
23490 NCR=NCR+1
23491 ICR(NCR)=IA
23492 MSCR(NCR)=2
23493 IOPT(NCR)=0
23494 RLOPTC(NCR)=1D19
23495 ENDIF
23496 ENDIF
23497 150 CONTINUE
23498
23499C...Skip if there is only one possibility
23500 IF (NCR.LE.2) THEN
23501 GOTO 9999
23502 ENDIF
23503
23504C...Reorder, so ordered in I (in order to correspond to old algorithm)
23505 NLOOP=0
23506 151 NLOOP=NLOOP+1
23507 MORD=1
23508 DO 155 IC1=1,NCR-1
23509 I1=ICR(IC1)
23510 I2=ICR(IC1+1)
23511 IF (I1.GT.I2) THEN
23512 IT=I1
23513 MST=MSCR(IC1)
23514 ICR(IC1)=I2
23515 MSCR(IC1)=MSCR(IC1+1)
23516 ICR(IC1+1)=IT
23517 MSCR(IC1+1)=MST
23518 MORD=0
23519 ENDIF
23520 155 CONTINUE
23521C...Max do 1000 reordering loops
23522 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
23523
23524C...Loop over CR partons
23525C...(Ignore junctions for now.)
23526 NLOOP=0
23527 160 NLOOP=NLOOP+1
23528 RLMAX=0D0
23529 ICRMAX=0
23530C...Loop over coloured partons
23531 DO 230 IC1=1,NCR
23532C...Retrieve parton Event Record index and Colour Side
23533 I=ICR(IC1)
23534 MSI=MSCR(IC1)
23535C...Skip already connected partons
23536 IF (MCN(I,MSI).NE.0) GOTO 230
23537C...Shorthand for colour charge
23538 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23539C...For Seattle algorithm, only start from partons with one dangling
23540C...colour tag
23541 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
23542 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) GOTO 230
23543 ENDIF
23544C...Retrieve saved optimal partner
23545 IO=IOPT(IC1)
23546 IF (IO.NE.0) THEN
23547C...Reject saved optimal partner if latter is now connected
23548C...(Also reject if using model S1, since saved partner may
23549C...now give rise to gg loop.)
23550 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
23551 IOPT(IC1)=0
23552 RLOPTC(IC1)=1D19
23553 ENDIF
23554 ENDIF
23555 RLOPT=RLOPTC(IC1)
23556C...Search for new optimal partner if necessary
23557 IF (IOPT(IC1).EQ.0) THEN
23558 MBROPT=0
23559 MGGOPT=0
23560 RLOPT=1D19
23561C...Loop over partons you can connect to
23562 DO 210 IC2=1,NCR
23563 J=ICR(IC2)
23564 MSJ=MSCR(IC2)
23565C...Skip if already connected
23566 IF (MCN(J,MSJ).NE.0) GOTO 210
23567C...Skip if this not colour-anticolour pair
23568 IF (MSI.EQ.MSJ) GOTO 210
23569C...And do not let gluons connect to themselves
23570 IF (I.EQ.J) GOTO 210
23571C...Suppress direct connections between partons in same Beam Remnant
23572 MBRSTR=0
23573 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
23574 & MBRSTR=1
23575C...Shorthand for colour charge
23576 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
23577C...Check for gluon loops
23578 MGGSTR=0
23579 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
23580 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
23581 & MCN(I,2).NE.0) MGGSTR=1
23582 ENDIF
23583C...Save connection with smallest lambda measure
23584 RL=FOUR(I,J)
23585C...Optional: Seattle v2: multiply gluons by 1/2 since two strings connected
23586 IF (MSTP(95).GE.7.AND.MSTP(95).LE.8) THEN
23587 IF (K(I,2).EQ.21) RL=0.5D0*RL
23588 IF (K(J,2).EQ.21) RL=0.5D0*RL
23589 ENDIF
23590C...If best so far was a BR string and this is not, also save.
23591C...If best so far was a gg string and this is not, also save.
23592C...NB: this is not fool-proof. If the algorithm finds a BR or gg
23593C...string with a small Lambda measure as the last step, this connection
23594C...will be saved regardless of whether other possibilities existed.
23595C...I.e., there should really be a check whether another possibility has
23596C...already been found, but since these models are now actively in use
23597C...and uncertainties are anyway large, the algorithm is left as it is.
23598C...(correction --> Pythia 8 ?)
23599 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
23600 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
23601 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
23602 RLOPT=RL
23603 RLOPTC(IC1)=RLOPT
23604 IOPT(IC1)=J
23605 MBROPT=MBRSTR
23606 MGGOPT=MGGSTR
23607 ENDIF
23608 210 CONTINUE
23609 ENDIF
23610 IF (IOPT(IC1).NE.0) THEN
23611C...Save pair with largest RLOPT so far
23612 IF (RLOPT.GE.RLMAX) THEN
23613 ICRMAX=IC1
23614 RLMAX=RLOPT
23615 ENDIF
23616 ENDIF
23617 230 CONTINUE
23618C...Save and iterate
23619 IF (ICRMAX.GT.0) THEN
23620 LCT=LCT+1
23621 ILMAX=ICR(ICRMAX)
23622 JLMAX=IOPT(ICRMAX)
23623 ICMAX=MSCR(ICRMAX)
23624 JCMAX=3-ICMAX
23625 MCN(ILMAX,ICMAX)=LCT
23626 MCN(JLMAX,JCMAX)=LCT
23627 IF (NLOOP.LE.2*(N-IP)) THEN
23628 GOTO 160
23629 ELSE
23630 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
23631 CALL PYSTOP(11)
23632 ENDIF
23633 ELSE
23634C...Save and exit. First check for leftover gluon(s)
23635 DO 260 I=MAX(1,IP),N
23636C...Check colour charge
23637 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
23638 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
23639 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
23640C...Decide where to put left-over gluon (minimal insertion)
23641 ILMAX=0
23642 RLMAX=1D19
23643 DO 250 KCT=NCT+1,LCT
23644 DO 240 IT=MAX(1,IP),N
23645 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
23646 IF (MCN(IT,1).EQ.KCT) IC=IT
23647 IF (MCN(IT,2).EQ.KCT) IA=IT
23648 240 CONTINUE
23649 RL=FOUR(IC,I)*FOUR(IA,I)
23650 IF (RL.LT.RLMAX) THEN
23651 RLMAX=RL
23652 ICMAX=IC
23653 IAMAX=IA
23654 ENDIF
23655 250 CONTINUE
23656 LCT=LCT+1
23657 MCN(I,1)=MCN(ICMAX,1)
23658 MCN(I,2)=LCT
23659 MCN(ICMAX,1)=LCT
23660 ENDIF
23661 260 CONTINUE
23662C...Here we need to loop over entire event.
23663 DO 270 IZ=MAX(1,IP),N
23664C...Do not erase parton shower colour history
23665 IF (K(IZ,1).NE.3) GOTO 270
23666C...Check colour charge
23667 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
23668 IF (MCI.EQ.0) GOTO 270
23669 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
23670 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
23671 270 CONTINUE
23672 ENDIF
23673
23674 9999 RETURN
23675 END
23676
23677C*********************************************************************
23678
23679C...PYDIFF
23680C...Handles diffractive and elastic scattering.
23681
23682 SUBROUTINE PYDIFF
23683
23684C...Double precision and integer declarations.
23685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23686 IMPLICIT INTEGER(I-N)
23687 INTEGER PYK,PYCHGE,PYCOMP
23688C...Commonblocks.
23689 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23691 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23692 COMMON/PYINT1/MINT(400),VINT(400)
23693 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
23694
23695C...Reset K, P and V vectors. Store incoming particles.
23696 DO 110 JT=1,MSTP(126)+10
23697 I=MINT(83)+JT
23698 DO 100 J=1,5
23699 K(I,J)=0
23700 P(I,J)=0D0
23701 V(I,J)=0D0
23702 100 CONTINUE
23703 110 CONTINUE
23704 N=MINT(84)
23705 MINT(3)=0
23706 MINT(21)=0
23707 MINT(22)=0
23708 MINT(23)=0
23709 MINT(24)=0
23710 MINT(4)=4
23711 DO 130 JT=1,2
23712 I=MINT(83)+JT
23713 K(I,1)=21
23714 K(I,2)=MINT(10+JT)
23715 DO 120 J=1,5
23716 P(I,J)=VINT(285+5*JT+J)
23717 120 CONTINUE
23718 130 CONTINUE
23719 MINT(6)=2
23720
23721C...Subprocess; kinematics.
23722 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
23723 PZ=SQRT(SQLAM)/(2D0*VINT(1))
23724 DO 200 JT=1,2
23725 I=MINT(83)+JT
23726 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
23727 KFH=MINT(102+JT)
23728
23729C...Elastically scattered particle. (Except elastic GVMD states.)
23730 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
23731 & MINT(106+JT).NE.3)) THEN
23732 N=N+1
23733 K(N,1)=1
23734 K(N,2)=KFH
23735 K(N,3)=I+2
23736 P(N,3)=PZ*(-1)**(JT+1)
23737 P(N,4)=PE
23738 P(N,5)=SQRT(VINT(62+JT))
23739
23740C...Decay rho from elastic scattering of gamma with sin**2(theta)
23741C...distribution of decay products (in rho rest frame).
23742 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
23743 NSAV=N
23744 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
23745 P(N,3)=0D0
23746 P(N,4)=P(N,5)
23747 CALL PYDECY(NSAV)
23748 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
23749 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
23750 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
23751 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
23752 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
23753 140 CTHE=2D0*PYR(0)-1D0
23754 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
23755 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
23756 ENDIF
23757 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
23758 ENDIF
23759
23760C...Diffracted particle: low-mass system to two particles.
23761 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
23762 N=N+2
23763 K(N-1,1)=1
23764 K(N,1)=1
23765 K(N-1,3)=I+2
23766 K(N,3)=I+2
23767 PMMAS=SQRT(VINT(62+JT))
23768 NTRY=0
23769 150 NTRY=NTRY+1
23770 IF(NTRY.LT.20) THEN
23771 MINT(105)=MINT(102+JT)
23772 MINT(109)=MINT(106+JT)
23773 CALL PYSPLI(KFH,21,KFL1,KFL2)
23774 CALL PYKFDI(KFL1,0,KFL3,KF1)
23775 IF(KF1.EQ.0) GOTO 150
23776 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
23777 IF(KF2.EQ.0) GOTO 150
23778 ELSE
23779 KF1=KFH
23780 KF2=111
23781 ENDIF
23782 PM1=PYMASS(KF1)
23783 PM2=PYMASS(KF2)
23784 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
23785 K(N-1,2)=KF1
23786 K(N,2)=KF2
23787 P(N-1,5)=PM1
23788 P(N,5)=PM2
23789 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
23790 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
23791 P(N-1,3)=PZP
23792 P(N,3)=-PZP
23793 P(N-1,4)=SQRT(PM1**2+PZP**2)
23794 P(N,4)=SQRT(PM2**2+PZP**2)
23795 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
23796 & 0D0,0D0,0D0)
23797 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
23798 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
23799
23800C...Diffracted particle: valence quark kicked out.
23801 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
23802 & PARP(101))) THEN
23803 N=N+2
23804 K(N-1,1)=2
23805 K(N,1)=1
23806 K(N-1,3)=I+2
23807 K(N,3)=I+2
23808 MINT(105)=MINT(102+JT)
23809 MINT(109)=MINT(106+JT)
23810 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
23811 P(N-1,5)=PYMASS(K(N-1,2))
23812 P(N,5)=PYMASS(K(N,2))
23813 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
23814 & 4D0*P(N-1,5)**2*P(N,5)**2
23815 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
23816 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
23817 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
23818 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
23819 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23820
23821C...Diffracted particle: gluon kicked out.
23822 ELSE
23823 N=N+3
23824 K(N-2,1)=2
23825 K(N-1,1)=2
23826 K(N,1)=1
23827 K(N-2,3)=I+2
23828 K(N-1,3)=I+2
23829 K(N,3)=I+2
23830 MINT(105)=MINT(102+JT)
23831 MINT(109)=MINT(106+JT)
23832 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
23833 K(N-1,2)=21
23834 P(N-2,5)=PYMASS(K(N-2,2))
23835 P(N-1,5)=0D0
23836 P(N,5)=PYMASS(K(N,2))
23837C...Energy distribution for particle into two jets.
23838 160 IMB=1
23839 IF(MOD(KFH/1000,10).NE.0) IMB=2
23840 CHIK=PARP(92+2*IMB)
23841 IF(MSTP(92).LE.1) THEN
23842 IF(IMB.EQ.1) CHI=PYR(0)
23843 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
23844 ELSEIF(MSTP(92).EQ.2) THEN
23845 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
23846 ELSEIF(MSTP(92).EQ.3) THEN
23847 CUT=2D0*0.3D0/VINT(1)
23848 170 CHI=PYR(0)**2
23849 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
23850 & PYR(0)) GOTO 170
23851 ELSEIF(MSTP(92).EQ.4) THEN
23852 CUT=2D0*0.3D0/VINT(1)
23853 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
23854 180 CHIR=CUT*CUTR**PYR(0)
23855 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
23856 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
23857 ELSE
23858 CUT=2D0*0.3D0/VINT(1)
23859 CUTA=CUT**(1D0-PARP(98))
23860 CUTB=(1D0+CUT)**(1D0-PARP(98))
23861 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
23862 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
23863 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
23864 ENDIF
23865 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
23866 & VINT(62+JT)) GOTO 160
23867 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
23868 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
23869 & (2D0*VINT(62+JT))
23870 PEI=SQRT(PZI**2+SQM)
23871 PQQP=(1D0-CHI)*(PEI+PZI)
23872 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
23873 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
23874 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
23875 P(N-1,3)=P(N-1,4)*(-1)**JT
23876 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
23877 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
23878 ENDIF
23879
23880C...Documentation lines.
23881 K(I+2,1)=21
23882 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
23883 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
23884 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
23885 K(I+2,3)=I
23886 P(I+2,3)=PZ*(-1)**(JT+1)
23887 P(I+2,4)=PE
23888 P(I+2,5)=SQRT(VINT(62+JT))
23889 200 CONTINUE
23890
23891C...Rotate outgoing partons/particles using cos(theta).
23892 IF(VINT(23).LT.0.9D0) THEN
23893 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
23894 ELSE
23895 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
23896 ENDIF
23897
23898 RETURN
23899 END
23900
23901C*********************************************************************
23902
23903C...PYDISG
23904C...Set up a DIS process as gamma* + f -> f, with beam remnant
23905C...and showering added consecutively. Photon flux by the PYGAGA
23906C...routine (if at all).
23907
23908 SUBROUTINE PYDISG
23909
23910C...Double precision and integer declarations.
23911 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23912 IMPLICIT INTEGER(I-N)
23913 INTEGER PYK,PYCHGE,PYCOMP
23914C...Parameter statement to help give large particle numbers.
23915 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
23916 &KEXCIT=4000000,KDIMEN=5000000)
23917C...Commonblocks.
23918 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23919 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23920 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23921 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
23922 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23923 COMMON/PYINT1/MINT(400),VINT(400)
23924 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
23925C...Local arrays.
23926 DIMENSION PMS(4)
23927
23928C...Choice of subprocess, number of documentation lines
23929 IDOC=7
23930 MINT(3)=IDOC-6
23931 MINT(4)=IDOC
23932 IPU1=MINT(84)+1
23933 IPU2=MINT(84)+2
23934 IPU3=MINT(84)+3
23935 ISIDE=1
23936 IF(MINT(107).EQ.4) ISIDE=2
23937
23938C...Reset K, P and V vectors. Store incoming particles
23939 DO 110 JT=1,MSTP(126)+20
23940 I=MINT(83)+JT
23941 DO 100 J=1,5
23942 K(I,J)=0
23943 P(I,J)=0D0
23944 V(I,J)=0D0
23945 100 CONTINUE
23946 110 CONTINUE
23947 DO 130 JT=1,2
23948 I=MINT(83)+JT
23949 K(I,1)=21
23950 K(I,2)=MINT(10+JT)
23951 DO 120 J=1,5
23952 P(I,J)=VINT(285+5*JT+J)
23953 120 CONTINUE
23954 130 CONTINUE
23955 MINT(6)=2
23956
23957C...Store incoming partons in hadronic CM-frame
23958 DO 140 JT=1,2
23959 I=MINT(84)+JT
23960 K(I,1)=14
23961 K(I,2)=MINT(14+JT)
23962 K(I,3)=MINT(83)+2+JT
23963 140 CONTINUE
23964 IF(MINT(15).EQ.22) THEN
23965 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
23966 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
23967 P(MINT(84)+1,5)=-SQRT(VINT(307))
23968 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
23969 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
23970 KFRES=MINT(16)
23971 ISIDE=2
23972 ELSE
23973 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
23974 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
23975 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
23976 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
23977 P(MINT(84)+1,5)=-SQRT(VINT(308))
23978 KFRES=MINT(15)
23979 ISIDE=1
23980 ENDIF
23981 SIDESG=(-1D0)**(ISIDE-1)
23982
23983C...Copy incoming partons to documentation lines.
23984 DO 170 JT=1,2
23985 I1=MINT(83)+4+JT
23986 I2=MINT(84)+JT
23987 K(I1,1)=21
23988 K(I1,2)=K(I2,2)
23989 K(I1,3)=I1-2
23990 DO 150 J=1,5
23991 P(I1,J)=P(I2,J)
23992 150 CONTINUE
23993
23994C...Second copy for partons before ISR shower, since no such.
23995 I1=MINT(83)+2+JT
23996 K(I1,1)=21
23997 K(I1,2)=K(I2,2)
23998 K(I1,3)=I1-2
23999 DO 160 J=1,5
24000 P(I1,J)=P(I2,J)
24001 160 CONTINUE
24002 170 CONTINUE
24003
24004C...Define initial partons.
24005 NTRY=0
24006 180 NTRY=NTRY+1
24007 IF(NTRY.GT.100) THEN
24008 MINT(51)=1
24009 RETURN
24010 ENDIF
24011
24012C...Scattered quark in hadronic CM frame.
24013 I=MINT(83)+7
24014 K(IPU3,1)=3
24015 K(IPU3,2)=KFRES
24016 K(IPU3,3)=I
24017 P(IPU3,5)=PYMASS(KFRES)
24018 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24019 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24020 P(IPU3,5)=0D0
24021 K(I,1)=21
24022 K(I,2)=KFRES
24023 K(I,3)=MINT(83)+4+ISIDE
24024 P(I,3)=P(IPU3,3)
24025 P(I,4)=P(IPU3,4)
24026 P(I,5)=P(IPU3,5)
24027 N=IPU3
24028 MINT(21)=KFRES
24029 MINT(22)=0
24030
24031C...No primordial kT, or chosen according to truncated Gaussian or
24032C...exponential, or (for photon) predetermined or power law.
24033 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24034 IF(MSTP(91).LE.0) THEN
24035 PT=0D0
24036 ELSEIF(MSTP(91).EQ.1) THEN
24037 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24038 ELSE
24039 RPT1=PYR(0)
24040 RPT2=PYR(0)
24041 PT=-PARP(92)*LOG(RPT1*RPT2)
24042 ENDIF
24043 IF(PT.GT.PARP(93)) GOTO 190
24044 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24045 PTA=SQRT(VINT(282+ISIDE))
24046 PTB=0D0
24047 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24048 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24049 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24050 RPT1=PYR(0)
24051 RPT2=PYR(0)
24052 PTB=-PARP(99)*LOG(RPT1*RPT2)
24053 ENDIF
24054 IF(PTB.GT.PARP(100)) GOTO 190
24055 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24056 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24057 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24058 IF(MSTP(93).LE.0) THEN
24059 PT=0D0
24060 ELSEIF(MSTP(93).EQ.1) THEN
24061 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24062 ELSEIF(MSTP(93).EQ.2) THEN
24063 RPT1=PYR(0)
24064 RPT2=PYR(0)
24065 PT=-PARP(99)*LOG(RPT1*RPT2)
24066 ELSEIF(MSTP(93).EQ.3) THEN
24067 HA=PARP(99)**2
24068 HB=PARP(100)**2
24069 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24070 ELSE
24071 HA=PARP(99)**2
24072 HB=PARP(100)**2
24073 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24074 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24075 ENDIF
24076 IF(PT.GT.PARP(100)) GOTO 190
24077 ELSE
24078 PT=0D0
24079 ENDIF
24080 VINT(156+ISIDE)=PT
24081 PHI=PARU(2)*PYR(0)
24082 P(IPU3,1)=PT*COS(PHI)
24083 P(IPU3,2)=PT*SIN(PHI)
24084 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24085 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24086 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24087
24088C...Find one or two beam remnants.
24089 MINT(105)=MINT(102+ISIDE)
24090 MINT(109)=MINT(106+ISIDE)
24091 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24092 IF(MINT(51).NE.0) THEN
24093 MINT(51)=0
24094 GOTO 180
24095 ENDIF
24096
24097C...Store first remnant parton, with colour info and kinematics.
24098 I=N+1
24099 K(I,1)=1
24100 K(I,2)=KFLSP
24101 K(I,3)=MINT(83)+ISIDE
24102 P(I,5)=PYMASS(K(I,2))
24103 KCOL=KCHG(PYCOMP(KFLSP),2)
24104 IF(KCOL.NE.0) THEN
24105 K(I,1)=3
24106 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24107 K(I,KFLS+3)=MSTU(5)*IPU3
24108 K(IPU3,6-KFLS)=MSTU(5)*I
24109 ICOLR=I
24110 ENDIF
24111 IF(KFLCH.EQ.0) THEN
24112 P(I,1)=-P(IPU3,1)
24113 P(I,2)=-P(IPU3,2)
24114 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24115 P(I,3)=-P(IPU3,3)
24116 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24117 PRP=P(I,4)+ABS(P(I,3))
24118
24119C...When extra remnant parton or hadron: store extra remnant.
24120 ELSE
24121 I=I+1
24122 K(I,1)=1
24123 K(I,2)=KFLCH
24124 K(I,3)=MINT(83)+ISIDE
24125 P(I,5)=PYMASS(K(I,2))
24126 KCOL=KCHG(PYCOMP(KFLCH),2)
24127 IF(KCOL.NE.0) THEN
24128 K(I,1)=3
24129 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24130 K(I,KFLS+3)=MSTU(5)*IPU3
24131 K(IPU3,6-KFLS)=MSTU(5)*I
24132 ICOLR=I
24133 ENDIF
24134
24135C...Relative transverse momentum when two remnants.
24136 LOOP=0
24137 200 LOOP=LOOP+1
24138 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24139 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24140 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24141 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24142 P(I,1)=-P(IPU3,1)-P(I-1,1)
24143 P(I,2)=-P(IPU3,2)-P(I-1,2)
24144 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24145
24146C...Relative distribution of energy for particle into jet plus particle.
24147 IMB=1
24148 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24149 IF(MSTP(94).LE.1) THEN
24150 IF(IMB.EQ.1) CHI=PYR(0)
24151 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24152 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24153 ELSEIF(MSTP(94).EQ.2) THEN
24154 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24155 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24156 ELSEIF(MSTP(94).EQ.3) THEN
24157 CALL PYZDIS(1,0,PMS(4),ZZ)
24158 CHI=ZZ
24159 ELSE
24160 CALL PYZDIS(1000,0,PMS(4),ZZ)
24161 CHI=ZZ
24162 ENDIF
24163
24164C...Construct total transverse mass; reject if too large.
24165 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24166 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24167 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24168 IF(LOOP.LT.10) GOTO 200
24169 GOTO 180
24170 ENDIF
24171 VINT(158+ISIDE)=CHI
24172
24173C...Subdivide longitudinal momentum according to value selected above.
24174 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24175 PW1=(1D0-CHI)*PRP
24176 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24177 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24178 PW2=CHI*PRP
24179 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24180 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24181 ENDIF
24182 N=I
24183
24184C...Boost current and remnant systems to correct frame.
24185 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24186 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24187 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24188 &(2D0*VINT(1)*PCP)
24189 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24190 &(2D0*VINT(1)*PRP)
24191 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24192 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24193 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24194 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24195
24196C...Let current quark shower; recoil but no showering by colour partner.
24197 QMAX=2D0*SQRT(VINT(309-ISIDE))
24198 MSTJ48=MSTJ(48)
24199 MSTJ(48)=1
24200 PARJ86=PARJ(86)
24201 PARJ(86)=0D0
24202 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24203 MSTJ(48)=MSTJ48
24204 PARJ(86)=PARJ86
24205
24206 RETURN
24207 END
24208
24209C*********************************************************************
24210
24211C...PYDOCU
24212C...Handles the documentation of the process in MSTI and PARI,
24213C...and also computes cross-sections based on accumulated statistics.
24214
24215 SUBROUTINE PYDOCU
24216
24217C...Double precision and integer declarations.
24218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24219 IMPLICIT INTEGER(I-N)
24220 INTEGER PYK,PYCHGE,PYCOMP
24221C...Commonblocks.
24222 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24223 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24224 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24225 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24226 COMMON/PYINT1/MINT(400),VINT(400)
24227 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24228 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24229 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24230 &/PYINT5/
24231
24232C...Calculate Monte Carlo estimates of cross-sections.
24233 ISUB=MINT(1)
24234 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24235 NGEN(0,3)=NGEN(0,3)+1
24236 XSEC(0,3)=0D0
24237 DO 100 I=1,500
24238 IF(I.EQ.96.OR.I.EQ.97) THEN
24239 XSEC(I,3)=0D0
24240 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24241 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24242 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24243 & DBLE(NGEN(96,2)))
24244 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24245 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24246 & DBLE(NGEN(96,2)))
24247 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24248 XSEC(I,3)=0D0
24249 ELSEIF(NGEN(I,2).EQ.0) THEN
24250 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24251 & DBLE(NGEN(0,2)))
24252 ELSE
24253 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24254 & DBLE(NGEN(I,2)))
24255 ENDIF
24256 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24257 100 CONTINUE
24258
24259C...Rescale to known low-pT cross-section for standard QCD processes.
24260 IF(MSUB(95).EQ.1) THEN
24261 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24262 & XSEC(68,3)+XSEC(95,3)
24263 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24264 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24265 FAC=XSECW/XSECH
24266 XSEC(11,3)=FAC*XSEC(11,3)
24267 XSEC(12,3)=FAC*XSEC(12,3)
24268 XSEC(13,3)=FAC*XSEC(13,3)
24269 XSEC(28,3)=FAC*XSEC(28,3)
24270 XSEC(53,3)=FAC*XSEC(53,3)
24271 XSEC(68,3)=FAC*XSEC(68,3)
24272 XSEC(95,3)=FAC*XSEC(95,3)
24273 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24274 ENDIF
24275 ENDIF
24276
24277C...Save information for gamma-p and gamma-gamma.
24278 IF(MINT(121).GT.1) THEN
24279 IGA=MINT(122)
24280 CALL PYSAVE(2,IGA)
24281 CALL PYSAVE(5,0)
24282 ENDIF
24283
24284C...Reset information on hard interaction.
24285 DO 110 J=1,200
24286 MSTI(J)=0
24287 PARI(J)=0D0
24288 110 CONTINUE
24289
24290C...Copy integer valued information from MINT into MSTI.
24291 DO 120 J=1,32
24292 MSTI(J)=MINT(J)
24293 120 CONTINUE
24294 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24295
24296C...Store cross-section variables in PARI.
24297 PARI(1)=XSEC(0,3)
24298 PARI(2)=XSEC(0,3)/MINT(5)
24299 PARI(7)=VINT(97)
24300 PARI(9)=VINT(99)
24301 PARI(10)=VINT(100)
24302 VINT(98)=VINT(98)+VINT(100)
24303 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24304
24305C...Store kinematics variables in PARI.
24306 PARI(11)=VINT(1)
24307 PARI(12)=VINT(2)
24308 IF(ISUB.NE.95) THEN
24309 DO 130 J=13,26
24310 PARI(J)=VINT(30+J)
24311 130 CONTINUE
24312 PARI(29)=VINT(39)
24313 PARI(30)=VINT(40)
24314 PARI(31)=VINT(141)
24315 PARI(32)=VINT(142)
24316 PARI(33)=VINT(41)
24317 PARI(34)=VINT(42)
24318 PARI(35)=PARI(33)-PARI(34)
24319 PARI(36)=VINT(21)
24320 PARI(37)=VINT(22)
24321 PARI(38)=VINT(26)
24322 PARI(39)=VINT(157)
24323 PARI(40)=VINT(158)
24324 PARI(41)=VINT(23)
24325 PARI(42)=2D0*VINT(47)/VINT(1)
24326 ENDIF
24327
24328C...Store information on scattered partons in PARI.
24329 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24330 DO 140 IS=7,8
24331 I=MINT(IS)
24332 PARI(36+IS)=P(I,3)/VINT(1)
24333 PARI(38+IS)=P(I,4)/VINT(1)
24334 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24335 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24336 & SQRT(PR),1D20)),P(I,3))
24337 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24338 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24339 & SQRT(PR),1D20)),P(I,3))
24340 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24341 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24342 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24343 140 CONTINUE
24344 ENDIF
24345
24346C...Store sum up transverse and longitudinal momenta.
24347 PARI(65)=2D0*PARI(17)
24348 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24349 DO 150 I=MSTP(126)+1,N
24350 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24351 PT=SQRT(P(I,1)**2+P(I,2)**2)
24352 PARI(69)=PARI(69)+PT
24353 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24354 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24355 150 CONTINUE
24356 PARI(67)=PARI(68)
24357 PARI(71)=VINT(151)
24358 PARI(72)=VINT(152)
24359 PARI(73)=VINT(151)
24360 PARI(74)=VINT(152)
24361 ELSE
24362 PARI(66)=PARI(65)
24363 PARI(69)=PARI(65)
24364 ENDIF
24365
24366C...Store various other pieces of information into PARI.
24367 PARI(61)=VINT(148)
24368 PARI(75)=VINT(155)
24369 PARI(76)=VINT(156)
24370 PARI(77)=VINT(159)
24371 PARI(78)=VINT(160)
24372 PARI(81)=VINT(138)
24373
24374C...Store information on lepton -> lepton + gamma in PYGAGA.
24375 MSTI(71)=MINT(141)
24376 MSTI(72)=MINT(142)
24377 PARI(101)=VINT(301)
24378 PARI(102)=VINT(302)
24379 DO 160 I=103,114
24380 PARI(I)=VINT(I+202)
24381 160 CONTINUE
24382
24383C...Set information for PYTABU.
24384 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
24385 MSTU(161)=MINT(21)
24386 MSTU(162)=0
24387 ELSEIF(ISET(ISUB).EQ.5) THEN
24388 MSTU(161)=MINT(23)
24389 MSTU(162)=0
24390 ELSE
24391 MSTU(161)=MINT(21)
24392 MSTU(162)=MINT(22)
24393 ENDIF
24394
24395 RETURN
24396 END
24397
24398C*********************************************************************
24399
24400C...PYFRAM
24401C...Performs transformations between different coordinate frames.
24402
24403 SUBROUTINE PYFRAM(IFRAME)
24404
24405C...Double precision and integer declarations.
24406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24407 IMPLICIT INTEGER(I-N)
24408 INTEGER PYK,PYCHGE,PYCOMP
24409C...Commonblocks.
24410 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24411 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24412 COMMON/PYINT1/MINT(400),VINT(400)
24413 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
24414
24415C...Check that transformation can and should be done.
24416 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
24417 &MINT(91).EQ.1)) THEN
24418 IF(IFRAME.EQ.MINT(6)) RETURN
24419 ELSE
24420 WRITE(MSTU(11),5000) IFRAME,MINT(6)
24421 RETURN
24422 ENDIF
24423
24424 IF(MINT(6).EQ.1) THEN
24425C...Transform from fixed target or user specified frame to
24426C...overall CM frame.
24427 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
24428 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
24429 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
24430 ELSEIF(MINT(6).EQ.3) THEN
24431C...Transform from hadronic CM frame in DIS to overall CM frame.
24432 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
24433 & -VINT(225))
24434 ENDIF
24435
24436 IF(IFRAME.EQ.1) THEN
24437C...Transform from overall CM frame to fixed target or user specified
24438C...frame.
24439 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
24440 ELSEIF(IFRAME.EQ.3) THEN
24441C...Transform from overall CM frame to hadronic CM frame in DIS.
24442 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
24443 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
24444 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
24445 ENDIF
24446
24447C...Set information about new frame.
24448 MINT(6)=IFRAME
24449 MSTI(6)=IFRAME
24450
24451 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
24452 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
24453 &1X,I5)
24454
24455 RETURN
24456 END
24457
24458C*********************************************************************
24459
24460C...PYWIDT
24461C...Calculates full and partial widths of resonances.
24462
24463 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
24464
24465C...Double precision and integer declarations.
24466 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24467 IMPLICIT INTEGER(I-N)
24468 INTEGER PYK,PYCHGE,PYCOMP
24469C...Parameter statement to help give large particle numbers.
24470 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24471 &KEXCIT=4000000,KDIMEN=5000000)
24472C...Commonblocks.
24473 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24474 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24475 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
24476 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24477 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24478 COMMON/PYINT1/MINT(400),VINT(400)
24479 COMMON/PYINT4/MWID(500),WIDS(500,5)
24480 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
24481 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
24482 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
24483 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
24484 COMMON/PYPUED/IUED(0:99),RUED(0:99)
24485 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
24486 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
24487C...Local arrays and saved variables.
24488 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
24489 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
24490 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
24491C...UED: equivalences between ordered particles (451->475)
24492C...and UED particle code (5 000 000 + id)
24493 PARAMETER(KKFLMI=451,KKFLMA=475)
24494 DIMENSION CHIDEL(3), IUEDPR(25)
24495 DIMENSION IUEDEQ(KKFLMA),MUED(2)
24496 COMMON/SW1/SW21,CW21
24497 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
24498 & 6100001,6100002,6100003,6100004,6100005,6100006,
24499 & 5100001,5100002,5100003,5100004,5100005,5100006,
24500 & 6100011,6100013,6100015,
24501 & 5100012,5100011,5100014,5100013,5100016,5100015,
24502 & 5100021,5100022,5100023,5100024/
24503C...Save local variables
24504 SAVE MOFSV,WIDWSV,WID2SV
24505C...Initial values
24506 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
24507 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
24508 DATA IUEDPR/25*0/
24509C...UED: inline functions used in kk width calculus
24510 FKAC1(X,Y)=1.-X**2/Y**2
24511 FKAC2(X,Y)=2.+X**2/Y**2
24512
24513C...Compressed code and sign; mass.
24514 KFLA=IABS(KFLR)
24515 KFLS=ISIGN(1,KFLR)
24516 KC=PYCOMP(KFLA)
24517 SHR=SQRT(SH)
24518 PMR=PMAS(KC,1)
24519
24520C...Reset width information.
24521 DO 110 I=0,MDCY(KC,3)
24522 WDTP(I)=0D0
24523 DO 100 J=0,5
24524 WDTE(I,J)=0D0
24525 100 CONTINUE
24526 110 CONTINUE
24527
24528C...Allow for fudge factor to rescale resonance width.
24529 FUDGE=1D0
24530 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
24531 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
24532 IF(MSTP(110).EQ.KFLA) THEN
24533 FUDGE=PARP(110)
24534 ELSEIF(MSTP(110).EQ.-1) THEN
24535 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
24536 ELSEIF(MSTP(110).EQ.-2) THEN
24537 FUDGE=PARP(110)
24538 ENDIF
24539 ENDIF
24540
24541C...Not to be treated as a resonance: return.
24542 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
24543 &KFLA.NE.22) THEN
24544 WDTP(0)=1D0
24545 WDTE(0,0)=1D0
24546 MINT(61)=0
24547 MINT(62)=0
24548 MINT(63)=0
24549 RETURN
24550
24551C...Treatment as a resonance based on tabulated branching ratios.
24552 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
24553C...Loop over possible decay channels; skip irrelevant ones.
24554 DO 120 I=1,MDCY(KC,3)
24555 IDC=I+MDCY(KC,2)-1
24556 IF(MDME(IDC,1).LT.0) GOTO 120
24557
24558C...Read out decay products and nominal masses.
24559 KFD1=KFDP(IDC,1)
24560 KFC1=PYCOMP(KFD1)
24561C...Skip dummy modes or unrecognized particles
24562 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
24563 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
24564 PM1=PMAS(KFC1,1)
24565 KFD2=KFDP(IDC,2)
24566 KFC2=PYCOMP(KFD2)
24567 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
24568 PM2=PMAS(KFC2,1)
24569 KFD3=KFDP(IDC,3)
24570 PM3=0D0
24571 IF(KFD3.NE.0) THEN
24572 KFC3=PYCOMP(KFD3)
24573 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
24574 PM3=PMAS(KFC3,1)
24575 ENDIF
24576
24577C...Naive partial width and alternative threshold factors.
24578 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
24579 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
24580 & PM1+PM2+PM3.GE.SHR) THEN
24581 WDTP(I)=0D0
24582 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
24583 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
24584 & 4D0*PM1**2*PM2**2))/SH
24585 ELSEIF(MDME(IDC,2).EQ.52) THEN
24586 PMA=MAX(PM1,PM2,PM3)
24587 PMC=MIN(PM1,PM2,PM3)
24588 PMB=PM1+PM2+PM3-PMA-PMC
24589 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
24590 PMAN=PMA**2/SH
24591 PMBN=PMB**2/SH
24592 PMCN=PMC**2/SH
24593 PMBCN=PMBC**2/SH
24594 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
24595 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24596 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24597 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24598 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24599 & ((1D0-PMBCN)*PMBCN*SH)
24600 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
24601 WDTP(I)=WDTP(I)*SQRT(
24602 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
24603 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
24604 ELSEIF(MDME(IDC,2).EQ.53) THEN
24605 PMA=MAX(PM1,PM2,PM3)
24606 PMC=MIN(PM1,PM2,PM3)
24607 PMB=PM1+PM2+PM3-PMA-PMC
24608 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
24609 PMAN=PMA**2/SH
24610 PMBN=PMB**2/SH
24611 PMCN=PMC**2/SH
24612 PMBCN=PMBC**2/SH
24613 FACACT=SQRT(MAX(0D0,
24614 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24615 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24616 & ((SHR-PMA)**2-(PMB+PMC)**2)*
24617 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
24618 & ((1D0-PMBCN)*PMBCN*SH)
24619 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
24620 PMAN=PMA**2/PMR**2
24621 PMBN=PMB**2/PMR**2
24622 PMCN=PMC**2/PMR**2
24623 PMBCN=PMBC**2/PMR**2
24624 FACNOM=SQRT(MAX(0D0,
24625 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
24626 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
24627 & ((PMR-PMA)**2-(PMB+PMC)**2)*
24628 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
24629 & ((1D0-PMBCN)*PMBCN*PMR**2)
24630 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
24631 ENDIF
24632 WDTP(I)=FUDGE*WDTP(I)
24633 WDTP(0)=WDTP(0)+WDTP(I)
24634
24635C...Calculate secondary width (at most two identical/opposite).
24636 WID2=1D0
24637 IF(MDME(IDC,1).GT.0) THEN
24638 IF(KFD2.EQ.KFD1) THEN
24639 IF(KCHG(KFC1,3).EQ.0) THEN
24640 WID2=WIDS(KFC1,1)
24641 ELSEIF(KFD1.GT.0) THEN
24642 WID2=WIDS(KFC1,4)
24643 ELSE
24644 WID2=WIDS(KFC1,5)
24645 ENDIF
24646 IF(KFD3.GT.0) THEN
24647 WID2=WID2*WIDS(KFC3,2)
24648 ELSEIF(KFD3.LT.0) THEN
24649 WID2=WID2*WIDS(KFC3,3)
24650 ENDIF
24651 ELSEIF(KFD2.EQ.-KFD1) THEN
24652 WID2=WIDS(KFC1,1)
24653 IF(KFD3.GT.0) THEN
24654 WID2=WID2*WIDS(KFC3,2)
24655 ELSEIF(KFD3.LT.0) THEN
24656 WID2=WID2*WIDS(KFC3,3)
24657 ENDIF
24658 ELSEIF(KFD3.EQ.KFD1) THEN
24659 IF(KCHG(KFC1,3).EQ.0) THEN
24660 WID2=WIDS(KFC1,1)
24661 ELSEIF(KFD1.GT.0) THEN
24662 WID2=WIDS(KFC1,4)
24663 ELSE
24664 WID2=WIDS(KFC1,5)
24665 ENDIF
24666 IF(KFD2.GT.0) THEN
24667 WID2=WID2*WIDS(KFC2,2)
24668 ELSEIF(KFD2.LT.0) THEN
24669 WID2=WID2*WIDS(KFC2,3)
24670 ENDIF
24671 ELSEIF(KFD3.EQ.-KFD1) THEN
24672 WID2=WIDS(KFC1,1)
24673 IF(KFD2.GT.0) THEN
24674 WID2=WID2*WIDS(KFC2,2)
24675 ELSEIF(KFD2.LT.0) THEN
24676 WID2=WID2*WIDS(KFC2,3)
24677 ENDIF
24678 ELSEIF(KFD3.EQ.KFD2) THEN
24679 IF(KCHG(KFC2,3).EQ.0) THEN
24680 WID2=WIDS(KFC2,1)
24681 ELSEIF(KFD2.GT.0) THEN
24682 WID2=WIDS(KFC2,4)
24683 ELSE
24684 WID2=WIDS(KFC2,5)
24685 ENDIF
24686 IF(KFD1.GT.0) THEN
24687 WID2=WID2*WIDS(KFC1,2)
24688 ELSEIF(KFD1.LT.0) THEN
24689 WID2=WID2*WIDS(KFC1,3)
24690 ENDIF
24691 ELSEIF(KFD3.EQ.-KFD2) THEN
24692 WID2=WIDS(KFC2,1)
24693 IF(KFD1.GT.0) THEN
24694 WID2=WID2*WIDS(KFC1,2)
24695 ELSEIF(KFD1.LT.0) THEN
24696 WID2=WID2*WIDS(KFC1,3)
24697 ENDIF
24698 ELSE
24699 IF(KFD1.GT.0) THEN
24700 WID2=WIDS(KFC1,2)
24701 ELSE
24702 WID2=WIDS(KFC1,3)
24703 ENDIF
24704 IF(KFD2.GT.0) THEN
24705 WID2=WID2*WIDS(KFC2,2)
24706 ELSE
24707 WID2=WID2*WIDS(KFC2,3)
24708 ENDIF
24709 IF(KFD3.GT.0) THEN
24710 WID2=WID2*WIDS(KFC3,2)
24711 ELSEIF(KFD3.LT.0) THEN
24712 WID2=WID2*WIDS(KFC3,3)
24713 ENDIF
24714 ENDIF
24715
24716C...Store effective widths according to case.
24717 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24718 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24719 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24720 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24721 ENDIF
24722 120 CONTINUE
24723C...Return.
24724 MINT(61)=0
24725 MINT(62)=0
24726 MINT(63)=0
24727 RETURN
24728 ENDIF
24729
24730C...Here begins detailed dynamical calculation of resonance widths.
24731C...Shared treatment of Higgs states.
24732 KFHIGG=25
24733 IHIGG=1
24734 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
24735 KFHIGG=KFLA
24736 IHIGG=KFLA-33
24737 ENDIF
24738
24739C...Common electroweak and strong constants.
24740 XW=PARU(102)
24741 XWV=XW
24742 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
24743 XW1=1D0-XW
24744 AEM=PYALEM(SH)
24745 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
24746 AS=PYALPS(SH)
24747 RADC=1D0+AS/PARU(1)
24748
24749 IF(KFLA.EQ.6) THEN
24750C...t quark.
24751 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24752 RADCT=1D0-2.5D0*AS/PARU(1)
24753 DO 140 I=1,MDCY(KC,3)
24754 IDC=I+MDCY(KC,2)-1
24755 IF(MDME(IDC,1).LT.0) GOTO 140
24756 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24757 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24758 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
24759 WID2=1D0
24760 IF(I.GE.4.AND.I.LE.7) THEN
24761C...t -> W + q; including approximate QCD correction factor.
24762 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
24763 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24764 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24765 IF(KFLR.GT.0) THEN
24766 WID2=WIDS(24,2)
24767 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24768 ELSE
24769 WID2=WIDS(24,3)
24770 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24771 ENDIF
24772 ELSEIF(I.EQ.9) THEN
24773C...t -> H + b.
24774 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
24775 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24776 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
24777 & 4D0*SQRT(RM2R*RM2))
24778 WID2=WIDS(37,2)
24779 IF(KFLR.LT.0) WID2=WIDS(37,3)
24780CMRENNA++
24781 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
24782C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
24783 BETA=ATAN(RMSS(5))
24784 SINB=SIN(BETA)
24785 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
24786 ET=KCHG(6,1)/3D0
24787 T3L=SIGN(0.5D0,ET)
24788 KFC1=PYCOMP(KFDP(IDC,1))
24789 KFC2=PYCOMP(KFDP(IDC,2))
24790 PMNCHI=PMAS(KFC1,1)
24791 PMSTOP=PMAS(KFC2,1)
24792 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24793 IZ=I-9
24794 DO 130 IK=1,4
24795 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
24796 130 CONTINUE
24797 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
24798 AR=-ET*ZMIXC(IZ,1)*TANW
24799 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
24800 BR=AL
24801 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
24802 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
24803 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24804 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24805 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
24806 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
24807 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
24808 IF(KFLR.GT.0) THEN
24809 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24810 ELSE
24811 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24812 ENDIF
24813 ENDIF
24814 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
24815C...t -> ~g + ~t
24816 KFC1=PYCOMP(KFDP(IDC,1))
24817 KFC2=PYCOMP(KFDP(IDC,2))
24818 PMNCHI=PMAS(KFC1,1)
24819 PMSTOP=PMAS(KFC2,1)
24820 IF(SHR.GT.PMNCHI+PMSTOP) THEN
24821 RL=SFMIX(6,1)
24822 RR=-SFMIX(6,2)
24823 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
24824 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
24825 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
24826 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
24827 IF(KFLR.GT.0) THEN
24828 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
24829 ELSE
24830 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
24831 ENDIF
24832 ENDIF
24833 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
24834C...t -> ~gravitino + ~t
24835 XMP2=RMSS(29)**2
24836 KFC1=PYCOMP(KFDP(IDC,1))
24837 XMGR2=PMAS(KFC1,1)**2
24838 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
24839 KFC2=PYCOMP(KFDP(IDC,2))
24840 WID2=WIDS(KFC2,2)
24841 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
24842CMRENNA--
24843 ENDIF
24844 WDTP(I)=FUDGE*WDTP(I)
24845 WDTP(0)=WDTP(0)+WDTP(I)
24846 IF(MDME(IDC,1).GT.0) THEN
24847 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24848 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24849 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24850 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24851 ENDIF
24852 140 CONTINUE
24853
24854 ELSEIF(KFLA.EQ.7) THEN
24855C...b' quark.
24856 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24857 DO 150 I=1,MDCY(KC,3)
24858 IDC=I+MDCY(KC,2)-1
24859 IF(MDME(IDC,1).LT.0) GOTO 150
24860 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24861 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24862 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
24863 WID2=1D0
24864 IF(I.GE.4.AND.I.LE.7) THEN
24865C...b' -> W + q.
24866 WDTP(I)=FAC*VCKM(I-3,4)*
24867 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24868 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24869 IF(KFLR.GT.0) THEN
24870 WID2=WIDS(24,3)
24871 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
24872 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
24873 ELSE
24874 WID2=WIDS(24,2)
24875 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
24876 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
24877 ENDIF
24878 WID2=WIDS(24,3)
24879 IF(KFLR.LT.0) WID2=WIDS(24,2)
24880 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24881C...b' -> H + q.
24882 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24883 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24884 IF(KFLR.GT.0) THEN
24885 WID2=WIDS(37,3)
24886 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
24887 ELSE
24888 WID2=WIDS(37,2)
24889 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
24890 ENDIF
24891 ENDIF
24892 WDTP(I)=FUDGE*WDTP(I)
24893 WDTP(0)=WDTP(0)+WDTP(I)
24894 IF(MDME(IDC,1).GT.0) THEN
24895 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24896 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24897 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24898 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24899 ENDIF
24900 150 CONTINUE
24901
24902 ELSEIF(KFLA.EQ.8) THEN
24903C...t' quark.
24904 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24905 DO 160 I=1,MDCY(KC,3)
24906 IDC=I+MDCY(KC,2)-1
24907 IF(MDME(IDC,1).LT.0) GOTO 160
24908 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24909 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24910 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
24911 WID2=1D0
24912 IF(I.GE.4.AND.I.LE.7) THEN
24913C...t' -> W + q.
24914 WDTP(I)=FAC*VCKM(4,I-3)*
24915 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24916 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24917 IF(KFLR.GT.0) THEN
24918 WID2=WIDS(24,2)
24919 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
24920 ELSE
24921 WID2=WIDS(24,3)
24922 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
24923 ENDIF
24924 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
24925C...t' -> H + q.
24926 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24927 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
24928 IF(KFLR.GT.0) THEN
24929 WID2=WIDS(37,2)
24930 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
24931 ELSE
24932 WID2=WIDS(37,3)
24933 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
24934 ENDIF
24935 ENDIF
24936 WDTP(I)=FUDGE*WDTP(I)
24937 WDTP(0)=WDTP(0)+WDTP(I)
24938 IF(MDME(IDC,1).GT.0) THEN
24939 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24940 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24941 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24942 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24943 ENDIF
24944 160 CONTINUE
24945
24946 ELSEIF(KFLA.EQ.17) THEN
24947C...tau' lepton.
24948 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24949 DO 170 I=1,MDCY(KC,3)
24950 IDC=I+MDCY(KC,2)-1
24951 IF(MDME(IDC,1).LT.0) GOTO 170
24952 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24953 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24954 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
24955 WID2=1D0
24956 IF(I.EQ.3) THEN
24957C...tau' -> W + nu'_tau.
24958 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24959 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
24960 IF(KFLR.GT.0) THEN
24961 WID2=WIDS(24,3)
24962 WID2=WID2*WIDS(18,2)
24963 ELSE
24964 WID2=WIDS(24,2)
24965 WID2=WID2*WIDS(18,3)
24966 ENDIF
24967 ELSEIF(I.EQ.5) THEN
24968C...tau' -> H + nu'_tau.
24969 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
24970 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
24971 IF(KFLR.GT.0) THEN
24972 WID2=WIDS(37,3)
24973 WID2=WID2*WIDS(18,2)
24974 ELSE
24975 WID2=WIDS(37,2)
24976 WID2=WID2*WIDS(18,3)
24977 ENDIF
24978 ENDIF
24979 WDTP(I)=FUDGE*WDTP(I)
24980 WDTP(0)=WDTP(0)+WDTP(I)
24981 IF(MDME(IDC,1).GT.0) THEN
24982 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
24983 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
24984 WDTE(I,0)=WDTE(I,MDME(IDC,1))
24985 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
24986 ENDIF
24987 170 CONTINUE
24988
24989 ELSEIF(KFLA.EQ.18) THEN
24990C...nu'_tau neutrino.
24991 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
24992 DO 180 I=1,MDCY(KC,3)
24993 IDC=I+MDCY(KC,2)-1
24994 IF(MDME(IDC,1).LT.0) GOTO 180
24995 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
24996 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
24997 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
24998 WID2=1D0
24999 IF(I.EQ.2) THEN
25000C...nu'_tau -> W + tau'.
25001 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25002 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25003 IF(KFLR.GT.0) THEN
25004 WID2=WIDS(24,2)
25005 WID2=WID2*WIDS(17,2)
25006 ELSE
25007 WID2=WIDS(24,3)
25008 WID2=WID2*WIDS(17,3)
25009 ENDIF
25010 ELSEIF(I.EQ.3) THEN
25011C...nu'_tau -> H + tau'.
25012 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25013 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25014 IF(KFLR.GT.0) THEN
25015 WID2=WIDS(37,2)
25016 WID2=WID2*WIDS(17,2)
25017 ELSE
25018 WID2=WIDS(37,3)
25019 WID2=WID2*WIDS(17,3)
25020 ENDIF
25021 ENDIF
25022 WDTP(I)=FUDGE*WDTP(I)
25023 WDTP(0)=WDTP(0)+WDTP(I)
25024 IF(MDME(IDC,1).GT.0) THEN
25025 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25026 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25027 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25028 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25029 ENDIF
25030 180 CONTINUE
25031
25032 ELSEIF(KFLA.EQ.21) THEN
25033C...QCD:
25034C***Note that widths are not given in dimensional quantities here.
25035 DO 190 I=1,MDCY(KC,3)
25036 IDC=I+MDCY(KC,2)-1
25037 IF(MDME(IDC,1).LT.0) GOTO 190
25038 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25039 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25040 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25041 WID2=1D0
25042 IF(I.LE.8) THEN
25043C...QCD -> q + qbar
25044 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25045 IF(I.EQ.6) WID2=WIDS(6,1)
25046 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25047 ENDIF
25048 WDTP(I)=FUDGE*WDTP(I)
25049 WDTP(0)=WDTP(0)+WDTP(I)
25050 IF(MDME(IDC,1).GT.0) THEN
25051 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25052 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25053 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25054 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25055 ENDIF
25056 190 CONTINUE
25057
25058 ELSEIF(KFLA.EQ.22) THEN
25059C...QED photon.
25060C***Note that widths are not given in dimensional quantities here.
25061 DO 200 I=1,MDCY(KC,3)
25062 IDC=I+MDCY(KC,2)-1
25063 IF(MDME(IDC,1).LT.0) GOTO 200
25064 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25065 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25066 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25067 WID2=1D0
25068 IF(I.LE.8) THEN
25069C...QED -> q + qbar.
25070 EF=KCHG(I,1)/3D0
25071 FCOF=3D0*RADC
25072 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25073 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25074 IF(I.EQ.6) WID2=WIDS(6,1)
25075 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25076 ELSEIF(I.LE.12) THEN
25077C...QED -> l+ + l-.
25078 EF=KCHG(9+2*(I-8),1)/3D0
25079 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25080 IF(I.EQ.12) WID2=WIDS(17,1)
25081 ENDIF
25082 WDTP(I)=FUDGE*WDTP(I)
25083 WDTP(0)=WDTP(0)+WDTP(I)
25084 IF(MDME(IDC,1).GT.0) THEN
25085 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25086 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25087 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25088 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25089 ENDIF
25090 200 CONTINUE
25091
25092 ELSEIF(KFLA.EQ.23) THEN
25093C...Z0:
25094 ICASE=1
25095 XWC=1D0/(16D0*XW*XW1)
25096 FAC=(AEM*XWC/3D0)*SHR
25097 210 CONTINUE
25098 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25099 VINT(111)=0D0
25100 VINT(112)=0D0
25101 VINT(114)=0D0
25102 ENDIF
25103 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25104 KFI=IABS(MINT(15))
25105 IF(KFI.GT.20) KFI=IABS(MINT(16))
25106 EI=KCHG(KFI,1)/3D0
25107 AI=SIGN(1D0,EI)
25108 VI=AI-4D0*EI*XWV
25109 SQMZ=PMAS(23,1)**2
25110 HZ=SHR*WDTP(0)
25111 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25112 IF(MSTP(43).EQ.3) VINT(112)=
25113 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25114 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25115 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25116 ENDIF
25117 DO 220 I=1,MDCY(KC,3)
25118 IDC=I+MDCY(KC,2)-1
25119 IF(MDME(IDC,1).LT.0) GOTO 220
25120 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25121 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25122 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25123 WID2=1D0
25124 IF(I.LE.8) THEN
25125C...Z0 -> q + qbar
25126 EF=KCHG(I,1)/3D0
25127 AF=SIGN(1D0,EF+0.1D0)
25128 VF=AF-4D0*EF*XWV
25129 FCOF=3D0*RADC
25130 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25131 IF(I.EQ.6) WID2=WIDS(6,1)
25132 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25133 ELSEIF(I.LE.16) THEN
25134C...Z0 -> l+ + l-, nu + nubar
25135 EF=KCHG(I+2,1)/3D0
25136 AF=SIGN(1D0,EF+0.1D0)
25137 VF=AF-4D0*EF*XWV
25138 FCOF=1D0
25139 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25140 ENDIF
25141 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25142 IF(ICASE.EQ.1) THEN
25143 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25144 & BE34
25145 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25146 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25147 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25148 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25149 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25150 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25151 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25152 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25153 ENDIF
25154 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25155 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25156 IF(MDME(IDC,1).GT.0) THEN
25157 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25158 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25159 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25160 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25161 & WDTE(I,MDME(IDC,1))
25162 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25163 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25164 ENDIF
25165 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25166 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25167 & VINT(111)+FGGF*WID2
25168 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25169 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25170 & VINT(114)+FZZF*WID2
25171 ENDIF
25172 ENDIF
25173 220 CONTINUE
25174 IF(MINT(61).GE.1) ICASE=3-ICASE
25175 IF(ICASE.EQ.2) GOTO 210
25176
25177 ELSEIF(KFLA.EQ.24) THEN
25178C...W+/-:
25179 FAC=(AEM/(24D0*XW))*SHR
25180 DO 230 I=1,MDCY(KC,3)
25181 IDC=I+MDCY(KC,2)-1
25182 IF(MDME(IDC,1).LT.0) GOTO 230
25183 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25184 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25185 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25186 WID2=1D0
25187 IF(I.LE.16) THEN
25188C...W+/- -> q + qbar'
25189 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25190 IF(KFLR.GT.0) THEN
25191 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25192 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25193 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25194 ELSE
25195 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25196 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25197 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25198 ENDIF
25199 ELSEIF(I.LE.20) THEN
25200C...W+/- -> l+/- + nu
25201 FCOF=1D0
25202 IF(KFLR.GT.0) THEN
25203 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25204 ELSE
25205 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25206 ENDIF
25207 ENDIF
25208 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25209 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25210 WDTP(I)=FUDGE*WDTP(I)
25211 WDTP(0)=WDTP(0)+WDTP(I)
25212 IF(MDME(IDC,1).GT.0) THEN
25213 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25214 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25215 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25216 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25217 ENDIF
25218 230 CONTINUE
25219
25220 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25221C...h0 (or H0, or A0):
25222 SHFS=SH
25223 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25224 DO 270 I=1,MDCY(KFHIGG,3)
25225 IDC=I+MDCY(KFHIGG,2)-1
25226 IF(MDME(IDC,1).LT.0) GOTO 270
25227 KFC1=PYCOMP(KFDP(IDC,1))
25228 KFC2=PYCOMP(KFDP(IDC,2))
25229 RM1=PMAS(KFC1,1)**2/SH
25230 RM2=PMAS(KFC2,1)**2/SH
25231 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25232 & GOTO 270
25233 WID2=1D0
25234
25235 IF(I.LE.8) THEN
25236C...h0 -> q + qbar
25237 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25238 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25239C...A0 behaves like beta, ho and H0 like beta**3.
25240 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25241 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25242 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25243 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25244 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25245 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25246 IF(IHIGG.NE.3) THEN
25247 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25248 & PARU(151+10*IHIGG))**2
25249 ENDIF
25250 ENDIF
25251 ENDIF
25252 IF(I.EQ.6) WID2=WIDS(6,1)
25253 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25254 ELSEIF(I.LE.12) THEN
25255C...h0 -> l+ + l-
25256 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25257C...A0 behaves like beta, ho and H0 like beta**3.
25258 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25259 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25260 & PARU(153+10*IHIGG)**2
25261 IF(I.EQ.12) WID2=WIDS(17,1)
25262
25263 ELSEIF(I.EQ.13) THEN
25264C...h0 -> g + g; quark loop contribution only
25265 ETARE=0D0
25266 ETAIM=0D0
25267 DO 240 J=1,2*MSTP(1)
25268 EPS=(2D0*PMAS(J,1))**2/SH
25269C...Loop integral; function of eps=4m^2/shat; different for A0.
25270 IF(EPS.LE.1D0) THEN
25271 IF(EPS.GT.1D-4) THEN
25272 ROOT=SQRT(1D0-EPS)
25273 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25274 ELSE
25275 RLN=LOG(4D0/EPS-2D0)
25276 ENDIF
25277 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25278 PHIIM=0.5D0*PARU(1)*RLN
25279 ELSE
25280 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25281 PHIIM=0D0
25282 ENDIF
25283 IF(IHIGG.LE.2) THEN
25284 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25285 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25286 ELSE
25287 ETAREJ=-0.5D0*EPS*PHIRE
25288 ETAIMJ=-0.5D0*EPS*PHIIM
25289 ENDIF
25290C...Couplings (=1 for standard model Higgs).
25291 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25292 IF(MOD(J,2).EQ.1) THEN
25293 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25294 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25295 ELSE
25296 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25297 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25298 ENDIF
25299 ENDIF
25300 ETARE=ETARE+ETAREJ
25301 ETAIM=ETAIM+ETAIMJ
25302 240 CONTINUE
25303 ETA2=ETARE**2+ETAIM**2
25304 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25305
25306 ELSEIF(I.EQ.14) THEN
25307C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25308 ETARE=0D0
25309 ETAIM=0D0
25310 JMAX=3*MSTP(1)+1
25311 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25312 DO 250 J=1,JMAX
25313 IF(J.LE.2*MSTP(1)) THEN
25314 EJ=KCHG(J,1)/3D0
25315 EPS=(2D0*PMAS(J,1))**2/SH
25316 ELSEIF(J.LE.3*MSTP(1)) THEN
25317 JL=2*(J-2*MSTP(1))-1
25318 EJ=KCHG(10+JL,1)/3D0
25319 EPS=(2D0*PMAS(10+JL,1))**2/SH
25320 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25321 EPS=(2D0*PMAS(24,1))**2/SH
25322 ELSE
25323 EPS=(2D0*PMAS(37,1))**2/SH
25324 ENDIF
25325C...Loop integral; function of eps=4m^2/shat.
25326 IF(EPS.LE.1D0) THEN
25327 IF(EPS.GT.1D-4) THEN
25328 ROOT=SQRT(1D0-EPS)
25329 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25330 ELSE
25331 RLN=LOG(4D0/EPS-2D0)
25332 ENDIF
25333 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25334 PHIIM=0.5D0*PARU(1)*RLN
25335 ELSE
25336 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25337 PHIIM=0D0
25338 ENDIF
25339 IF(J.LE.3*MSTP(1)) THEN
25340C...Fermion loops: loop integral different for A0; charges.
25341 IF(IHIGG.LE.2) THEN
25342 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25343 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25344 ELSE
25345 PHIPRE=-0.5D0*EPS*PHIRE
25346 PHIPIM=-0.5D0*EPS*PHIIM
25347 ENDIF
25348 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25349 EJC=3D0*EJ**2
25350 EJH=PARU(151+10*IHIGG)
25351 ELSEIF(J.LE.2*MSTP(1)) THEN
25352 EJC=3D0*EJ**2
25353 EJH=PARU(152+10*IHIGG)
25354 ELSE
25355 EJC=EJ**2
25356 EJH=PARU(153+10*IHIGG)
25357 ENDIF
25358 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25359 ETAREJ=EJC*EJH*PHIPRE
25360 ETAIMJ=EJC*EJH*PHIPIM
25361 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25362C...W loops: loop integral and charges.
25363 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
25364 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
25365 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25366 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25367 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25368 ENDIF
25369 ELSE
25370C...Charged H loops: loop integral and charges.
25371 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
25372 & PARU(158+10*IHIGG+2*(IHIGG/3))
25373 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
25374 ETAIMJ=-EPS**2*PHIIM*FACHHH
25375 ENDIF
25376 ETARE=ETARE+ETAREJ
25377 ETAIM=ETAIM+ETAIMJ
25378 250 CONTINUE
25379 ETA2=ETARE**2+ETAIM**2
25380 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
25381
25382 ELSEIF(I.EQ.15) THEN
25383C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
25384 ETARE=0D0
25385 ETAIM=0D0
25386 JMAX=3*MSTP(1)+1
25387 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25388 DO 260 J=1,JMAX
25389 IF(J.LE.2*MSTP(1)) THEN
25390 EJ=KCHG(J,1)/3D0
25391 AJ=SIGN(1D0,EJ+0.1D0)
25392 VJ=AJ-4D0*EJ*XWV
25393 EPS=(2D0*PMAS(J,1))**2/SH
25394 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
25395 ELSEIF(J.LE.3*MSTP(1)) THEN
25396 JL=2*(J-2*MSTP(1))-1
25397 EJ=KCHG(10+JL,1)/3D0
25398 AJ=SIGN(1D0,EJ+0.1D0)
25399 VJ=AJ-4D0*EJ*XWV
25400 EPS=(2D0*PMAS(10+JL,1))**2/SH
25401 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
25402 ELSE
25403 EPS=(2D0*PMAS(24,1))**2/SH
25404 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
25405 ENDIF
25406C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
25407 IF(EPS.LE.1D0) THEN
25408 ROOT=SQRT(1D0-EPS)
25409 IF(EPS.GT.1D-4) THEN
25410 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25411 ELSE
25412 RLN=LOG(4D0/EPS-2D0)
25413 ENDIF
25414 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25415 PHIIM=0.5D0*PARU(1)*RLN
25416 PSIRE=0.5D0*ROOT*RLN
25417 PSIIM=-0.5D0*ROOT*PARU(1)
25418 ELSE
25419 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25420 PHIIM=0D0
25421 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
25422 PSIIM=0D0
25423 ENDIF
25424 IF(EPSP.LE.1D0) THEN
25425 ROOT=SQRT(1D0-EPSP)
25426 IF(EPSP.GT.1D-4) THEN
25427 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25428 ELSE
25429 RLN=LOG(4D0/EPSP-2D0)
25430 ENDIF
25431 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
25432 PHIIMP=0.5D0*PARU(1)*RLN
25433 PSIREP=0.5D0*ROOT*RLN
25434 PSIIMP=-0.5D0*ROOT*PARU(1)
25435 ELSE
25436 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
25437 PHIIMP=0D0
25438 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
25439 PSIIMP=0D0
25440 ENDIF
25441 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
25442 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
25443 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
25444 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
25445 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
25446 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
25447 IF(J.LE.3*MSTP(1)) THEN
25448C...Fermion loops: loop integral different for A0; charges.
25449 IF(IHIGG.EQ.3) FXYRE=0D0
25450 IF(IHIGG.EQ.3) FXYIM=0D0
25451 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25452 EJC=-3D0*EJ*VJ
25453 EJH=PARU(151+10*IHIGG)
25454 ELSEIF(J.LE.2*MSTP(1)) THEN
25455 EJC=-3D0*EJ*VJ
25456 EJH=PARU(152+10*IHIGG)
25457 ELSE
25458 EJC=-EJ*VJ
25459 EJH=PARU(153+10*IHIGG)
25460 ENDIF
25461 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
25462 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
25463 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
25464 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25465C...W loops: loop integral and charges.
25466 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
25467 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
25468 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
25469 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25470 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
25471 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
25472 ENDIF
25473 ELSE
25474C...Charged H loops: loop integral and charges.
25475 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
25476 & PARU(158+10*IHIGG+2*(IHIGG/3))
25477 ETAREJ=FACHHH*FXYRE
25478 ETAIMJ=FACHHH*FXYIM
25479 ENDIF
25480 ETARE=ETARE+ETAREJ
25481 ETAIM=ETAIM+ETAIMJ
25482 260 CONTINUE
25483 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
25484 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
25485 WID2=WIDS(23,2)
25486
25487 ELSEIF(I.LE.17) THEN
25488C...h0 -> Z0 + Z0, W+ + W-
25489 PM1=PMAS(IABS(KFDP(IDC,1)),1)
25490 PG1=PMAS(IABS(KFDP(IDC,1)),2)
25491 IF(MINT(62).GE.1) THEN
25492 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
25493 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
25494 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
25495 MOFSV(IHIGG,I-15)=0
25496 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25497 & 1D0-4D0*RM1))
25498 WID2=1D0
25499 ELSE
25500 MOFSV(IHIGG,I-15)=1
25501 RMAS=SQRT(MAX(0D0,SH))
25502 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
25503 & WID2)
25504 WIDWSV(IHIGG,I-15)=WIDW
25505 WID2SV(IHIGG,I-15)=WID2
25506 ENDIF
25507 ELSE
25508 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
25509 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
25510 & 1D0-4D0*RM1))
25511 WID2=1D0
25512 ELSE
25513 WIDW=WIDWSV(IHIGG,I-15)
25514 WID2=WID2SV(IHIGG,I-15)
25515 ENDIF
25516 ENDIF
25517 WDTP(I)=FAC*WIDW/(2D0*(18-I))
25518 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
25519 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25520 & PARU(138+I+10*IHIGG)**2
25521 WID2=WID2*WIDS(7+I,1)
25522
25523 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
25524C...H0 -> Z0 + h0, A0-> Z0 + h0
25525 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25526 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25527 IF(IHIGG.EQ.2) THEN
25528 WDTP(I)=WDTP(I)*PARU(179)**2
25529 ELSEIF(IHIGG.EQ.3) THEN
25530 WDTP(I)=WDTP(I)*PARU(186)**2
25531 ENDIF
25532 WID2=WIDS(23,2)*WIDS(25,2)
25533
25534 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
25535C...H0 -> h0 + h0, A0-> h0 + h0
25536 WDTP(I)=FAC*0.25D0*
25537 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25538 IF(IHIGG.EQ.2) THEN
25539 WDTP(I)=WDTP(I)*PARU(176)**2
25540 ELSEIF(IHIGG.EQ.3) THEN
25541 WDTP(I)=WDTP(I)*PARU(169)**2
25542 ENDIF
25543 WID2=WIDS(25,1)
25544 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
25545C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
25546 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
25547 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25548 & *PARU(195+IHIGG)**2
25549 IF(I.EQ.20) THEN
25550 WID2=WIDS(24,2)*WIDS(37,3)
25551 ELSEIF(I.EQ.21) THEN
25552 WID2=WIDS(24,3)*WIDS(37,2)
25553 ENDIF
25554
25555 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
25556C...H0 -> Z0 + A0.
25557 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
25558 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25559 WID2=WIDS(36,2)*WIDS(23,2)
25560
25561 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
25562C...H0 -> h0 + A0.
25563 WDTP(I)=FAC*0.5D0*PARU(180)**2*
25564 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25565 WID2=WIDS(25,2)*WIDS(36,2)
25566
25567 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
25568C...H0 -> A0 + A0
25569 WDTP(I)=FAC*0.25D0*PARU(177)**2*
25570 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
25571 WID2=WIDS(36,1)
25572
25573CMRENNA++
25574 ELSE
25575C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25576 RM10=RM1*SH/PMR**2
25577 RM20=RM2*SH/PMR**2
25578 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25579 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25580 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25581 WFAC=0D0
25582 ELSE
25583 WFAC=WFAC/WFAC0
25584 ENDIF
25585 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25586CMRENNA--
25587 IF(KFC2.EQ.KFC1) THEN
25588 WID2=WIDS(KFC1,1)
25589 ELSE
25590 KSGN1=2
25591 IF(KFDP(IDC,1).LT.0) KSGN1=3
25592 KSGN2=2
25593 IF(KFDP(IDC,2).LT.0) KSGN2=3
25594 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25595 ENDIF
25596 ENDIF
25597 WDTP(I)=FUDGE*WDTP(I)
25598 WDTP(0)=WDTP(0)+WDTP(I)
25599 IF(MDME(IDC,1).GT.0) THEN
25600 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25601 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25602 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25603 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25604 ENDIF
25605 270 CONTINUE
25606
25607 ELSEIF(KFLA.EQ.32) THEN
25608C...Z'0:
25609 ICASE=1
25610 XWC=1D0/(16D0*XW*XW1)
25611 FAC=(AEM*XWC/3D0)*SHR
25612 VINT(117)=0D0
25613 280 CONTINUE
25614 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25615 VINT(111)=0D0
25616 VINT(112)=0D0
25617 VINT(113)=0D0
25618 VINT(114)=0D0
25619 VINT(115)=0D0
25620 VINT(116)=0D0
25621 ENDIF
25622 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25623 KFAI=IABS(MINT(15))
25624 EI=KCHG(KFAI,1)/3D0
25625 AI=SIGN(1D0,EI+0.1D0)
25626 VI=AI-4D0*EI*XWV
25627 KFAIC=1
25628 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
25629 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
25630 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
25631 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
25632 VPI=PARU(119+2*KFAIC)
25633 API=PARU(120+2*KFAIC)
25634 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
25635 VPI=PARJ(178+2*KFAIC)
25636 API=PARJ(179+2*KFAIC)
25637 ELSE
25638 VPI=PARJ(186+2*KFAIC)
25639 API=PARJ(187+2*KFAIC)
25640 ENDIF
25641 SQMZ=PMAS(23,1)**2
25642 HZ=SHR*VINT(117)
25643 SQMZP=PMAS(32,1)**2
25644 HZP=SHR*WDTP(0)
25645 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25646 & MSTP(44).EQ.7) VINT(111)=1D0
25647 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
25648 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25649 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
25650 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
25651 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25652 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25653 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
25654 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
25655 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
25656 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25657 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
25658 ENDIF
25659 DO 290 I=1,MDCY(KC,3)
25660 IDC=I+MDCY(KC,2)-1
25661 IF(MDME(IDC,1).LT.0) GOTO 290
25662 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25663 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25664 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
25665 WID2=1D0
25666 IF(I.LE.16) THEN
25667 IF(I.LE.8) THEN
25668C...Z'0 -> q + qbar
25669 EF=KCHG(I,1)/3D0
25670 AF=SIGN(1D0,EF+0.1D0)
25671 VF=AF-4D0*EF*XWV
25672 IF(I.LE.2) THEN
25673 VPF=PARU(123-2*MOD(I,2))
25674 APF=PARU(124-2*MOD(I,2))
25675 ELSEIF(I.LE.4) THEN
25676 VPF=PARJ(182-2*MOD(I,2))
25677 APF=PARJ(183-2*MOD(I,2))
25678 ELSE
25679 VPF=PARJ(190-2*MOD(I,2))
25680 APF=PARJ(191-2*MOD(I,2))
25681 ENDIF
25682 FCOF=3D0*RADC
25683 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
25684 & PYHFTH(SH,SH*RM1,1D0)
25685 IF(I.EQ.6) WID2=WIDS(6,1)
25686 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25687 ELSEIF(I.LE.16) THEN
25688C...Z'0 -> l+ + l-, nu + nubar
25689 EF=KCHG(I+2,1)/3D0
25690 AF=SIGN(1D0,EF+0.1D0)
25691 VF=AF-4D0*EF*XWV
25692 IF(I.LE.10) THEN
25693 VPF=PARU(127-2*MOD(I,2))
25694 APF=PARU(128-2*MOD(I,2))
25695 ELSEIF(I.LE.12) THEN
25696 VPF=PARJ(186-2*MOD(I,2))
25697 APF=PARJ(187-2*MOD(I,2))
25698 ELSE
25699 VPF=PARJ(194-2*MOD(I,2))
25700 APF=PARJ(195-2*MOD(I,2))
25701 ENDIF
25702 FCOF=1D0
25703 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25704 ENDIF
25705 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25706 IF(ICASE.EQ.1) THEN
25707 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25708 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
25709 & APF**2*(1D0-4D0*RM1))*BE34
25710 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25711 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25712 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
25713 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
25714 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
25715 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
25716 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
25717 ELSEIF(MINT(61).EQ.2) THEN
25718 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25719 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25720 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
25721 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25722 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
25723 & BE34
25724 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
25725 & BE34
25726 ENDIF
25727 ELSEIF(I.EQ.17) THEN
25728C...Z'0 -> W+ + W-
25729 WDTPZP=PARU(129)**2*XW1**2*
25730 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25731 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25732 IF(ICASE.EQ.1) THEN
25733 WDTPZ=0D0
25734 WDTP(I)=FAC*WDTPZP
25735 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25736 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25737 ELSEIF(MINT(61).EQ.2) THEN
25738 FGGF=0D0
25739 FGZF=0D0
25740 FGZPF=0D0
25741 FZZF=0D0
25742 FZZPF=0D0
25743 FZPZPF=WDTPZP
25744 ENDIF
25745 WID2=WIDS(24,1)
25746 ELSEIF(I.EQ.18) THEN
25747C...Z'0 -> H+ + H-
25748 CZC=2D0*(1D0-2D0*XW)
25749 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25750 IF(ICASE.EQ.1) THEN
25751 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
25752 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
25753 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25754 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
25755 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
25756 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
25757 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
25758 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
25759 ELSEIF(MINT(61).EQ.2) THEN
25760 FGGF=0.25D0*BE34C
25761 FGZF=0.25D0*PARU(142)*CZC*BE34C
25762 FGZPF=0.25D0*PARU(143)*CZC*BE34C
25763 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
25764 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
25765 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
25766 ENDIF
25767 WID2=WIDS(37,1)
25768 ELSEIF(I.EQ.19) THEN
25769C...Z'0 -> Z0 + gamma.
25770 ELSEIF(I.EQ.20) THEN
25771C...Z'0 -> Z0 + h0
25772 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25773 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
25774 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
25775 IF(ICASE.EQ.1) THEN
25776 WDTPZ=0D0
25777 WDTP(I)=FAC*WDTPZP
25778 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25779 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
25780 ELSEIF(MINT(61).EQ.2) THEN
25781 FGGF=0D0
25782 FGZF=0D0
25783 FGZPF=0D0
25784 FZZF=0D0
25785 FZZPF=0D0
25786 FZPZPF=WDTPZP
25787 ENDIF
25788 WID2=WIDS(23,2)*WIDS(25,2)
25789 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
25790C...Z' -> h0 + A0 or H0 + A0.
25791 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25792 IF(I.EQ.21) THEN
25793 CZAH=PARU(186)
25794 CZPAH=PARU(188)
25795 ELSE
25796 CZAH=PARU(187)
25797 CZPAH=PARU(189)
25798 ENDIF
25799 IF(ICASE.EQ.1) THEN
25800 WDTPZ=CZAH**2*BE34C
25801 WDTP(I)=FAC*CZPAH**2*BE34C
25802 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25803 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
25804 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
25805 & VINT(116))*BE34C
25806 ELSEIF(MINT(61).EQ.2) THEN
25807 FGGF=0D0
25808 FGZF=0D0
25809 FGZPF=0D0
25810 FZZF=CZAH**2*BE34C
25811 FZZPF=CZAH*CZPAH*BE34C
25812 FZPZPF=CZPAH**2*BE34C
25813 ENDIF
25814 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
25815 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
25816 ENDIF
25817 IF(ICASE.EQ.1) THEN
25818 VINT(117)=VINT(117)+FAC*WDTPZ
25819 WDTP(I)=FUDGE*WDTP(I)
25820 WDTP(0)=WDTP(0)+WDTP(I)
25821 ENDIF
25822 IF(MDME(IDC,1).GT.0) THEN
25823 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25824 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25825 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25826 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25827 & WDTE(I,MDME(IDC,1))
25828 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25829 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25830 ENDIF
25831 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25832 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
25833 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
25834 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
25835 & FGZF*WID2
25836 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
25837 & FGZPF*WID2
25838 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
25839 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
25840 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
25841 & FZZPF*WID2
25842 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
25843 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
25844 ENDIF
25845 ENDIF
25846 290 CONTINUE
25847 IF(MINT(61).GE.1) ICASE=3-ICASE
25848 IF(ICASE.EQ.2) GOTO 280
25849
25850 ELSEIF(KFLA.EQ.34) THEN
25851C...W'+/-:
25852 FAC=(AEM/(24D0*XW))*SHR
25853 DO 300 I=1,MDCY(KC,3)
25854 IDC=I+MDCY(KC,2)-1
25855 IF(MDME(IDC,1).LT.0) GOTO 300
25856 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25857 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25858 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
25859 WID2=1D0
25860 IF(I.LE.20) THEN
25861 IF(I.LE.16) THEN
25862C...W'+/- -> q + qbar'
25863 FCOF=3D0*RADC*(PARU(131)**2+PARU(132)**2)*
25864 & VCKM((I-1)/4+1,MOD(I-1,4)+1)
25865 IF(KFLR.GT.0) THEN
25866 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25867 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25868 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25869 ELSE
25870 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25871 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25872 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25873 ENDIF
25874 ELSEIF(I.LE.20) THEN
25875C...W'+/- -> l+/- + nu
25876 FCOF=PARU(133)**2+PARU(134)**2
25877 IF(KFLR.GT.0) THEN
25878 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25879 ELSE
25880 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25881 ENDIF
25882 ENDIF
25883 WDTP(I)=FAC*FCOF*0.5D0*(2D0-RM1-RM2-(RM1-RM2)**2)*
25884 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25885 ELSEIF(I.EQ.21) THEN
25886C...W'+/- -> W+/- + Z0
25887 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
25888 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
25889 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
25890 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
25891 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
25892 ELSEIF(I.EQ.23) THEN
25893C...W'+/- -> W+/- + h0
25894 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25895 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
25896 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25897 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25898 ENDIF
25899 WDTP(I)=FUDGE*WDTP(I)
25900 WDTP(0)=WDTP(0)+WDTP(I)
25901 IF(MDME(IDC,1).GT.0) THEN
25902 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25903 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25904 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25905 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25906 ENDIF
25907 300 CONTINUE
25908
25909 ELSEIF(KFLA.EQ.37) THEN
25910C...H+/-:
25911C IF(MSTP(49).EQ.0) THEN
25912 SHFS=SH
25913C ELSE
25914C SHFS=PMAS(37,1)**2
25915C ENDIF
25916 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25917 DO 310 I=1,MDCY(KC,3)
25918 IDC=I+MDCY(KC,2)-1
25919 IF(MDME(IDC,1).LT.0) GOTO 310
25920 KFC1=PYCOMP(KFDP(IDC,1))
25921 KFC2=PYCOMP(KFDP(IDC,2))
25922 RM1=PMAS(KFC1,1)**2/SH
25923 RM2=PMAS(KFC2,1)**2/SH
25924 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
25925 WID2=1D0
25926 IF(I.LE.4) THEN
25927C...H+/- -> q + qbar'
25928 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
25929 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25930 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
25931 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
25932 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25933 IF(KFLR.GT.0) THEN
25934 IF(I.EQ.3) WID2=WIDS(6,2)
25935 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
25936 ELSE
25937 IF(I.EQ.3) WID2=WIDS(6,3)
25938 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
25939 ENDIF
25940 ELSEIF(I.LE.8) THEN
25941C...H+/- -> l+/- + nu
25942 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
25943 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
25944 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
25945 IF(KFLR.GT.0) THEN
25946 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
25947 ELSE
25948 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
25949 ENDIF
25950 ELSEIF(I.EQ.9) THEN
25951C...H+/- -> W+/- + h0.
25952 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
25953 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
25954 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
25955 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
25956
25957CMRENNA++
25958 ELSE
25959C...Add in SUSY decays (two-body) by rescaling by phase space factor.
25960 RM10=RM1*SH/PMR**2
25961 RM20=RM2*SH/PMR**2
25962 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
25963 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
25964 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
25965 WFAC=0D0
25966 ELSE
25967 WFAC=WFAC/WFAC0
25968 ENDIF
25969 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
25970CMRENNA--
25971 KSGN1=2
25972 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
25973 KSGN2=2
25974 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
25975 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
25976 ENDIF
25977 WDTP(I)=FUDGE*WDTP(I)
25978 WDTP(0)=WDTP(0)+WDTP(I)
25979 IF(MDME(IDC,1).GT.0) THEN
25980 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25981 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25982 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25983 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25984 ENDIF
25985 310 CONTINUE
25986
25987 ELSEIF(KFLA.EQ.41) THEN
25988C...R:
25989 FAC=(AEM/(12D0*XW))*SHR
25990 DO 320 I=1,MDCY(KC,3)
25991 IDC=I+MDCY(KC,2)-1
25992 IF(MDME(IDC,1).LT.0) GOTO 320
25993 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25994 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25995 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
25996 WID2=1D0
25997 IF(I.LE.6) THEN
25998C...R -> q + qbar'
25999 FCOF=3D0*RADC
26000 ELSEIF(I.LE.9) THEN
26001C...R -> l+ + l'-
26002 FCOF=1D0
26003 ENDIF
26004 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26005 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26006 IF(KFLR.GT.0) THEN
26007 IF(I.EQ.4) WID2=WIDS(6,3)
26008 IF(I.EQ.5) WID2=WIDS(7,3)
26009 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26010 IF(I.EQ.9) WID2=WIDS(17,3)
26011 ELSE
26012 IF(I.EQ.4) WID2=WIDS(6,2)
26013 IF(I.EQ.5) WID2=WIDS(7,2)
26014 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26015 IF(I.EQ.9) WID2=WIDS(17,2)
26016 ENDIF
26017 WDTP(I)=FUDGE*WDTP(I)
26018 WDTP(0)=WDTP(0)+WDTP(I)
26019 IF(MDME(IDC,1).GT.0) THEN
26020 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26021 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26022 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26023 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26024 ENDIF
26025 320 CONTINUE
26026
26027 ELSEIF(KFLA.EQ.42) THEN
26028C...LQ (leptoquark).
26029 FAC=(AEM/4D0)*PARU(151)*SHR
26030 DO 330 I=1,MDCY(KC,3)
26031 IDC=I+MDCY(KC,2)-1
26032 IF(MDME(IDC,1).LT.0) GOTO 330
26033 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26034 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26035 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26036 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26037 WID2=1D0
26038 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26039 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26040 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26041 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26042 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26043 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26044 WDTP(I)=FUDGE*WDTP(I)
26045 WDTP(0)=WDTP(0)+WDTP(I)
26046 IF(MDME(IDC,1).GT.0) THEN
26047 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26048 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26049 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26050 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26051 ENDIF
26052 330 CONTINUE
26053
26054C...UED: kk state width decays : flav: 451 476
26055 ELSEIF(IUED(1).EQ.1.AND.
26056 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26057 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26058 KCLA=PYCOMP(KFLA)
26059C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26060 RMFLAS=PMAS(KCLA,1)
26061 FACSH=SH/PMAS(KCLA,1)**2
26062 ALPHEM=PYALEM(RMFLAS**2)
26063 ALPHS=PYALPS(RMFLAS**2)
26064
26065C...uedcor parameters (alpha_s is calculated at mkk scale)
26066C...alpha_em is calculated at z pole !
26067 ALPHEM=PARU(101)
26068 FACSH=1.
26069
26070 DO 1070 I=1,MDCY(KCLA,3)
26071 IDC=I+MDCY(KCLA,2)-1
26072
26073 IF(MDME(IDC,1).LT.0) GOTO 1070
26074 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26075 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26076 RM1=PMAS(KFC1,1)**2/SH
26077 RM2=PMAS(KFC2,1)**2/SH
26078 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26079 & GOTO 1070
26080 WID2=1D0
26081
26082C...N.B. RINV=RUED(1)
26083 RMKK=RUED(1)
26084 RMWKK=PMAS(475,1)
26085 RMZKK=PMAS(474,1)
26086 SW2=PARU(102)
26087 CW2=1.-SW2
26088 KKCLA=KCLA-KKFLMI+1
26089 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26090 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26091 IF(KKCLA.LE.6) THEN
26092C...q*_S -> q + gamma* (in first time sw21=0)
26093 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26094C...Eventually change the following by enabling a choice of open or closed.
26095C...Only the gamma_kk channel is open.
26096 IF(MOD(I,2).EQ.0)
26097 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26098 WDTP(I)=FACSH*WDTP(I)
26099 WID2=WIDS(473,2)
26100 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26101C...q*_D -> q + Z*/W*
26102 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26103 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26104 IF(I.EQ.1)THEN
26105C...q*_D -> q + Z*
26106 WDTP(I)=0.5*GAMMAW
26107 WID2=WIDS(474,2)
26108 ELSEIF(I.EQ.2)THEN
26109C...q*_D -> q + W*
26110 WDTP(I)=GAMMAW
26111 WID2=WIDS(475,2)
26112 ENDIF
26113 WDTP(I)=FACSH*WDTP(I)
26114C...q*_D -> q + gamma* is closed
26115 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26116C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26117 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26118 RMGAKK=PMAS(473,1)
26119 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26120 + FKAC1(RMGAKK,RMFLAS)**2
26121 WDTP(I)=FACSH*WDTP(I)
26122 WID2=WIDS(473,2)
26123 ELSEIF(KKCLA.EQ.22)THEN
26124 RMQST=PMAS(KKPART,1)
26125 WID2=WIDS(KKPART,2)
26126C...g* -> q*_S/q*_D + q
26127 FAC=10.*ALPHS/12.*RMFLAS
26128 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26129 WDTP(I)=FACSH*WDTP(I)
26130 ELSEIF(KKCLA.EQ.23)THEN
26131C...gamma* decays to graviton + gamma : initial value is used
26132 ICHI=IUED(4)/2
26133 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26134 & *CHIDEL(ICHI)
26135 ELSEIF(KKCLA.EQ.24)THEN
26136C...Z* -> l*_S + l is closed
26137C... Z* -> l*_D + l
26138 IF(I.LE.3)GOTO 1070
26139c... After closing the channels for a Z* decaying into positively charged
26140C... KK lepton singlets, close the channels for a Z* decaying into negatively
26141C... charged KK lepton singlets + positively charged SM particles
26142 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26143 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26144 RMLST=PMAS(KKPART,1)
26145 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26146 WDTP(I)=FACSH*WDTP(I)
26147 WID2=WIDS(KKPART,2)
26148 ELSEIF(KKCLA.EQ.25)THEN
26149C...W* -> l*_D lbar
26150 FAC=3.*ALPHEM/12./SW2*RMWKK
26151 RMLST=PMAS(KKPART,1)
26152 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26153 WDTP(I)=FACSH*WDTP(I)
26154 WID2=WIDS(KKPART,2)
26155 ENDIF
26156 WDTP(0)=WDTP(0)+WDTP(I)
26157 IF(MDME(IDC,1).GT.0) THEN
26158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26162 ENDIF
26163 1070 CONTINUE
26164 IUEDPR(KKCLA)=1
26165
26166 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26167C...Techni-pi0 and techni-pi0':
26168 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26169 DO 340 I=1,MDCY(KC,3)
26170 IDC=I+MDCY(KC,2)-1
26171 IF(MDME(IDC,1).LT.0) GOTO 340
26172 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26173 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26174 RM1=PM1**2/SH
26175 RM2=PM2**2/SH
26176 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26177 WID2=1D0
26178C...pi_tc -> g + g
26179 IF(I.EQ.8) THEN
26180 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26181 & /(8D0*PARU(1))*SH*SHR
26182 IF(KFLA.EQ.KTECHN+111) THEN
26183 FACP=FACP*RTCM(9)
26184 ELSE
26185 FACP=FACP*RTCM(10)
26186 ENDIF
26187 WDTP(I)=FACP
26188 ELSE
26189C...pi_tc -> f + fbar.
26190 FCOF=1D0
26191 IKA=IABS(KFDP(IDC,1))
26192 IF(IKA.LT.10) FCOF=3D0*RADC
26193 HM1=PM1
26194 HM2=PM2
26195 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26196 FCOF=FCOF*RTCM(1+IKA)**2
26197 HM1=PYMRUN(KFDP(IDC,1),SH)
26198 HM2=PYMRUN(KFDP(IDC,2),SH)
26199 ELSEIF(IKA.EQ.15) THEN
26200 FCOF=FCOF*RTCM(8)**2
26201 ENDIF
26202 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26203 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26204 ENDIF
26205 WDTP(I)=FUDGE*WDTP(I)
26206 WDTP(0)=WDTP(0)+WDTP(I)
26207 IF(MDME(IDC,1).GT.0) THEN
26208 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26209 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26210 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26211 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26212 ENDIF
26213 340 CONTINUE
26214
26215 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26216C...pi+_tc
26217 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26218 DO 350 I=1,MDCY(KC,3)
26219 IDC=I+MDCY(KC,2)-1
26220 IF(MDME(IDC,1).LT.0) GOTO 350
26221 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26222 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26223 PM3=0D0
26224 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26225 RM1=PM1**2/SH
26226 RM2=PM2**2/SH
26227 RM3=PM3**2/SH
26228 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26229 WID2=1D0
26230C...pi_tc -> f + f'.
26231 FCOF=1D0
26232 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26233C...pi_tc+ -> W b b~
26234 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26235 FCOF=3D0*RADC
26236 XMT2=PMAS(6,1)**2/SH
26237 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26238 KFC3=PYCOMP(KFDP(IDC,3))
26239 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26240 CHECK = SQRT(RM1)
26241 T0 = (1D0-CHECK**2)*
26242 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26243 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26244 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26245 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26246 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26247 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26248 & +T3*LOG(CHECK))
26249 IF(KFLR.GT.0) THEN
26250 WID2=WIDS(24,2)
26251 ELSE
26252 WID2=WIDS(24,3)
26253 ENDIF
26254 ELSE
26255 FCOF=1D0
26256 IKA=IABS(KFDP(IDC,1))
26257 IF(IKA.LT.10) FCOF=3D0*RADC
26258 HM1=PM1
26259 HM2=PM2
26260 IF(I.GE.1.AND.I.LE.5) THEN
26261 IF(I.LE.2) THEN
26262 FCOF=FCOF*RTCM(5)**2
26263 ELSEIF(I.LE.4) THEN
26264 FCOF=FCOF*RTCM(6)**2
26265 ELSEIF(I.EQ.5) THEN
26266 FCOF=FCOF*RTCM(7)**2
26267 ENDIF
26268 HM1=PYMRUN(KFDP(IDC,1),SH)
26269 HM2=PYMRUN(KFDP(IDC,2),SH)
26270 ELSEIF(I.EQ.8) THEN
26271 FCOF=FCOF*RTCM(8)**2
26272 ENDIF
26273 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26274 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26275 ENDIF
26276 WDTP(I)=FUDGE*WDTP(I)
26277 WDTP(0)=WDTP(0)+WDTP(I)
26278 IF(MDME(IDC,1).GT.0) THEN
26279 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26280 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26281 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26282 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26283 ENDIF
26284 350 CONTINUE
26285
26286 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26287C...Techni-eta.
26288 FAC=(SH/PARP(46)**2)*SHR
26289 DO 360 I=1,MDCY(KC,3)
26290 IDC=I+MDCY(KC,2)-1
26291 IF(MDME(IDC,1).LT.0) GOTO 360
26292 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26293 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26294 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26295 WID2=1D0
26296 IF(I.LE.2) THEN
26297 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26298 IF(I.EQ.2) WID2=WIDS(6,1)
26299 ELSE
26300 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26301 ENDIF
26302 WDTP(I)=FUDGE*WDTP(I)
26303 WDTP(0)=WDTP(0)+WDTP(I)
26304 IF(MDME(IDC,1).GT.0) THEN
26305 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26306 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26307 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26308 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26309 ENDIF
26310 360 CONTINUE
26311
26312 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26313C...Techni-rho0:
26314 ALPRHT=2.16D0*(3D0/ITCM(1))
26315 FAC=(ALPRHT/12D0)*SHR
26316 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26317 SQMZ=PMAS(23,1)**2
26318 SQMW=PMAS(24,1)**2
26319 SHP=SH
26320 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26321 GMMZ=SHR*WDTPP(0)
26322 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26323 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26324 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26325 DO 370 I=1,MDCY(KC,3)
26326 IDC=I+MDCY(KC,2)-1
26327 IF(MDME(IDC,1).LT.0) GOTO 370
26328 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26329 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26330 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26331 WID2=1D0
26332 IF(I.EQ.1) THEN
26333C...rho_tc0 -> W+ + W-.
26334C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26335 WDTP(I)=FAC*RTCM(3)**4*
26336 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26337 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26338 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26339 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26340 WID2=WIDS(24,1)
26341 ELSEIF(I.EQ.2) THEN
26342C...rho_tc0 -> W+ + pi_tc-.
26343C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26344 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26345 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26346 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26347 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26348 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26349 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26350 ELSEIF(I.EQ.3) THEN
26351C...rho_tc0 -> pi_tc+ + W-.
26352 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26353 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26354 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26355 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
26356 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26357 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
26358 ELSEIF(I.EQ.4) THEN
26359C...rho_tc0 -> pi_tc+ + pi_tc-.
26360 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26361 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26362 WID2=WIDS(PYCOMP(KTECHN+211),1)
26363 ELSEIF(I.EQ.5) THEN
26364C...rho_tc0 -> gamma + pi_tc0
26365 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26366 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26367 & SHR**3
26368 WID2=WIDS(PYCOMP(KTECHN+111),2)
26369 ELSEIF(I.EQ.6) THEN
26370C...rho_tc0 -> gamma + pi_tc0'
26371 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26372 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
26373 WID2=WIDS(PYCOMP(KTECHN+221),2)
26374 ELSEIF(I.EQ.7) THEN
26375C...rho_tc0 -> Z0 + pi_tc0
26376 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26377 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26378 & XW/XW1*SHR**3
26379 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26380 ELSEIF(I.EQ.8) THEN
26381C...rho_tc0 -> Z0 + pi_tc0'
26382 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26383 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26384 & XW/XW1*SHR**3
26385 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26386 ELSEIF(I.EQ.9) THEN
26387C...rho_tc0 -> gamma + Z0
26388 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26389 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26390 WID2=WIDS(23,2)
26391 ELSEIF(I.EQ.10) THEN
26392C...rho_tc0 -> Z0 + Z0
26393 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26394 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
26395 & SHR**3
26396 WID2=WIDS(23,1)
26397 ELSE
26398C...rho_tc0 -> f + fbar.
26399 WID2=1D0
26400 IF(I.LE.18) THEN
26401 IA=I-10
26402 FCOF=3D0*RADC
26403 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26404 ELSE
26405 IA=I-6
26406 FCOF=1D0
26407 IF(IA.GE.17) WID2=WIDS(IA,1)
26408 ENDIF
26409 EI=KCHG(IA,1)/3D0
26410 AI=SIGN(1D0,EI+0.1D0)
26411 VI=AI-4D0*EI*XWV
26412 VALI=0.5D0*(VI+AI)
26413 VARI=0.5D0*(VI-AI)
26414 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26415 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26416 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26417 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26418 ENDIF
26419 WDTP(I)=FUDGE*WDTP(I)
26420 WDTP(0)=WDTP(0)+WDTP(I)
26421 IF(MDME(IDC,1).GT.0) THEN
26422 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26423 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26424 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26425 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26426 ENDIF
26427 370 CONTINUE
26428
26429 ELSEIF(KFLA.EQ.KTECHN+213) THEN
26430C...Techni-rho+/-:
26431 ALPRHT=2.16D0*(3D0/ITCM(1))
26432 FAC=(ALPRHT/12D0)*SHR
26433 SQMZ=PMAS(23,1)**2
26434 SQMW=PMAS(24,1)**2
26435 SHP=SH
26436 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
26437 GMMW=SHR*WDTPP(0)
26438 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
26439 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
26440 DO 380 I=1,MDCY(KC,3)
26441 IDC=I+MDCY(KC,2)-1
26442 IF(MDME(IDC,1).LT.0) GOTO 380
26443 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26444 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26445 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
26446 WID2=1D0
26447 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26448c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26449c & /3D0*SHR**3
26450 IF(I.EQ.1) THEN
26451C...rho_tc+ -> W+ + Z0.
26452C......Goldstone
26453 WDTP(I)=FAC*RTCM(3)**4*
26454 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26455 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
26456 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
26457C......W_L Z_T
26458 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
26459 & /3D0*SHR**3
26460 VA2=0D0
26461 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
26462C......W_T Z_L
26463 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
26464 & /3D0*SHR**3
26465 IF(KFLR.GT.0) THEN
26466 WID2=WIDS(24,2)*WIDS(23,2)
26467 ELSE
26468 WID2=WIDS(24,3)*WIDS(23,2)
26469 ENDIF
26470 ELSEIF(I.EQ.2) THEN
26471C...rho_tc+ -> W+ + pi_tc0.
26472 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26473 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26474 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26475 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26476 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
26477 IF(KFLR.GT.0) THEN
26478 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
26479 ELSE
26480 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
26481 ENDIF
26482 ELSEIF(I.EQ.3) THEN
26483C...rho_tc+ -> pi_tc+ + Z0.
26484 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26485 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26486 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26487 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
26488 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
26489 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26490 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26491 & SHR**3*XW/XW1
26492 IF(KFLR.GT.0) THEN
26493 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
26494 ELSE
26495 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
26496 ENDIF
26497 ELSEIF(I.EQ.4) THEN
26498C...rho_tc+ -> pi_tc+ + pi_tc0.
26499 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
26500 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26501 IF(KFLR.GT.0) THEN
26502 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
26503 ELSE
26504 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
26505 ENDIF
26506 ELSEIF(I.EQ.5) THEN
26507C...rho_tc+ -> pi_tc+ + gamma
26508 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26509 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
26510 & SHR**3
26511 IF(KFLR.GT.0) THEN
26512 WID2=WIDS(PYCOMP(KTECHN+211),2)
26513 ELSE
26514 WID2=WIDS(PYCOMP(KTECHN+211),3)
26515 ENDIF
26516 ELSEIF(I.EQ.6) THEN
26517C...rho_tc+ -> W+ + pi_tc0'
26518 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26519 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
26520 IF(KFLR.GT.0) THEN
26521 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
26522 ELSE
26523 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
26524 ENDIF
26525 ELSEIF(I.EQ.7) THEN
26526C...rho_tc+ -> W+ + gamma
26527 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26528 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26529 IF(KFLR.GT.0) THEN
26530 WID2=WIDS(24,2)
26531 ELSE
26532 WID2=WIDS(24,3)
26533 ENDIF
26534 ELSE
26535C...rho_tc+ -> f + fbar'.
26536 IA=I-7
26537 WID2=1D0
26538 IF(IA.LE.16) THEN
26539 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
26540 IF(KFLR.GT.0) THEN
26541 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
26542 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
26543 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
26544 ELSE
26545 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
26546 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
26547 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
26548 ENDIF
26549 ELSE
26550 FCOF=1D0
26551 IF(KFLR.GT.0) THEN
26552 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26553 ELSE
26554 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26555 ENDIF
26556 ENDIF
26557 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26558 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26559 ENDIF
26560 WDTP(I)=FUDGE*WDTP(I)
26561 WDTP(0)=WDTP(0)+WDTP(I)
26562 IF(MDME(IDC,1).GT.0) THEN
26563 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26564 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26565 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26566 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26567 ENDIF
26568 380 CONTINUE
26569
26570 ELSEIF(KFLA.EQ.KTECHN+223) THEN
26571C...Techni-omega:
26572 ALPRHT=2.16D0*(3D0/ITCM(1))
26573 FAC=(ALPRHT/12D0)*SHR
26574 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
26575 SQMZ=PMAS(23,1)**2
26576 SHP=SH
26577 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26578 GMMZ=SHR*WDTPP(0)
26579 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26580 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26581 DO 390 I=1,MDCY(KC,3)
26582 IDC=I+MDCY(KC,2)-1
26583 IF(MDME(IDC,1).LT.0) GOTO 390
26584 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26585 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26586 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
26587 WID2=1D0
26588 IF(I.EQ.1) THEN
26589C...omega_tc0 -> gamma + pi_tc0.
26590 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
26591 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
26592 WID2=WIDS(PYCOMP(KTECHN+111),2)
26593 ELSEIF(I.EQ.2) THEN
26594C...omega_tc0 -> Z0 + pi_tc0
26595 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26596 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
26597 & XW/XW1*SHR**3
26598 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
26599 ELSEIF(I.EQ.3) THEN
26600C...omega_tc0 -> gamma + pi_tc0'
26601 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26602 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26603 & SHR**3
26604 WID2=WIDS(PYCOMP(KTECHN+221),2)
26605 ELSEIF(I.EQ.4) THEN
26606C...omega_tc0 -> Z0 + pi_tc0'
26607 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26608 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
26609 & XW/XW1*SHR**3
26610 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
26611 ELSEIF(I.EQ.5) THEN
26612C...omega_tc0 -> W+ + pi_tc-
26613 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26614 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26615 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26616 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26617 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
26618 ELSEIF(I.EQ.6) THEN
26619C...omega_tc0 -> pi_tc+ + W-
26620 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26621 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
26622 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
26623 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26624 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
26625 ELSEIF(I.EQ.7) THEN
26626C...omega_tc0 -> W+ + W-.
26627C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26628 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
26629 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26630 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26631 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
26632 WID2=WIDS(24,1)
26633 ELSEIF(I.EQ.8) THEN
26634C...omega_tc0 -> pi_tc+ + pi_tc-.
26635 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
26636 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26637 WID2=WIDS(PYCOMP(KTECHN+211),1)
26638C...omega_tc0 -> gamma + Z0
26639 ELSEIF(I.EQ.9) THEN
26640 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26641 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
26642 WID2=WIDS(23,2)
26643C...omega_tc0 -> Z0 + Z0
26644 ELSEIF(I.EQ.10) THEN
26645 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26646 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
26647 & /24D0/RTCM(12)**2*SHR**3
26648 WID2=WIDS(23,1)
26649 ELSE
26650C...omega_tc0 -> f + fbar.
26651 WID2=1D0
26652 IF(I.LE.18) THEN
26653 IA=I-10
26654 FCOF=3D0*RADC
26655 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
26656 ELSE
26657 IA=I-8
26658 FCOF=1D0
26659 IF(IA.GE.17) WID2=WIDS(IA,1)
26660 ENDIF
26661 EI=KCHG(IA,1)/3D0
26662 AI=SIGN(1D0,EI+0.1D0)
26663 VI=AI-4D0*EI*XWV
26664 VALI=-0.5D0*(VI+AI)
26665 VARI=-0.5D0*(VI-AI)
26666 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
26667 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
26668 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
26669 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
26670 ENDIF
26671 WDTP(I)=FUDGE*WDTP(I)
26672 WDTP(0)=WDTP(0)+WDTP(I)
26673 IF(MDME(IDC,1).GT.0) THEN
26674 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26675 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26676 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26677 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26678 ENDIF
26679 390 CONTINUE
26680
26681C.....V8 -> quark anti-quark
26682 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
26683 FAC=AS/6D0*SHR
26684 TANT3=RTCM(21)
26685 IF(ITCM(2).EQ.0) THEN
26686 IMDL=1
26687 ELSEIF(ITCM(2).EQ.1) THEN
26688 IMDL=2
26689 ENDIF
26690 DO 400 I=1,MDCY(KC,3)
26691 IDC=I+MDCY(KC,2)-1
26692 IF(MDME(IDC,1).LT.0) GOTO 400
26693 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26694 RM1=PM1**2/SH
26695 IF(RM1.GT.0.25D0) GOTO 400
26696 WID2=1D0
26697 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26698 FMIX=1D0/TANT3**2
26699 ELSE
26700 FMIX=TANT3**2
26701 ENDIF
26702 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
26703 IF(I.EQ.6) WID2=WIDS(6,1)
26704 WDTP(I)=FUDGE*WDTP(I)
26705 WDTP(0)=WDTP(0)+WDTP(I)
26706 IF(MDME(IDC,1).GT.0) THEN
26707 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26708 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26709 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26710 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26711 ENDIF
26712 400 CONTINUE
26713
26714 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
26715 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
26716 CLEBF=0D0
26717 DO 410 I=1,MDCY(KC,3)
26718 IDC=I+MDCY(KC,2)-1
26719 IF(MDME(IDC,1).LT.0) GOTO 410
26720 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26721 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26722 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
26723 WID2=1D0
26724C...pi_tc -> g + g
26725 IF(I.EQ.7) THEN
26726 IF(KFLA.EQ.KTECHN+100111) THEN
26727 CLEBG=4D0/3D0
26728 ELSE
26729 CLEBG=5D0/3D0
26730 ENDIF
26731 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
26732 & /(2D0*PARU(1))*SH*SHR*CLEBG
26733 WDTP(I)=FACP
26734 ELSE
26735C...pi_tc -> f + fbar.
26736 IF(I.EQ.6) WID2=WIDS(6,1)
26737 FCOF=1D0
26738 IKA=IABS(KFDP(IDC,1))
26739 IF(IKA.LT.10) FCOF=3D0*RADC
26740 HM1=PYMRUN(KFDP(IDC,1),SH)
26741 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
26742 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26743 ENDIF
26744 WDTP(I)=FUDGE*WDTP(I)
26745 WDTP(0)=WDTP(0)+WDTP(I)
26746 IF(MDME(IDC,1).GT.0) THEN
26747 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26748 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26749 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26750 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26751 ENDIF
26752 410 CONTINUE
26753
26754 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
26755 FAC=AS/6D0*SHR
26756 ALPRHT=2.16D0*(3D0/ITCM(1))
26757 TANT3=RTCM(21)
26758 SIN2T=2D0*TANT3/(TANT3**2+1D0)
26759 SINT3=TANT3/SQRT(TANT3**2+1D0)
26760 CSXPP=RTCM(22)
26761 RM82=RTCM(27)**2
26762 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
26763 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
26764 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
26765 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
26766 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
26767 & SINT3**2)*2D0
26768 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
26769 & SINT3**2)*2D0
26770 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
26771
26772 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
26773 GMV8=SHR*WDTPP(0)
26774 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
26775 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
26776 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
26777 IF(ITCM(2).EQ.0) THEN
26778 IMDL=1
26779 ELSE
26780 IMDL=2
26781 ENDIF
26782 DO 420 I=1,MDCY(KC,3)
26783 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
26784 & KFLA.EQ.KTECHN+300113)) GOTO 420
26785 IDC=I+MDCY(KC,2)-1
26786 IF(MDME(IDC,1).LT.0) GOTO 420
26787 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26788 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26789 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
26790 WID2=1D0
26791 IF(I.LE.6) THEN
26792 IF(I.EQ.6) WID2=WIDS(6,1)
26793 XIG=1D0
26794 IF(KFLA.EQ.KTECHN+200113) THEN
26795 XIG=0D0
26796 XIJ=X12
26797 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
26798 XIG=0D0
26799 XIJ=X21
26800 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
26801 XIJ=X11
26802 ELSE
26803 XIJ=X22
26804 ENDIF
26805 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
26806 FMIX=1D0/TANT3/SIN2T
26807 ELSE
26808 FMIX=-TANT3/SIN2T
26809 ENDIF
26810 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
26811 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
26812 ELSEIF(I.EQ.7) THEN
26813 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
26814 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
26815 PSH=SHR*(1D0-RM1)/2D0
26816 WDTP(I)=AS/9D0*PSH**3/RM82
26817 IF(I.EQ.8) THEN
26818 WDTP(I)=2D0*WDTP(I)*CSXPP**2
26819 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26820 ELSE
26821 WDTP(I)=5D0*WDTP(I)
26822 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
26823 ENDIF
26824 ENDIF
26825 WDTP(I)=FUDGE*WDTP(I)
26826 WDTP(0)=WDTP(0)+WDTP(I)
26827 IF(MDME(IDC,1).GT.0) THEN
26828 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26829 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26830 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26831 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26832 ENDIF
26833 420 CONTINUE
26834
26835 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
26836C...d* excited quark.
26837 FAC=(SH/RTCM(41)**2)*SHR
26838 DO 430 I=1,MDCY(KC,3)
26839 IDC=I+MDCY(KC,2)-1
26840 IF(MDME(IDC,1).LT.0) GOTO 430
26841 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26842 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26843 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
26844 WID2=1D0
26845 IF(I.EQ.1) THEN
26846C...d* -> g + d.
26847 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26848 WID2=1D0
26849 ELSEIF(I.EQ.2) THEN
26850C...d* -> gamma + d.
26851 QF=-RTCM(43)/2D0+RTCM(44)/6D0
26852 WDTP(I)=FAC*AEM*QF**2/4D0
26853 WID2=1D0
26854 ELSEIF(I.EQ.3) THEN
26855C...d* -> Z0 + d.
26856 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26857 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26858 & (1D0-RM1)**2*(2D0+RM1)
26859 WID2=WIDS(23,2)
26860 ELSEIF(I.EQ.4) THEN
26861C...d* -> W- + u.
26862 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26863 & (1D0-RM1)**2*(2D0+RM1)
26864 IF(KFLR.GT.0) WID2=WIDS(24,3)
26865 IF(KFLR.LT.0) WID2=WIDS(24,2)
26866 ENDIF
26867 WDTP(I)=FUDGE*WDTP(I)
26868 WDTP(0)=WDTP(0)+WDTP(I)
26869 IF(MDME(IDC,1).GT.0) THEN
26870 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26871 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26872 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26873 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26874 ENDIF
26875 430 CONTINUE
26876
26877 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
26878C...u* excited quark.
26879 FAC=(SH/RTCM(41)**2)*SHR
26880 DO 440 I=1,MDCY(KC,3)
26881 IDC=I+MDCY(KC,2)-1
26882 IF(MDME(IDC,1).LT.0) GOTO 440
26883 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26884 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26885 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
26886 WID2=1D0
26887 IF(I.EQ.1) THEN
26888C...u* -> g + u.
26889 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
26890 WID2=1D0
26891 ELSEIF(I.EQ.2) THEN
26892C...u* -> gamma + u.
26893 QF=RTCM(43)/2D0+RTCM(44)/6D0
26894 WDTP(I)=FAC*AEM*QF**2/4D0
26895 WID2=1D0
26896 ELSEIF(I.EQ.3) THEN
26897C...u* -> Z0 + u.
26898 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
26899 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26900 & (1D0-RM1)**2*(2D0+RM1)
26901 WID2=WIDS(23,2)
26902 ELSEIF(I.EQ.4) THEN
26903C...u* -> W+ + d.
26904 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26905 & (1D0-RM1)**2*(2D0+RM1)
26906 IF(KFLR.GT.0) WID2=WIDS(24,2)
26907 IF(KFLR.LT.0) WID2=WIDS(24,3)
26908 ENDIF
26909 WDTP(I)=FUDGE*WDTP(I)
26910 WDTP(0)=WDTP(0)+WDTP(I)
26911 IF(MDME(IDC,1).GT.0) THEN
26912 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26913 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26914 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26915 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26916 ENDIF
26917 440 CONTINUE
26918
26919 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
26920C...e* excited lepton.
26921 FAC=(SH/RTCM(41)**2)*SHR
26922 DO 450 I=1,MDCY(KC,3)
26923 IDC=I+MDCY(KC,2)-1
26924 IF(MDME(IDC,1).LT.0) GOTO 450
26925 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26926 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26927 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
26928 WID2=1D0
26929 IF(I.EQ.1) THEN
26930C...e* -> gamma + e.
26931 QF=-RTCM(43)/2D0-RTCM(44)/2D0
26932 WDTP(I)=FAC*AEM*QF**2/4D0
26933 WID2=1D0
26934 ELSEIF(I.EQ.2) THEN
26935C...e* -> Z0 + e.
26936 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26937 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26938 & (1D0-RM1)**2*(2D0+RM1)
26939 WID2=WIDS(23,2)
26940 ELSEIF(I.EQ.3) THEN
26941C...e* -> W- + nu.
26942 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26943 & (1D0-RM1)**2*(2D0+RM1)
26944 IF(KFLR.GT.0) WID2=WIDS(24,3)
26945 IF(KFLR.LT.0) WID2=WIDS(24,2)
26946 ENDIF
26947 WDTP(I)=FUDGE*WDTP(I)
26948 WDTP(0)=WDTP(0)+WDTP(I)
26949 IF(MDME(IDC,1).GT.0) THEN
26950 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26951 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26952 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26953 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26954 ENDIF
26955 450 CONTINUE
26956
26957 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
26958C...nu*_e excited neutrino.
26959 FAC=(SH/RTCM(41)**2)*SHR
26960 DO 460 I=1,MDCY(KC,3)
26961 IDC=I+MDCY(KC,2)-1
26962 IF(MDME(IDC,1).LT.0) GOTO 460
26963 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26964 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26965 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
26966 WID2=1D0
26967 IF(I.EQ.1) THEN
26968C...nu*_e -> Z0 + nu*_e.
26969 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
26970 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
26971 & (1D0-RM1)**2*(2D0+RM1)
26972 WID2=WIDS(23,2)
26973 ELSEIF(I.EQ.2) THEN
26974C...nu*_e -> W+ + e.
26975 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
26976 & (1D0-RM1)**2*(2D0+RM1)
26977 IF(KFLR.GT.0) WID2=WIDS(24,2)
26978 IF(KFLR.LT.0) WID2=WIDS(24,3)
26979 ENDIF
26980 WDTP(I)=FUDGE*WDTP(I)
26981 WDTP(0)=WDTP(0)+WDTP(I)
26982 IF(MDME(IDC,1).GT.0) THEN
26983 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26984 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26985 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26986 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26987 ENDIF
26988 460 CONTINUE
26989
26990 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
26991C...G* (graviton resonance):
26992 FAC=(PARP(50)**2/PARU(1))*SHR
26993 DO 470 I=1,MDCY(KC,3)
26994 IDC=I+MDCY(KC,2)-1
26995 IF(MDME(IDC,1).LT.0) GOTO 470
26996 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26997 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26998 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
26999 WID2=1D0
27000 IF(I.LE.8) THEN
27001C...G* -> q + qbar
27002 FCOF=3D0*RADC
27003 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27004 & PYHFTH(SH,SH*RM1,1D0)
27005 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27006 & (1D0+8D0*RM1/3D0)/320D0
27007 IF(I.EQ.6) WID2=WIDS(6,1)
27008 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27009 ELSEIF(I.LE.16) THEN
27010C...G* -> l+ + l-, nu + nubar
27011 FCOF=1D0
27012 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27013 & (1D0+8D0*RM1/3D0)/320D0
27014 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27015 ELSEIF(I.EQ.17) THEN
27016C...G* -> g + g.
27017 WDTP(I)=FAC/20D0
27018 ELSEIF(I.EQ.18) THEN
27019C...G* -> gamma + gamma.
27020 WDTP(I)=FAC/160D0
27021 ELSEIF(I.EQ.19) THEN
27022C...G* -> Z0 + Z0.
27023 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27024 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27025 WID2=WIDS(23,1)
27026 ELSEIF(I.EQ.20) THEN
27027C...G* -> W+ + W-.
27028 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27029 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27030 WID2=WIDS(24,1)
27031 ENDIF
27032 WDTP(I)=FUDGE*WDTP(I)
27033 WDTP(0)=WDTP(0)+WDTP(I)
27034 IF(MDME(IDC,1).GT.0) THEN
27035 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27036 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27037 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27038 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27039 ENDIF
27040 470 CONTINUE
27041
27042 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27043C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27044 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27045 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27046 DO 480 I=1,MDCY(KC,3)
27047 IDC=I+MDCY(KC,2)-1
27048 IF(MDME(IDC,1).LT.0) GOTO 480
27049 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27050 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27051 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27052 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27053 WID2=1D0
27054 IF(I.LE.9) THEN
27055C...nu_lR -> l- qbar q'
27056 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27057 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27058 ELSEIF(I.LE.18) THEN
27059C...nu_lR -> l+ q qbar'
27060 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27061 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27062 ELSE
27063C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27064 FCOF=1D0
27065 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27066 ENDIF
27067 X=(PM1+PM2+PM3)/SHR
27068 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27069 Y=(SHR/PMWR)**2
27070 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27071 WDTP(I)=FAC*FCOF*FX*FY
27072 WDTP(I)=FUDGE*WDTP(I)
27073 WDTP(0)=WDTP(0)+WDTP(I)
27074 IF(MDME(IDC,1).GT.0) THEN
27075 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27076 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27077 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27078 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27079 ENDIF
27080 480 CONTINUE
27081
27082 ELSEIF(KFLA.EQ.9900023) THEN
27083C...Z_R0:
27084 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27085 DO 490 I=1,MDCY(KC,3)
27086 IDC=I+MDCY(KC,2)-1
27087 IF(MDME(IDC,1).LT.0) GOTO 490
27088 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27089 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27090 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27091 WID2=1D0
27092 SYMMET=1D0
27093 IF(I.LE.6) THEN
27094C...Z_R0 -> q + qbar
27095 EF=KCHG(I,1)/3D0
27096 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27097 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27098 FCOF=3D0*RADC
27099 IF(I.EQ.6) WID2=WIDS(6,1)
27100 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27101C...Z_R0 -> l+ + l-
27102 AF=-(1D0-2D0*XW)
27103 VF=-1D0+4D0*XW
27104 FCOF=1D0
27105 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27106C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27107 AF=-2D0*XW
27108 VF=0D0
27109 FCOF=1D0
27110 SYMMET=0.5D0
27111 ELSEIF(I.LE.15) THEN
27112C...Z0 -> nu_R + nu_R, assumed Majorana.
27113 AF=2D0*XW1
27114 VF=0D0
27115 FCOF=1D0
27116 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27117 SYMMET=0.5D0
27118 ENDIF
27119 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27120 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27121 WDTP(I)=FUDGE*WDTP(I)
27122 WDTP(0)=WDTP(0)+WDTP(I)
27123 IF(MDME(IDC,1).GT.0) THEN
27124 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27125 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27126 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27127 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27128 ENDIF
27129 490 CONTINUE
27130
27131 ELSEIF(KFLA.EQ.9900024) THEN
27132C...W_R+/-:
27133 FAC=(AEM/(24D0*XW))*SHR
27134 DO 500 I=1,MDCY(KC,3)
27135 IDC=I+MDCY(KC,2)-1
27136 IF(MDME(IDC,1).LT.0) GOTO 500
27137 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27138 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27139 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27140 WID2=1D0
27141 IF(I.LE.9) THEN
27142C...W_R+/- -> q + qbar'
27143 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27144 IF(KFLR.GT.0) THEN
27145 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27146 ELSE
27147 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27148 ENDIF
27149 ELSEIF(I.LE.12) THEN
27150C...W_R+/- -> l+/- + nu_R
27151 FCOF=1D0
27152 ENDIF
27153 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27154 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27155 WDTP(I)=FUDGE*WDTP(I)
27156 WDTP(0)=WDTP(0)+WDTP(I)
27157 IF(MDME(IDC,1).GT.0) THEN
27158 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27159 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27160 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27161 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27162 ENDIF
27163 500 CONTINUE
27164
27165 ELSEIF(KFLA.EQ.9900041) THEN
27166C...H_L++/--:
27167 FAC=(1D0/(8D0*PARU(1)))*SHR
27168 DO 510 I=1,MDCY(KC,3)
27169 IDC=I+MDCY(KC,2)-1
27170 IF(MDME(IDC,1).LT.0) GOTO 510
27171 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27172 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27173 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27174 WID2=1D0
27175 IF(I.LE.6) THEN
27176C...H_L++/-- -> l+/- + l'+/-
27177 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27178 & (IABS(KFDP(IDC,2))-9)/2)**2
27179 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27180 ELSEIF(I.EQ.7) THEN
27181C...H_L++/-- -> W_L+/- + W_L+/-
27182 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27183 & (3D0*RM1+0.25D0/RM1-1D0)
27184 WID2=WIDS(24,4+(1-KFLS)/2)
27185 ENDIF
27186 WDTP(I)=FAC*FCOF*
27187 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27188 WDTP(I)=FUDGE*WDTP(I)
27189 WDTP(0)=WDTP(0)+WDTP(I)
27190 IF(MDME(IDC,1).GT.0) THEN
27191 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27192 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27193 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27194 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27195 ENDIF
27196 510 CONTINUE
27197
27198 ELSEIF(KFLA.EQ.9900042) THEN
27199C...H_R++/--:
27200 FAC=(1D0/(8D0*PARU(1)))*SHR
27201 DO 520 I=1,MDCY(KC,3)
27202 IDC=I+MDCY(KC,2)-1
27203 IF(MDME(IDC,1).LT.0) GOTO 520
27204 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27205 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27206 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27207 WID2=1D0
27208 IF(I.LE.6) THEN
27209C...H_R++/-- -> l+/- + l'+/-
27210 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27211 & (IABS(KFDP(IDC,2))-9)/2)**2
27212 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27213 ELSEIF(I.EQ.7) THEN
27214C...H_R++/-- -> W_R+/- + W_R+/-
27215 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27216 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27217 ENDIF
27218 WDTP(I)=FAC*FCOF*
27219 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27220 WDTP(I)=FUDGE*WDTP(I)
27221 WDTP(0)=WDTP(0)+WDTP(I)
27222 IF(MDME(IDC,1).GT.0) THEN
27223 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27224 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27225 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27226 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27227 ENDIF
27228 520 CONTINUE
27229
27230 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27231C...Techni-a2:
27232C...Need to update to alpha_rho
27233 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27234 FAC=(ALPRHT/12D0)*SHR
27235 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27236 SQMZ=PMAS(23,1)**2
27237 SQMW=PMAS(24,1)**2
27238 SHP=SH
27239 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27240 GMMZ=SHR*WDTPP(0)
27241 XWRHT=1D0/(4D0*XW*(1D0-XW))
27242 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27243 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27244 DO 530 I=1,MDCY(KC,3)
27245 IDC=I+MDCY(KC,2)-1
27246 IF(MDME(IDC,1).LT.0) GOTO 530
27247 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27248 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27249 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27250 WID2=1D0
27251 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27252 IF(I.LE.4) THEN
27253 FACPV=PCM**2
27254 FACPA=PCM**2+1.5D0*RM1
27255 VA2=0D0
27256 AA2=0D0
27257C...a2_tc0 -> W+ + W-
27258 IF(I.EQ.1) THEN
27259 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27260C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27261 WID2=WIDS(24,1)
27262C...a2_tc0 -> W+ + pi_tc- + c.c.
27263 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27264 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27265 IF(I.EQ.6) THEN
27266 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27267 ELSE
27268 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27269 ENDIF
27270 ELSEIF(I.EQ.4) THEN
27271C...a2_tc0 -> Z0 + pi_tc0'
27272 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27273 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27274 ENDIF
27275 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27276 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27277 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27278 FACPA=PCM**2*(1D0+RM1+RM2)
27279 VA2=0D0
27280 AA2=0D0
27281 IF(I.EQ.5) THEN
27282C...a_T^0 -> gamma rho_T^0
27283 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27284 WID2=WIDS(PYCOMP(KTECHN+113),2)
27285 ELSEIF(I.EQ.6) THEN
27286C...a_T^0 -> gamma omega_T
27287 VA2=1D0/RTCM(50)**4
27288 WID2=WIDS(PYCOMP(KTECHN+223),2)
27289 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27290C...a_T^0 -> W^+- rho_T^-+
27291 AA2=.25D0/XW/RTCM(51)**4
27292 IF(I.EQ.7) THEN
27293 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27294 ELSE
27295 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27296 ENDIF
27297 ELSEIF(I.EQ.9) THEN
27298C...a_T^0 -> Z^0 rho_T^0
27299 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27300 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27301 ELSEIF(I.EQ.10) THEN
27302C...a_T^0 -> Z^0 omega_T
27303 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27304 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27305 ENDIF
27306 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27307 ELSE
27308C...a2_tc0 -> f + fbar.
27309 WID2=1D0
27310 IF(I.LE.18) THEN
27311 IA=I-10
27312 FCOF=3D0*RADC
27313 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27314 ELSE
27315 IA=I-8
27316 FCOF=1D0
27317 IF(IA.GE.17) WID2=WIDS(IA,1)
27318 ENDIF
27319 EI=KCHG(IA,1)/3D0
27320 AI=SIGN(1D0,EI+0.1D0)
27321 VI=AI-4D0*EI*XWV
27322 VALI=0.5D0*(VI+AI)
27323 VARI=0.5D0*(VI-AI)
27324 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27325 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27326 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27327 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27328 ENDIF
27329 WDTP(I)=FUDGE*WDTP(I)
27330 WDTP(0)=WDTP(0)+WDTP(I)
27331 IF(MDME(IDC,1).GT.0) THEN
27332 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27333 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27334 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27335 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27336 ENDIF
27337 530 CONTINUE
27338
27339 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27340C...Techni-a2+/-:
27341 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27342 FAC=(ALPRHT/12D0)*SHR
27343 SQMZ=PMAS(23,1)**2
27344 SQMW=PMAS(24,1)**2
27345 SHP=SH
27346 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27347 GMMW=SHR*WDTPP(0)
27348 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27349 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27350 DO 540 I=1,MDCY(KC,3)
27351 IDC=I+MDCY(KC,2)-1
27352 IF(MDME(IDC,1).LT.0) GOTO 540
27353 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27354 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27355 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
27356 WID2=1D0
27357 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27358 IF(KFLR.GT.0) THEN
27359 ICHANN=2
27360 ELSE
27361 ICHANN=3
27362 ENDIF
27363 IF(I.LE.7) THEN
27364 AA2=0
27365 VA2=0
27366C...a2_tc+ -> gamma + W+.
27367 IF(I.EQ.1) THEN
27368 AA2=RTCM(3)**2/RTCM(49)**2
27369 WID2=WIDS(24,ICHANN)
27370C...a2_tc+ -> gamma + pi_tc+.
27371 ELSEIF(I.EQ.2) THEN
27372 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
27373 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
27374C...a2_tc+ -> W+ + Z
27375 ELSEIF(I.EQ.3) THEN
27376 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
27377 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
27378 WID2=WIDS(24,ICHANN)*WIDS(23,2)
27379C...a2_tc+ -> W+ + pi_tc0.
27380 ELSEIF(I.EQ.4) THEN
27381 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27382 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
27383C...a2_tc+ -> W+ + pi_tc'0.
27384 ELSEIF(I.EQ.5) THEN
27385 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
27386 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
27387C...a2_tc+ -> Z0 + pi_tc+.
27388 ELSEIF(I.EQ.6) THEN
27389 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
27390 & RTCM(49)**2
27391 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
27392 ENDIF
27393 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27394 & /3D0*SHR**3
27395 ELSEIF(I.LE.10) THEN
27396 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27397 FACPA=PCM**2*(1D0+RM1+RM2)
27398 VA2=0D0
27399 AA2=0D0
27400C...a2_tc+ -> gamma + rho_tc+
27401 IF(I.EQ.7) THEN
27402 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27403 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
27404C...a2_tc+ -> W+ + rho_T^0
27405 ELSEIF(I.EQ.8) THEN
27406 AA2=1D0/(4D0*XW)/RTCM(51)**4
27407 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
27408C...a2_tc+ -> W+ + omega_T
27409 ELSEIF(I.EQ.9) THEN
27410 VA2=.25D0/XW/RTCM(50)**4
27411 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
27412C...a2_tc+ -> Z^0 + rho_T^+
27413 ELSEIF(I.EQ.10) THEN
27414 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27415 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
27416 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
27417 ENDIF
27418 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27419 ELSE
27420C...a2_tc+ -> f + fbar'.
27421 IA=I-10
27422 WID2=1D0
27423 IF(IA.LE.16) THEN
27424 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27425 IF(KFLR.GT.0) THEN
27426 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27427 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27428 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27429 ELSE
27430 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27431 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27432 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27433 ENDIF
27434 ELSE
27435 FCOF=1D0
27436 IF(KFLR.GT.0) THEN
27437 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27438 ELSE
27439 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27440 ENDIF
27441 ENDIF
27442 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27443 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27444 ENDIF
27445 WDTP(I)=FUDGE*WDTP(I)
27446 WDTP(0)=WDTP(0)+WDTP(I)
27447 IF(MDME(IDC,1).GT.0) THEN
27448 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27449 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27450 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27451 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27452 ENDIF
27453 540 CONTINUE
27454
27455 ENDIF
27456 MINT(61)=0
27457 MINT(62)=0
27458 MINT(63)=0
27459 RETURN
27460 END
27461
27462C***********************************************************************
27463
27464C...PYOFSH
27465C...Calculates partial width and differential cross-section maxima
27466C...of channels/processes not allowed on mass-shell, and selects
27467C...masses in such channels/processes.
27468
27469 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
27470
27471C...Double precision and integer declarations.
27472 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27473 IMPLICIT INTEGER(I-N)
27474 INTEGER PYK,PYCHGE,PYCOMP
27475C...Commonblocks.
27476 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27477 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27478 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
27479 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
27480 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27481 COMMON/PYINT1/MINT(400),VINT(400)
27482 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
27483 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
27484 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
27485 &/PYINT2/,/PYINT5/
27486C...Local arrays.
27487 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
27488 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
27489 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
27490 &WDTE(0:400,0:5)
27491
27492C...Find if particles equal, maximum mass, matrix elements, etc.
27493 MINT(51)=0
27494 ISUB=MINT(1)
27495 KFD(1)=IABS(KFD1)
27496 KFD(2)=IABS(KFD2)
27497 MEQL=0
27498 IF(KFD(1).EQ.KFD(2)) MEQL=1
27499 MLM=0
27500 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
27501 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
27502 NOFF=44
27503 PMMX=PMMO
27504 ELSE
27505 NOFF=40
27506 PMMX=VINT(1)
27507 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
27508 ENDIF
27509 MMED=0
27510 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
27511 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
27512 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
27513 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
27514 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
27515 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
27516 LOOP=1
27517
27518C...Find where Breit-Wigners are required, else select discrete masses.
27519 100 DO 110 I=1,2
27520 KFCA=PYCOMP(KFD(I))
27521 IF(KFCA.GT.0) THEN
27522 PMD(I)=PMAS(KFCA,1)
27523 PGD(I)=PMAS(KFCA,2)
27524 ELSE
27525 PMD(I)=0D0
27526 PGD(I)=0D0
27527 ENDIF
27528 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
27529 MBW(I)=0
27530 PMG(I)=PMD(I)
27531 RMG(I)=(PMG(I)/PMMX)**2
27532 ELSE
27533 MBW(I)=1
27534 ENDIF
27535 110 CONTINUE
27536
27537C...Find allowed mass range and Breit-Wigner parameters.
27538 DO 120 I=1,2
27539 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
27540 PML(I)=PARP(42)
27541 PMU(I)=PMMX-PARP(42)
27542 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27543 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27544 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
27545 ILM=I
27546 IF(MLM.EQ.2) ILM=3-I
27547 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
27548 IF(MBW(3-I).EQ.0) THEN
27549 PMU(I)=PMMX-PMD(3-I)
27550 ELSE
27551 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
27552 ENDIF
27553 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
27554 & MIN(PMU(I),CKIN(NOFF+2*ILM))
27555 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27556 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27557 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27558 IF(MBW(I).EQ.1) THEN
27559 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27560 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27561 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27562 & PGD(I)))
27563 ENDIF
27564 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
27565 ILM=I
27566 IF(MLM.EQ.2) ILM=3-I
27567 PML(I)=MAX(CKIN(48+I),PARP(42))
27568 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
27569 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
27570 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
27571 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
27572 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
27573 IF(MBW(I).EQ.1) THEN
27574 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27575 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
27576 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
27577 & PGD(I)))
27578 ENDIF
27579 ENDIF
27580 120 CONTINUE
27581 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
27582 &THEN
27583 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
27584 MINT(51)=1
27585 RETURN
27586 ENDIF
27587
27588C...Calculation of partial width of resonance.
27589 IF(MOFSH.EQ.1) THEN
27590
27591C..If only one integration, pick that to be the inner.
27592 IF(MBW(1).EQ.0) THEN
27593 PM2=PMD(1)
27594 PMD(1)=PMD(2)
27595 PGD(1)=PGD(2)
27596 PML(1)=PML(2)
27597 PMU(1)=PMU(2)
27598 ELSEIF(MBW(2).EQ.0) THEN
27599 PM2=PMD(2)
27600 ENDIF
27601
27602C...Start outer loop of integration.
27603 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27604 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27605 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
27606 NPT2=1
27607 XPT2(1)=1D0
27608 INX2(1)=0
27609 FMAX2=0D0
27610 ENDIF
27611 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27612 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
27613 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
27614 ENDIF
27615 RM2=(PM2/PMMX)**2
27616
27617C...Start inner loop of integration.
27618 PML1=PML(1)
27619 PMU1=MIN(PMU(1),PMMX-PM2)
27620 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
27621 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27622 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
27623 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
27624 FUNC2=0D0
27625 GOTO 180
27626 ENDIF
27627 NPT1=1
27628 XPT1(1)=1D0
27629 INX1(1)=0
27630 FMAX1=0D0
27631 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
27632 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
27633 RM1=(PM1/PMMX)**2
27634
27635C...Evaluate function value - inner loop.
27636 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27637 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
27638 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
27639 & RM2**2+10D0*RM1*RM2)
27640 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
27641 FPT1(NPT1)=FUNC1
27642
27643C...Go to next position in inner loop.
27644 IF(NPT1.EQ.1) THEN
27645 NPT1=NPT1+1
27646 XPT1(NPT1)=0D0
27647 INX1(NPT1)=1
27648 GOTO 140
27649 ELSEIF(NPT1.LE.8) THEN
27650 NPT1=NPT1+1
27651 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
27652 ISH1=ISH1+1
27653 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27654 INX1(NPT1)=INX1(ISH1)
27655 INX1(ISH1)=NPT1
27656 GOTO 140
27657 ELSEIF(NPT1.LT.100) THEN
27658 ISN1=ISH1
27659 150 ISH1=ISH1+1
27660 IF(ISH1.GT.NPT1) ISH1=2
27661 IF(ISH1.EQ.ISN1) GOTO 160
27662 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
27663 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
27664 NPT1=NPT1+1
27665 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
27666 INX1(NPT1)=INX1(ISH1)
27667 INX1(ISH1)=NPT1
27668 GOTO 140
27669 ENDIF
27670
27671C...Calculate integral over inner loop.
27672 160 FSUM1=0D0
27673 DO 170 IPT1=2,NPT1
27674 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
27675 & (XPT1(INX1(IPT1))-XPT1(IPT1))
27676 170 CONTINUE
27677 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
27678 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
27679 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
27680 FPT2(NPT2)=FUNC2
27681
27682C...Go to next position in outer loop.
27683 IF(NPT2.EQ.1) THEN
27684 NPT2=NPT2+1
27685 XPT2(NPT2)=0D0
27686 INX2(NPT2)=1
27687 GOTO 130
27688 ELSEIF(NPT2.LE.8) THEN
27689 NPT2=NPT2+1
27690 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
27691 ISH2=ISH2+1
27692 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27693 INX2(NPT2)=INX2(ISH2)
27694 INX2(ISH2)=NPT2
27695 GOTO 130
27696 ELSEIF(NPT2.LT.100) THEN
27697 ISN2=ISH2
27698 190 ISH2=ISH2+1
27699 IF(ISH2.GT.NPT2) ISH2=2
27700 IF(ISH2.EQ.ISN2) GOTO 200
27701 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
27702 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
27703 NPT2=NPT2+1
27704 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
27705 INX2(NPT2)=INX2(ISH2)
27706 INX2(ISH2)=NPT2
27707 GOTO 130
27708 ENDIF
27709
27710C...Calculate integral over outer loop.
27711 200 FSUM2=0D0
27712 DO 210 IPT2=2,NPT2
27713 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
27714 & (XPT2(INX2(IPT2))-XPT2(IPT2))
27715 210 CONTINUE
27716 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
27717 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
27718 ELSE
27719 FSUM2=FUNC2
27720 ENDIF
27721
27722C...Save result; second integration for user-selected mass range.
27723 IF(LOOP.EQ.1) WIDW=FSUM2
27724 WID2=FSUM2
27725 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
27726 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
27727 LOOP=2
27728 GOTO 100
27729 ENDIF
27730 RET1=WIDW
27731 RET2=WID2/WIDW
27732
27733C...Select two decay product masses of a resonance.
27734 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
27735 220 DO 230 I=1,2
27736 IF(MBW(I).EQ.0) GOTO 230
27737 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
27738 & (ATU(I)-ATL(I)))
27739 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
27740 RMG(I)=(PMG(I)/PMMX)**2
27741 230 CONTINUE
27742 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27743 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
27744
27745C...Weight with matrix element (if none known, use beta factor).
27746 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
27747 IF(MMED.EQ.1) THEN
27748 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
27749 ELSEIF(MMED.EQ.2) THEN
27750 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
27751 & RMG(2)**2+10D0*RMG(1)*RMG(2))
27752 ELSEIF(MMED.EQ.3) THEN
27753 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
27754 ELSE
27755 WTBE=FLAM
27756 ENDIF
27757 IF(WTBE.LT.PYR(0)) GOTO 220
27758 RET1=PMG(1)
27759 RET2=PMG(2)
27760
27761C...Find suitable set of masses for initialization of 2 -> 2 processes.
27762 ELSEIF(MOFSH.EQ.3) THEN
27763 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
27764 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
27765 PMG(2)=PMD(2)
27766 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
27767 PMG(1)=PMD(1)
27768 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
27769 ELSE
27770 IDIV=-1
27771 240 IDIV=IDIV+1
27772 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
27773 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
27774 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
27775 ENDIF
27776 RET1=PMG(1)
27777 RET2=PMG(2)
27778
27779C...Evaluate importance of excluded tails of Breit-Wigners.
27780 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27781 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27782 IF(MEQL.LE.1) THEN
27783 VINT(80)=1D0
27784 DO 250 I=1,2
27785 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
27786 & PARU(1)
27787 250 CONTINUE
27788 ELSE
27789 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
27790 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
27791 ENDIF
27792 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
27793 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
27794 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
27795 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27796
27797C...Pick one particle to be the lighter (if improves efficiency).
27798 ELSEIF(MOFSH.EQ.4) THEN
27799 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
27800 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
27801 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
27802
27803C...Select two masses according to Breit-Wigner + flat in s + 1/s.
27804 DO 270 I=1,2
27805 IF(MBW(I).EQ.0) GOTO 270
27806 PMV=PMU(I)
27807 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27808 ATV=ATU(I)
27809 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27810 RBR=PYR(0)
27811 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27812 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
27813 IF(RBR.LT.0.8D0) THEN
27814 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
27815 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
27816 ELSEIF(RBR.LT.0.9D0) THEN
27817 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
27818 ELSEIF(RBR.LT.1.5D0) THEN
27819 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
27820 ELSE
27821 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
27822 & (PMV**2-PML(I)**2))))
27823 ENDIF
27824 270 CONTINUE
27825 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
27826 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
27827 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
27828 NGEN(0,1)=NGEN(0,1)+1
27829 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
27830 GOTO 260
27831 ELSE
27832 MINT(51)=1
27833 RETURN
27834 ENDIF
27835 ENDIF
27836 RET1=PMG(1)
27837 RET2=PMG(2)
27838
27839C...Give weight for selected mass distribution.
27840 VINT(80)=1D0
27841 DO 280 I=1,2
27842 IF(MBW(I).EQ.0) GOTO 280
27843 PMV=PMU(I)
27844 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
27845 ATV=ATU(I)
27846 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
27847 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
27848 & (PMD(I)*PGD(I))**2)/PARU(1)
27849 F1=1D0
27850 F2=1D0/PMG(I)**2
27851 F3=1D0/PMG(I)**4
27852 FI0=(ATV-ATL(I))/PARU(1)
27853 FI1=PMV**2-PML(I)**2
27854 FI2=2D0*LOG(PMV/PML(I))
27855 FI3=1D0/PML(I)**2-1D0/PMV**2
27856 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
27857 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
27858 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
27859 & 5D0*F3/FI3))
27860 ELSE
27861 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
27862 ENDIF
27863 VINT(80)=VINT(80)*FI0
27864 280 CONTINUE
27865 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
27866 ENDIF
27867
27868 RETURN
27869 END
27870
27871C***********************************************************************
27872
27873C...PYRECO
27874C...Handles the possibility of colour reconnection in W+W- events,
27875C...Based on the main scenarios of the Sjostrand and Khoze study:
27876C...I, II, II', intermediate and instantaneous; plus one model
27877C...along the lines of the Gustafson and Hakkinen: GH.
27878C...Note: also handles Z0 Z0 and W-W+ events, but notation below
27879C...is as if first resonance is W+ and second W-.
27880
27881 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
27882
27883C...Double precision and integer declarations.
27884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
27885 IMPLICIT INTEGER(I-N)
27886 INTEGER PYK,PYCHGE,PYCOMP
27887C...Parameter value; number of points in MC integration.
27888 PARAMETER (NPT=100)
27889C...Commonblocks.
27890 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
27891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
27892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
27893 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
27894 COMMON/PYINT1/MINT(400),VINT(400)
27895 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
27896C...Local arrays.
27897 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
27898 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
27899 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
27900 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
27901 &TMC(20),IJOIN(100)
27902
27903C...Functions to give four-product and to do determinants.
27904 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)
27905 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
27906 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
27907 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
27908
27909C...Only allow fraction of recoupling for GH, intermediate and
27910C...instantaneous.
27911 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
27912 IF(PYR(0).GT.PARP(120)) RETURN
27913 ENDIF
27914 ISUB=MINT(1)
27915
27916C...Common part for scenarios I, II, II', and GH.
27917 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
27918 &MSTP(115).EQ.5) THEN
27919
27920C...Read out frequently-used parameters.
27921 PI=PARU(1)
27922 HBAR=PARU(3)
27923 PMW=PMAS(24,1)
27924 IF(ISUB.EQ.22) PMW=PMAS(23,1)
27925 PGW=PMAS(24,2)
27926 IF(ISUB.EQ.22) PGW=PMAS(23,2)
27927 TFRAG=PARP(115)
27928 RHAD=PARP(116)
27929 FACT=PARP(117)
27930 BLOWR=PARP(118)
27931 BLOWT=PARP(119)
27932
27933C...Find range of decay products of the W's.
27934C...Background: the W's are stored in IW1 and IW2.
27935C...Their direct decay products in NSD1+1 through NSD1+4.
27936C...Products after shower (if any) in NSD1+5 through NAFT1
27937C...for first W and in NAFT1+1 through N for the second.
27938 IF(NAFT1.GT.NSD1+4) THEN
27939 NBEG(1)=NSD1+5
27940 NEND(1)=NAFT1
27941 ELSE
27942 NBEG(1)=NSD1+1
27943 NEND(1)=NSD1+2
27944 ENDIF
27945 IF(N.GT.NAFT1) THEN
27946 NBEG(2)=NAFT1+1
27947 NEND(2)=N
27948 ELSE
27949 NBEG(2)=NSD1+3
27950 NEND(2)=NSD1+4
27951 ENDIF
27952
27953C...Rearrange parton shower products along strings.
27954 NOLD=N
27955 CALL PYPREP(NSD1+1)
27956 IF(MINT(51).NE.0) RETURN
27957
27958C...Find partons pointing back to W+ and W-; store them with quark
27959C...end of string first.
27960 NNP=0
27961 NNM=0
27962 ISGP=0
27963 ISGM=0
27964 DO 120 I=NOLD+1,N
27965 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
27966 IF(IABS(K(I,2)).GE.22) GOTO 120
27967 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
27968 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
27969 NNP=NNP+1
27970 IF(ISGP.EQ.1) THEN
27971 INP(NNP)=I
27972 ELSE
27973 DO 100 I1=NNP,2,-1
27974 INP(I1)=INP(I1-1)
27975 100 CONTINUE
27976 INP(1)=I
27977 ENDIF
27978 IF(K(I,1).EQ.1) ISGP=0
27979 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
27980 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
27981 NNM=NNM+1
27982 IF(ISGM.EQ.1) THEN
27983 INM(NNM)=I
27984 ELSE
27985 DO 110 I1=NNM,2,-1
27986 INM(I1)=INM(I1-1)
27987 110 CONTINUE
27988 INM(1)=I
27989 ENDIF
27990 IF(K(I,1).EQ.1) ISGM=0
27991 ENDIF
27992 120 CONTINUE
27993
27994C...Boost to W+W- rest frame (not strictly needed).
27995 DO 130 J=1,3
27996 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
27997 130 CONTINUE
27998 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
27999 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28000 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28001
28002C...Select decay vertices of W+ and W-.
28003 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28004 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28005 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28006 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28007 GTMAX=MAX(TP,TM)
28008 DO 140 J=1,3
28009 XP(J)=TP*P(IW1,J)/P(IW1,4)
28010 XM(J)=TM*P(IW2,J)/P(IW2,4)
28011 140 CONTINUE
28012
28013C...Begin scenario I specifics.
28014 IF(MSTP(115).EQ.1) THEN
28015
28016C...Reconstruct velocity and direction of W+ string pieces.
28017 DO 170 IIP=1,NNP-1
28018 IF(K(INP(IIP),2).LT.0) GOTO 170
28019 I1=INP(IIP)
28020 I2=INP(IIP+1)
28021 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28022 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28023 DO 150 J=1,3
28024 V1(J)=P(I1,J)/P1A
28025 V2(J)=P(I2,J)/P2A
28026 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28027 DIRP(IIP,J)=V1(J)-V2(J)
28028 150 CONTINUE
28029 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28030 & BETP(IIP,3)**2)
28031 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28032 DO 160 J=1,3
28033 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28034 160 CONTINUE
28035 170 CONTINUE
28036
28037C...Reconstruct velocity and direction of W- string pieces.
28038 DO 200 IIM=1,NNM-1
28039 IF(K(INM(IIM),2).LT.0) GOTO 200
28040 I1=INM(IIM)
28041 I2=INM(IIM+1)
28042 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28043 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28044 DO 180 J=1,3
28045 V1(J)=P(I1,J)/P1A
28046 V2(J)=P(I2,J)/P2A
28047 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28048 DIRM(IIM,J)=V1(J)-V2(J)
28049 180 CONTINUE
28050 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28051 & BETM(IIM,3)**2)
28052 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28053 DO 190 J=1,3
28054 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28055 190 CONTINUE
28056 200 CONTINUE
28057
28058C...Loop over number of space-time points.
28059 NACC=0
28060 SUM=0D0
28061 DO 250 IPT=1,NPT
28062
28063C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28064 R=SQRT(-LOG(PYR(0)))
28065 PHI=2D0*PI*PYR(0)
28066 X=BLOWR*RHAD*R*COS(PHI)
28067 Y=BLOWR*RHAD*R*SIN(PHI)
28068 R=SQRT(-LOG(PYR(0)))
28069 PHI=2D0*PI*PYR(0)
28070 Z=BLOWR*RHAD*R*COS(PHI)
28071 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28072
28073C...Reject impossible points. Weight for sample distribution.
28074 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28075 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28076 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28077
28078C...Loop over W+ string pieces and find one with largest weight.
28079 IMAXP=0
28080 WTMAXP=1D-10
28081 XD(1)=X-XP(1)
28082 XD(2)=Y-XP(2)
28083 XD(3)=Z-XP(3)
28084 XD(4)=T-TP
28085 DO 220 IIP=1,NNP-1
28086 IF(K(INP(IIP),2).LT.0) GOTO 220
28087 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28088 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28089 DO 210 J=1,3
28090 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28091 210 CONTINUE
28092 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28093 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28094 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28095 & DIRP(IIP,3)*XB(3))**2
28096 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28097 & TFRAG**2)
28098 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28099 IF(WTP.GT.WTMAXP) THEN
28100 IMAXP=IIP
28101 WTMAXP=WTP
28102 ENDIF
28103 220 CONTINUE
28104
28105C...Loop over W- string pieces and find one with largest weight.
28106 IMAXM=0
28107 WTMAXM=1D-10
28108 XD(1)=X-XM(1)
28109 XD(2)=Y-XM(2)
28110 XD(3)=Z-XM(3)
28111 XD(4)=T-TM
28112 DO 240 IIM=1,NNM-1
28113 IF(K(INM(IIM),2).LT.0) GOTO 240
28114 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28115 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28116 DO 230 J=1,3
28117 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28118 230 CONTINUE
28119 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28120 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28121 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28122 & DIRM(IIM,3)*XB(3))**2
28123 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28124 & TFRAG**2)
28125 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28126 IF(WTM.GT.WTMAXM) THEN
28127 IMAXM=IIM
28128 WTMAXM=WTM
28129 ENDIF
28130 240 CONTINUE
28131
28132C...Result of integration.
28133 WT=0D0
28134 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28135 WT=WTMAXP*WTMAXM/WTSMP
28136 SUM=SUM+WT
28137 NACC=NACC+1
28138 IAP(NACC)=IMAXP
28139 IAM(NACC)=IMAXM
28140 WTA(NACC)=WT
28141 ENDIF
28142 250 CONTINUE
28143 RES=BLOWR**3*BLOWT*SUM/NPT
28144
28145C...Decide whether to reconnect and, if so, where.
28146 IACC=0
28147 PREC=1D0-EXP(-FACT*RES)
28148 IF(PREC.GT.PYR(0)) THEN
28149 RSUM=PYR(0)*SUM
28150 DO 260 IA=1,NACC
28151 IACC=IA
28152 RSUM=RSUM-WTA(IA)
28153 IF(RSUM.LE.0D0) GOTO 270
28154 260 CONTINUE
28155 270 IIP=IAP(IACC)
28156 IIM=IAM(IACC)
28157 ENDIF
28158
28159C...Begin scenario II and II' specifics.
28160 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28161
28162C...Loop through all string pieces, one from W+ and one from W-.
28163 NCROSS=0
28164 TC(0)=0D0
28165 DO 340 IIP=1,NNP-1
28166 IF(K(INP(IIP),2).LT.0) GOTO 340
28167 I1P=INP(IIP)
28168 I2P=INP(IIP+1)
28169 DO 330 IIM=1,NNM-1
28170 IF(K(INM(IIM),2).LT.0) GOTO 330
28171 I1M=INM(IIM)
28172 I2M=INM(IIM+1)
28173
28174C...Find endpoint velocity vectors.
28175 DO 280 J=1,3
28176 V1P(J)=P(I1P,J)/P(I1P,4)
28177 V2P(J)=P(I2P,J)/P(I2P,4)
28178 V1M(J)=P(I1M,J)/P(I1M,4)
28179 V2M(J)=P(I2M,J)/P(I2M,4)
28180 280 CONTINUE
28181
28182C...Define q matrix and find t.
28183 DO 290 J=1,3
28184 Q(1,J)=V2P(J)-V1P(J)
28185 Q(2,J)=-(V2M(J)-V1M(J))
28186 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28187 Q(4,J)=V1P(J)-V1M(J)
28188 290 CONTINUE
28189 T=-DETER(1,2,3)/DETER(1,2,4)
28190
28191C...Find alpha and beta; i.e. coordinates of crossing point.
28192 S11=Q(1,1)*(T-TP)
28193 S12=Q(2,1)*(T-TM)
28194 S13=Q(3,1)+Q(4,1)*T
28195 S21=Q(1,2)*(T-TP)
28196 S22=Q(2,2)*(T-TM)
28197 S23=Q(3,2)+Q(4,2)*T
28198 DEN=S11*S22-S12*S21
28199 ALP=(S12*S23-S22*S13)/DEN
28200 BET=(S21*S13-S11*S23)/DEN
28201
28202C...Check if solution acceptable.
28203 IANSW=1
28204 IF(T.LT.GTMAX) IANSW=0
28205 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28206 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28207
28208C...Find point of crossing and check that not inconsistent.
28209 DO 300 J=1,3
28210 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28211 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28212 300 CONTINUE
28213 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28214 & (XPP(3)-XMM(3))**2
28215 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28216 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28217 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28218
28219C...Find string eigentimes at crossing.
28220 IF(IANSW.EQ.1) THEN
28221 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28222 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28223 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28224 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28225 ELSE
28226 TAUP=0D0
28227 TAUM=0D0
28228 ENDIF
28229
28230C...Order crossings by time. End loop over crossings.
28231 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28232 NCROSS=NCROSS+1
28233 DO 310 I1=NCROSS,1,-1
28234 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28235 IPC(I1)=IIP
28236 IMC(I1)=IIM
28237 TC(I1)=T
28238 TPC(I1)=TAUP
28239 TMC(I1)=TAUM
28240 GOTO 320
28241 ELSE
28242 IPC(I1)=IPC(I1-1)
28243 IMC(I1)=IMC(I1-1)
28244 TC(I1)=TC(I1-1)
28245 TPC(I1)=TPC(I1-1)
28246 TMC(I1)=TMC(I1-1)
28247 ENDIF
28248 310 CONTINUE
28249 320 CONTINUE
28250 ENDIF
28251 330 CONTINUE
28252 340 CONTINUE
28253
28254C...Loop over crossings; find first (if any) acceptable one.
28255 IACC=0
28256 IF(NCROSS.GE.1) THEN
28257 DO 350 IC=1,NCROSS
28258 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28259 IF(PNFRAG.GT.PYR(0)) THEN
28260C...Scenario II: only compare with fragmentation time.
28261 IF(MSTP(115).EQ.2) THEN
28262 IACC=IC
28263 IIP=IPC(IACC)
28264 IIM=IMC(IACC)
28265 GOTO 360
28266C...Scenario II': also require that string length decreases.
28267 ELSE
28268 IIP=IPC(IC)
28269 IIM=IMC(IC)
28270 I1P=INP(IIP)
28271 I2P=INP(IIP+1)
28272 I1M=INM(IIM)
28273 I2M=INM(IIM+1)
28274 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28275 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28276 IF(ELNEW.LT.ELOLD) THEN
28277 IACC=IC
28278 IIP=IPC(IACC)
28279 IIM=IMC(IACC)
28280 GOTO 360
28281 ENDIF
28282 ENDIF
28283 ENDIF
28284 350 CONTINUE
28285 360 CONTINUE
28286 ENDIF
28287
28288C...Begin scenario GH specifics.
28289 ELSEIF(MSTP(115).EQ.5) THEN
28290
28291C...Loop through all string pieces, one from W+ and one from W-.
28292 IACC=0
28293 ELMIN=1D0
28294 DO 380 IIP=1,NNP-1
28295 IF(K(INP(IIP),2).LT.0) GOTO 380
28296 I1P=INP(IIP)
28297 I2P=INP(IIP+1)
28298 DO 370 IIM=1,NNM-1
28299 IF(K(INM(IIM),2).LT.0) GOTO 370
28300 I1M=INM(IIM)
28301 I2M=INM(IIM+1)
28302
28303C...Look for largest decrease of (exponent of) Lambda measure.
28304 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28305 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28306 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28307 IF(ELDIF.LT.ELMIN) THEN
28308 IACC=IIP+IIM
28309 ELMIN=ELDIF
28310 IPC(1)=IIP
28311 IMC(1)=IIM
28312 ENDIF
28313 370 CONTINUE
28314 380 CONTINUE
28315 IIP=IPC(1)
28316 IIM=IMC(1)
28317 ENDIF
28318
28319C...Common for scenarios I, II, II' and GH: reconnect strings.
28320 IF(IACC.NE.0) THEN
28321 MINT(32)=1
28322 NJOIN=0
28323 DO 390 IS=1,NNP+NNM
28324 NJOIN=NJOIN+1
28325 IF(IS.LE.IIP) THEN
28326 I=INP(IS)
28327 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28328 I=INM(IS-IIP+IIM)
28329 ELSEIF(IS.LE.IIP+NNM) THEN
28330 I=INM(IS-IIP-NNM+IIM)
28331 ELSE
28332 I=INP(IS-NNM)
28333 ENDIF
28334 IJOIN(NJOIN)=I
28335 IF(K(I,2).LT.0) THEN
28336 CALL PYJOIN(NJOIN,IJOIN)
28337 NJOIN=0
28338 ENDIF
28339 390 CONTINUE
28340
28341C...Restore original event record if no reconnection.
28342 ELSE
28343 DO 400 I=NSD1+1,NOLD
28344 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28345 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28346 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28347 ENDIF
28348 400 CONTINUE
28349 DO 410 I=NOLD+1,N
28350 K(K(I,3),1)=3
28351 410 CONTINUE
28352 N=NOLD
28353 ENDIF
28354
28355C...Boost back system.
28356 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28357 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
28358 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
28359 & BEWW(1),BEWW(2),BEWW(3))
28360
28361C...Common part for intermediate and instantaneous scenarios.
28362 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28363 MINT(32)=1
28364
28365C...Remove old shower products and reset showering ones.
28366 N=NSD1+4
28367 DO 420 I=NSD1+1,NSD1+4
28368 K(I,1)=3
28369 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28370 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28371 420 CONTINUE
28372
28373C...Identify quark-antiquark pairs.
28374 IQ1=NSD1+1
28375 IQ2=NSD1+2
28376 IQ3=NSD1+3
28377 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
28378 IQ4=2*NSD1+7-IQ3
28379
28380C...Reconnect strings.
28381 IJOIN(1)=IQ1
28382 IJOIN(2)=IQ4
28383 CALL PYJOIN(2,IJOIN)
28384 IJOIN(1)=IQ3
28385 IJOIN(2)=IQ2
28386 CALL PYJOIN(2,IJOIN)
28387
28388C...Do new parton showers in intermediate scenario.
28389 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
28390 MSTJ50=MSTJ(50)
28391 MSTJ(50)=0
28392 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
28393 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
28394 MSTJ(50)=MSTJ50
28395
28396C...Do new parton showers in instantaneous scenario.
28397 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
28398 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
28399 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
28400 PPM=SQRT(MAX(0D0,PPM2))
28401 CALL PYSHOW(IQ1,IQ4,PPM)
28402 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
28403 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
28404 PPM=SQRT(MAX(0D0,PPM2))
28405 CALL PYSHOW(IQ3,IQ2,PPM)
28406 ENDIF
28407 ENDIF
28408
28409 RETURN
28410 END
28411
28412C***********************************************************************
28413
28414C...PYKLIM
28415C...Checks generated variables against pre-set kinematical limits;
28416C...also calculates limits on variables used in generation.
28417
28418 SUBROUTINE PYKLIM(ILIM)
28419
28420C...Double precision and integer declarations.
28421 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28422 IMPLICIT INTEGER(I-N)
28423 INTEGER PYK,PYCHGE,PYCOMP
28424C...Commonblocks.
28425 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28426 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28427 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28428 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28429 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28430 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28431 COMMON/PYINT1/MINT(400),VINT(400)
28432 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28433 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
28434 &/PYINT1/,/PYINT2/
28435
28436C...Common kinematical expressions.
28437 MINT(51)=0
28438 ISUB=MINT(1)
28439 ISTSB=ISET(ISUB)
28440 IF(ISUB.EQ.96) GOTO 100
28441 SQM3=VINT(63)
28442 SQM4=VINT(64)
28443 IF(ILIM.NE.0) THEN
28444 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
28445 CKIN09=MAX(CKIN(9),CKIN(13))
28446 CKIN10=MIN(CKIN(10),CKIN(14))
28447 CKIN11=MAX(CKIN(11),CKIN(15))
28448 CKIN12=MIN(CKIN(12),CKIN(16))
28449 ELSE
28450 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
28451 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
28452 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
28453 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
28454 ENDIF
28455 ENDIF
28456 IF(ILIM.NE.1) THEN
28457 TAU=VINT(21)
28458 RM3=SQM3/(TAU*VINT(2))
28459 RM4=SQM4/(TAU*VINT(2))
28460 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
28461 ENDIF
28462 PTHMIN=CKIN(3)
28463 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
28464 &PTHMIN=MAX(CKIN(3),CKIN(5))
28465
28466 IF(ILIM.EQ.0) THEN
28467C...Check generated values of tau, y*, cos(theta-hat), and tau' against
28468C...pre-set kinematical limits.
28469 YST=VINT(22)
28470 CTH=VINT(23)
28471 TAUP=VINT(26)
28472 TAUE=TAU
28473 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
28474 X1=SQRT(TAUE)*EXP(YST)
28475 X2=SQRT(TAUE)*EXP(-YST)
28476 XF=X1-X2
28477 IF(MINT(47).NE.1) THEN
28478 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
28479 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
28480 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
28481 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
28482 ENDIF
28483 IF(MINT(45).NE.1) THEN
28484 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
28485 ENDIF
28486 IF(MINT(46).NE.1) THEN
28487 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
28488 ENDIF
28489 IF(MINT(45).EQ.2) THEN
28490 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28491 ENDIF
28492 IF(MINT(46).EQ.2) THEN
28493 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
28494 ENDIF
28495 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
28496 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
28497 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
28498 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
28499 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
28500 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
28501 Y3=YST+0.5D0*LOG(EXPY3)
28502 Y4=YST+0.5D0*LOG(EXPY4)
28503 YLARGE=MAX(Y3,Y4)
28504 YSMALL=MIN(Y3,Y4)
28505 ETALAR=20D0
28506 ETASMA=-20D0
28507 STH=SQRT(MAX(0D0,1D0-CTH**2))
28508 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
28509 & CTH)**2-4D0*RM3))
28510 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
28511 & CTH)**2-4D0*RM4))
28512 IF(STH.GE.1D-10) THEN
28513 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
28514 & (BE34*STH)
28515 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
28516 & (BE34*STH)
28517 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
28518 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
28519 ETALAR=MAX(ETA3,ETA4)
28520 ETASMA=MIN(ETA3,ETA4)
28521 ENDIF
28522 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
28523 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
28524 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
28525 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
28526 SH=TAU*VINT(2)
28527 RPTS=4D0*VINT(71)**2/SH
28528 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
28529 RM34=MAX(1D-20,2D0*RM3*RM4)
28530 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28531 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28532 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
28533 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
28534 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
28535 IF(PTH.LT.PTHMIN) MINT(51)=1
28536 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
28537 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
28538 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
28539 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
28540 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
28541 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
28542 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
28543 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
28544 IF(THA.LT.CKIN(35)) MINT(51)=1
28545 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
28546 IF(UHA.LT.CKIN(37)) MINT(51)=1
28547 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
28548 ENDIF
28549 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
28550 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
28551 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
28552 ENDIF
28553
28554C...Additional cuts on W2 (approximately) in DIS.
28555 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
28556 XBJ=X2
28557 IF(IABS(MINT(12)).LT.20) XBJ=X1
28558 Q2BJ=THA
28559 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
28560 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
28561 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
28562 ENDIF
28563
28564 ELSEIF(ILIM.EQ.1) THEN
28565C...Calculate limits on tau
28566C...0) due to definition
28567 TAUMN0=0D0
28568 TAUMX0=1D0
28569C...1) due to limits on subsystem mass
28570 TAUMN1=CKIN(1)**2/VINT(2)
28571 TAUMX1=1D0
28572 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
28573C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
28574 TM3=SQRT(SQM3+PTHMIN**2)
28575 TM4=SQRT(SQM4+PTHMIN**2)
28576 YDCOSH=1D0
28577 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
28578 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
28579 TAUMX2=1D0
28580C...3) due to limits on pT-hat and cos(theta-hat)
28581 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
28582 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
28583 TAUMN3=0D0
28584 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
28585 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
28586 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
28587 TAUMX3=1D0
28588 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
28589 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
28590 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
28591C...4) due to limits on x1 and x2
28592 TAUMN4=CKIN(21)*CKIN(23)
28593 TAUMX4=CKIN(22)*CKIN(24)
28594C...5) due to limits on xF
28595 TAUMN5=0D0
28596 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
28597C...6) due to limits on that and uhat
28598 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
28599 TAUMX6=1D0
28600 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
28601 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
28602
28603C...Net effect of all separate limits.
28604 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
28605 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
28606 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28607 VINT(11)=1D0-1D-9
28608 VINT(31)=1D0+1D-9
28609 ELSEIF(MINT(47).EQ.5) THEN
28610 VINT(31)=MIN(VINT(31),1D0-2D-10)
28611 ELSEIF(MINT(47).GE.6) THEN
28612 VINT(31)=MIN(VINT(31),1D0-1D-10)
28613 ENDIF
28614 IF(VINT(31).LE.VINT(11)) MINT(51)=1
28615
28616 ELSEIF(ILIM.EQ.2) THEN
28617C...Calculate limits on y*
28618 TAUE=TAU
28619 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28620 TAURT=SQRT(TAUE)
28621C...0) due to kinematics
28622 YSTMN0=LOG(TAURT)
28623 YSTMX0=-YSTMN0
28624C...1) due to explicit limits
28625 YSTMN1=CKIN(7)
28626 YSTMX1=CKIN(8)
28627C...2) due to limits on x1
28628 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
28629 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
28630C...3) due to limits on x2
28631 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
28632 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
28633C...4) due to limits on xF
28634 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
28635 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
28636 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
28637 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
28638C...5) due to simultaneous limits on y-large and y-small
28639 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
28640 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
28641 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
28642 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
28643 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
28644 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
28645C...6) due to simultaneous limits on cos(theta-hat) and y-large or
28646C... y-small
28647 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
28648 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
28649 RZMX=BE34*MIN(CKIN(28),CTHLIM)
28650 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
28651 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
28652 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
28653 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
28654 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
28655 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
28656
28657C...Net effect of all separate limits.
28658 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
28659 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
28660 IF(MINT(47).EQ.1) THEN
28661 VINT(12)=-1D-9
28662 VINT(32)=1D-9
28663 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28664 VINT(12)=(1D0-1D-9)*YSTMX0
28665 VINT(32)=(1D0+1D-9)*YSTMX0
28666 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28667 VINT(12)=-(1D0+1D-9)*YSTMX0
28668 VINT(32)=-(1D0-1D-9)*YSTMX0
28669 ELSEIF(MINT(47).EQ.5) THEN
28670 YSTEE=LOG((1D0-1D-10)/TAURT)
28671 VINT(12)=MAX(VINT(12),-YSTEE)
28672 VINT(32)=MIN(VINT(32),YSTEE)
28673 ENDIF
28674 IF(VINT(32).LE.VINT(12)) MINT(51)=1
28675
28676 ELSEIF(ILIM.EQ.3) THEN
28677C...Calculate limits on cos(theta-hat)
28678 YST=VINT(22)
28679C...0) due to definition
28680 CTNMN0=-1D0
28681 CTNMX0=0D0
28682 CTPMN0=0D0
28683 CTPMX0=1D0
28684C...1) due to explicit limits
28685 CTNMN1=MIN(0D0,CKIN(27))
28686 CTNMX1=MIN(0D0,CKIN(28))
28687 CTPMN1=MAX(0D0,CKIN(27))
28688 CTPMX1=MAX(0D0,CKIN(28))
28689C...2) due to limits on pT-hat
28690 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
28691 CTPMX2=-CTNMN2
28692 CTNMX2=0D0
28693 CTPMN2=0D0
28694 IF(CKIN(4).GE.0D0) THEN
28695 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
28696 & (BE34**2*TAU*VINT(2))))
28697 CTPMN2=-CTNMX2
28698 ENDIF
28699C...3) due to limits on y-large and y-small
28700 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
28701 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
28702 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
28703 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
28704 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
28705 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
28706 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
28707 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
28708C...4) due to limits on that
28709 CTNMN4=-1D0
28710 CTNMX4=0D0
28711 CTPMN4=0D0
28712 CTPMX4=1D0
28713 SH=TAU*VINT(2)
28714 IF(CKIN(35).GT.0D0) THEN
28715 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
28716 IF(CTLIM.GT.0D0) THEN
28717 CTPMX4=CTLIM
28718 ELSE
28719 CTPMX4=0D0
28720 CTNMX4=CTLIM
28721 ENDIF
28722 ENDIF
28723 IF(CKIN(36).GT.0D0) THEN
28724 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
28725 IF(CTLIM.LT.0D0) THEN
28726 CTNMN4=CTLIM
28727 ELSE
28728 CTNMN4=0D0
28729 CTPMN4=CTLIM
28730 ENDIF
28731 ENDIF
28732C...5) due to limits on uhat
28733 CTNMN5=-1D0
28734 CTNMX5=0D0
28735 CTPMN5=0D0
28736 CTPMX5=1D0
28737 IF(CKIN(37).GT.0D0) THEN
28738 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
28739 IF(CTLIM.LT.0D0) THEN
28740 CTNMN5=CTLIM
28741 ELSE
28742 CTNMN5=0D0
28743 CTPMN5=CTLIM
28744 ENDIF
28745 ENDIF
28746 IF(CKIN(38).GT.0D0) THEN
28747 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
28748 IF(CTLIM.GT.0D0) THEN
28749 CTPMX5=CTLIM
28750 ELSE
28751 CTPMX5=0D0
28752 CTNMX5=CTLIM
28753 ENDIF
28754 ENDIF
28755
28756C...Net effect of all separate limits.
28757 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
28758 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
28759 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
28760 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
28761 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
28762
28763 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
28764 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
28765
28766 ELSEIF(ILIM.EQ.4) THEN
28767C...Calculate limits on tau'
28768C...0) due to kinematics
28769 TAPMN0=TAU
28770 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
28771 PQRAT=(VINT(201)+VINT(206))/VINT(1)
28772 TAPMN0=(SQRT(TAU)+PQRAT)**2
28773 ENDIF
28774 TAPMX0=1D0
28775C...1) due to explicit limits
28776 TAPMN1=CKIN(31)**2/VINT(2)
28777 TAPMX1=1D0
28778 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
28779
28780C...Net effect of all separate limits.
28781 VINT(16)=MAX(TAPMN0,TAPMN1)
28782 VINT(36)=MIN(TAPMX0,TAPMX1)
28783 IF(MINT(47).EQ.1) THEN
28784 VINT(16)=1D0-1D-9
28785 VINT(36)=1D0+1D-9
28786 ELSEIF(MINT(47).EQ.5) THEN
28787 VINT(36)=MIN(VINT(36),1D0-2D-10)
28788 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
28789 VINT(36)=MIN(VINT(36),1D0-1D-10)
28790 ENDIF
28791 IF(VINT(36).LE.VINT(16)) MINT(51)=1
28792
28793 ENDIF
28794 RETURN
28795
28796C...Special case for low-pT and multiple interactions:
28797C...effective kinematical limits for tau, y*, cos(theta-hat).
28798 100 IF(ILIM.EQ.0) THEN
28799 ELSEIF(ILIM.EQ.1) THEN
28800 IF(MSTP(82).LE.1) THEN
28801 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28802 & VINT(2)
28803 ELSE
28804 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
28805 ENDIF
28806 VINT(31)=1D0
28807 ELSEIF(ILIM.EQ.2) THEN
28808 VINT(12)=0.5D0*LOG(VINT(21))
28809 VINT(32)=-VINT(12)
28810 ELSEIF(ILIM.EQ.3) THEN
28811 IF(MSTP(82).LE.1) THEN
28812 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
28813 & (VINT(21)*VINT(2))
28814 ELSE
28815 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
28816 & (VINT(21)*VINT(2))
28817 ENDIF
28818 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
28819 VINT(33)=0D0
28820 VINT(14)=0D0
28821 VINT(34)=-VINT(13)
28822 ENDIF
28823
28824 RETURN
28825 END
28826
28827C*********************************************************************
28828
28829C...PYKMAP
28830C...Maps a uniform distribution into a distribution of a kinematical
28831C...variable according to one of the possibilities allowed. It is
28832C...assumed that kinematical limits have been set by a PYKLIM call.
28833
28834 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
28835
28836C...Double precision and integer declarations.
28837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28838 IMPLICIT INTEGER(I-N)
28839 INTEGER PYK,PYCHGE,PYCOMP
28840C...Commonblocks.
28841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28842 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28843 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28844 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28845 COMMON/PYINT1/MINT(400),VINT(400)
28846 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28847 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
28848
28849C...Convert VVAR to tau variable.
28850 ISUB=MINT(1)
28851 ISTSB=ISET(ISUB)
28852 IF(IVAR.EQ.1) THEN
28853 TAUMIN=VINT(11)
28854 TAUMAX=VINT(31)
28855 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
28856 TAURE=VINT(73)
28857 GAMRE=VINT(74)
28858 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
28859 TAURE=VINT(75)
28860 GAMRE=VINT(76)
28861 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
28862 TAURE=VINT(77)
28863 GAMRE=VINT(78)
28864 ENDIF
28865 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
28866 TAU=1D0
28867 ELSEIF(MVAR.EQ.1) THEN
28868 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
28869 ELSEIF(MVAR.EQ.2) THEN
28870 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
28871 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
28872 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
28873 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
28874 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
28875 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
28876 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
28877 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
28878 ELSEIF(MINT(47).EQ.5) THEN
28879 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
28880 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
28881 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28882 ELSE
28883 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
28884 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
28885 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
28886 ENDIF
28887 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
28888
28889C...Convert VVAR to y* variable.
28890 ELSEIF(IVAR.EQ.2) THEN
28891 YSTMIN=VINT(12)
28892 YSTMAX=VINT(32)
28893 TAUE=VINT(21)
28894 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
28895 IF(MINT(47).EQ.1) THEN
28896 YST=0D0
28897 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
28898 YST=-0.5D0*LOG(TAUE)
28899 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
28900 YST=0.5D0*LOG(TAUE)
28901 ELSEIF(MVAR.EQ.1) THEN
28902 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
28903 ELSEIF(MVAR.EQ.2) THEN
28904 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
28905 ELSEIF(MVAR.EQ.3) THEN
28906 AUPP=ATAN(EXP(YSTMAX))
28907 ALOW=ATAN(EXP(YSTMIN))
28908 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
28909 ELSEIF(MVAR.EQ.4) THEN
28910 YST0=-0.5D0*LOG(TAUE)
28911 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
28912 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
28913 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
28914 ELSE
28915 YST0=-0.5D0*LOG(TAUE)
28916 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
28917 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
28918 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
28919 ENDIF
28920 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
28921
28922C...Convert VVAR to cos(theta-hat) variable.
28923 ELSEIF(IVAR.EQ.3) THEN
28924 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
28925 RSQM=1D0+RM34
28926 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
28927 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
28928 CTNMIN=VINT(13)
28929 CTNMAX=VINT(33)
28930 CTPMIN=VINT(14)
28931 CTPMAX=VINT(34)
28932 IF(MVAR.EQ.1) THEN
28933 ANEG=CTNMAX-CTNMIN
28934 APOS=CTPMAX-CTPMIN
28935 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28936 VCTN=VVAR*(ANEG+APOS)/ANEG
28937 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
28938 ELSE
28939 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28940 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
28941 ENDIF
28942 ELSEIF(MVAR.EQ.2) THEN
28943 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28944 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28945 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28946 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28947 ANEG=LOG(RMNMIN/RMNMAX)
28948 APOS=LOG(RMPMIN/RMPMAX)
28949 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28950 VCTN=VVAR*(ANEG+APOS)/ANEG
28951 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
28952 ELSE
28953 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28954 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
28955 ENDIF
28956 ELSEIF(MVAR.EQ.3) THEN
28957 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28958 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28959 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28960 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28961 ANEG=LOG(RMNMAX/RMNMIN)
28962 APOS=LOG(RMPMAX/RMPMIN)
28963 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28964 VCTN=VVAR*(ANEG+APOS)/ANEG
28965 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
28966 ELSE
28967 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28968 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
28969 ENDIF
28970 ELSEIF(MVAR.EQ.4) THEN
28971 RMNMIN=MAX(RM34,RSQM-CTNMIN)
28972 RMNMAX=MAX(RM34,RSQM-CTNMAX)
28973 RMPMIN=MAX(RM34,RSQM-CTPMIN)
28974 RMPMAX=MAX(RM34,RSQM-CTPMAX)
28975 ANEG=1D0/RMNMAX-1D0/RMNMIN
28976 APOS=1D0/RMPMAX-1D0/RMPMIN
28977 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28978 VCTN=VVAR*(ANEG+APOS)/ANEG
28979 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
28980 ELSE
28981 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28982 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
28983 ENDIF
28984 ELSEIF(MVAR.EQ.5) THEN
28985 RMNMIN=MAX(RM34,RSQM+CTNMIN)
28986 RMNMAX=MAX(RM34,RSQM+CTNMAX)
28987 RMPMIN=MAX(RM34,RSQM+CTPMIN)
28988 RMPMAX=MAX(RM34,RSQM+CTPMAX)
28989 ANEG=1D0/RMNMIN-1D0/RMNMAX
28990 APOS=1D0/RMPMIN-1D0/RMPMAX
28991 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
28992 VCTN=VVAR*(ANEG+APOS)/ANEG
28993 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
28994 ELSE
28995 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
28996 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
28997 ENDIF
28998 ENDIF
28999 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29000 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29001 VINT(23)=CTH
29002
29003C...Convert VVAR to tau' variable.
29004 ELSEIF(IVAR.EQ.4) THEN
29005 TAU=VINT(21)
29006 TAUPMN=VINT(16)
29007 TAUPMX=VINT(36)
29008 IF(MINT(47).EQ.1) THEN
29009 TAUP=1D0
29010 ELSEIF(MVAR.EQ.1) THEN
29011 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29012 ELSEIF(MVAR.EQ.2) THEN
29013 AUPP=(1D0-TAU/TAUPMX)**4
29014 ALOW=(1D0-TAU/TAUPMN)**4
29015 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29016 ELSEIF(MINT(47).EQ.5) THEN
29017 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29018 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29019 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29020 ELSE
29021 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29022 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29023 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29024 ENDIF
29025 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29026
29027C...Selection of extra variables needed in 2 -> 3 process:
29028C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29029C...Since no options are available, the functions of PYKLIM
29030C...and PYKMAP are joint for these choices.
29031 ELSEIF(IVAR.EQ.5) THEN
29032
29033C...Read out total energy and particle masses.
29034 MINT(51)=0
29035 MPTPK=1
29036 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29037 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29038 & MPTPK=2
29039 SHP=VINT(26)*VINT(2)
29040 SHPR=SQRT(SHP)
29041 PM1=VINT(201)
29042 PM2=VINT(206)
29043 PM3=SQRT(VINT(21))*VINT(1)
29044 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29045 MINT(51)=1
29046 RETURN
29047 ENDIF
29048 PMRS1=VINT(204)**2
29049 PMRS2=VINT(209)**2
29050
29051C...Specify coefficients of pT choice; upper and lower limits.
29052 IF(MPTPK.EQ.1) THEN
29053 HWT1=0.4D0
29054 HWT2=0.4D0
29055 ELSE
29056 HWT1=0.05D0
29057 HWT2=0.05D0
29058 ENDIF
29059 HWT3=1D0-HWT1-HWT2
29060 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29061 & (4D0*SHP)
29062 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29063 PTSMN1=CKIN(51)**2
29064 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29065 & (4D0*SHP)
29066 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29067 PTSMN2=CKIN(53)**2
29068
29069C...Select transverse momenta according to
29070C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29071 HMX=PMRS1+PTSMX1
29072 HMN=PMRS1+PTSMN1
29073 IF(HMX.LT.1.0001D0*HMN) THEN
29074 MINT(51)=1
29075 RETURN
29076 ENDIF
29077 HDE=PTSMX1-PTSMN1
29078 RPT=PYR(0)
29079 IF(RPT.LT.HWT1) THEN
29080 PTS1=PTSMN1+PYR(0)*HDE
29081 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29082 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29083 ELSE
29084 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29085 ENDIF
29086 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29087 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29088 HMX=PMRS2+PTSMX2
29089 HMN=PMRS2+PTSMN2
29090 IF(HMX.LT.1.0001D0*HMN) THEN
29091 MINT(51)=1
29092 RETURN
29093 ENDIF
29094 HDE=PTSMX2-PTSMN2
29095 RPT=PYR(0)
29096 IF(RPT.LT.HWT1) THEN
29097 PTS2=PTSMN2+PYR(0)*HDE
29098 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29099 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29100 ELSE
29101 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29102 ENDIF
29103 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29104 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29105
29106C...Select azimuthal angles and check pT choice.
29107 PHI1=PARU(2)*PYR(0)
29108 PHI2=PARU(2)*PYR(0)
29109 PHIR=PHI2-PHI1
29110 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29111 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29112 & CKIN(56)**2)) THEN
29113 MINT(51)=1
29114 RETURN
29115 ENDIF
29116
29117C...Calculate transverse masses and check phase space not closed.
29118 PMS1=PM1**2+PTS1
29119 PMS2=PM2**2+PTS2
29120 PMS3=PM3**2+PTS3
29121 PMT1=SQRT(PMS1)
29122 PMT2=SQRT(PMS2)
29123 PMT3=SQRT(PMS3)
29124 PM12=(PMT1+PMT2)**2
29125 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29126 MINT(51)=1
29127 RETURN
29128 ENDIF
29129
29130C...Select rapidity for particle 3 and check phase space not closed.
29131 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29132 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29133 IF(Y3MAX.LT.1D-6) THEN
29134 MINT(51)=1
29135 RETURN
29136 ENDIF
29137 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29138 PZ3=PMT3*SINH(Y3)
29139 PE3=PMT3*COSH(Y3)
29140
29141C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29142 PZ12=-PZ3
29143 PE12=SHPR-PE3
29144 PMS12=PE12**2-PZ12**2
29145 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29146 IF(SQL12.LT.1D-6*SHP) THEN
29147 MINT(51)=1
29148 RETURN
29149 ENDIF
29150 PMM1=PMS12+PMS1-PMS2
29151 PMM2=PMS12+PMS2-PMS1
29152 TFAC=-SHPR/(2D0*PMS12)
29153 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29154 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29155 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29156 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29157
29158C...Construct relative mirror weights and make choice.
29159 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29160 WTPU=1D0
29161 WTNU=1D0
29162 ELSE
29163 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29164 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29165 ENDIF
29166 WTP=WTPU/(WTPU+WTNU)
29167 WTN=WTNU/(WTPU+WTNU)
29168 EPS=1D0
29169 IF(WTN.GT.PYR(0)) EPS=-1D0
29170
29171C...Store result of variable choice and associated weights.
29172 VINT(202)=PTS1
29173 VINT(207)=PTS2
29174 VINT(203)=PHI1
29175 VINT(208)=PHI2
29176 VINT(205)=WTPTS1
29177 VINT(210)=WTPTS2
29178 VINT(211)=Y3
29179 VINT(212)=Y3MAX
29180 VINT(213)=EPS
29181 IF(EPS.GT.0D0) THEN
29182 VINT(214)=1D0/WTP
29183 VINT(215)=T1P
29184 VINT(216)=T2P
29185 ELSE
29186 VINT(214)=1D0/WTN
29187 VINT(215)=T1N
29188 VINT(216)=T2N
29189 ENDIF
29190 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29191 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29192 VINT(219)=0.5D0*(PMS12-PTS3)
29193 VINT(220)=SQL12
29194 ENDIF
29195
29196 RETURN
29197 END
29198
29199C***********************************************************************
29200
29201C...PYSIGH
29202C...Differential matrix elements for all included subprocesses
29203C...Note that what is coded is (disregarding the COMFAC factor)
29204C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29205C...when d(sigma-hat) is given in the zero-width limit, the delta
29206C...function in tau is replaced by a (modified) Breit-Wigner:
29207C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29208C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29209C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29210C...i.e., dimensionless quantities
29211C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29212C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29213C...(2pi)^4 delta^4(P - sum p_i)
29214C...COMFAC contains the factor pi/s (or equivalent) and
29215C...the conversion factor from GeV^-2 to mb
29216
29217 SUBROUTINE PYSIGH(NCHN,SIGS)
29218
29219C...Double precision and integer declarations
29220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29221 IMPLICIT INTEGER(I-N)
29222 INTEGER PYK,PYCHGE,PYCOMP
29223C...Parameter statement to help give large particle numbers.
29224 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29225 &KEXCIT=4000000,KDIMEN=5000000)
29226C...Commonblocks
29227 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29230 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29233 COMMON/PYINT1/MINT(400),VINT(400)
29234 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29235 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29236 COMMON/PYINT4/MWID(500),WIDS(500,5)
29237 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29238 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29239 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29240 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29241 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29242 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29243 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29244 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29245 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29246 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29247 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29248 COMMON/PYTCCO/COEFX(194:380,2)
29249 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29250 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29251 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29252C...Local arrays and complex variables
29253 DIMENSION XPQ(-25:25)
29254
29255C...Map of processes onto which routine to call
29256C...in order to evaluate cross section:
29257C...0 = not implemented;
29258C...1 = standard QCD (including photons);
29259C...2 = heavy flavours;
29260C...3 = W/Z;
29261C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29262C...5 = SUSY;
29263C...6 = Technicolor;
29264C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29265C...8 = Universal Extra Dimensions
29266 DIMENSION MAPPR(500)
29267 DATA (MAPPR(I),I=1,180)/
29268 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29269 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29270 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29271 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29272 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29273 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29274 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29275 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29276 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29277 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29278 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29279 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29280 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29281 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29282 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29283 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29284 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29285 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29286 DATA (MAPPR(I),I=181,500)/
29287 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29288 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29289 & 100*5,
29290 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29291 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29292 1 20*0,
29293 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29294 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29295 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29296 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29297 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29298 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29299 & 4, 4, 18*0,
29300 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29301 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29302 4 20*0,
29303 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29304 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29305 8 20*0/
29306
29307C...Reset number of channels and cross-section
29308 NCHN=0
29309 SIGS=0D0
29310
29311C...Read process to consider.
29312 ISUB=MINT(1)
29313 ISUBSV=ISUB
29314 MAP=MAPPR(ISUB)
29315
29316C...Read kinematical variables and limits
29317 ISTSB=ISET(ISUBSV)
29318 TAUMIN=VINT(11)
29319 YSTMIN=VINT(12)
29320 CTNMIN=VINT(13)
29321 CTPMIN=VINT(14)
29322 TAUPMN=VINT(16)
29323 TAU=VINT(21)
29324 YST=VINT(22)
29325 CTH=VINT(23)
29326 XT2=VINT(25)
29327 TAUP=VINT(26)
29328 TAUMAX=VINT(31)
29329 YSTMAX=VINT(32)
29330 CTNMAX=VINT(33)
29331 CTPMAX=VINT(34)
29332 TAUPMX=VINT(36)
29333
29334C...Derive kinematical quantities
29335 TAUE=TAU
29336 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29337 X(1)=SQRT(TAUE)*EXP(YST)
29338 X(2)=SQRT(TAUE)*EXP(-YST)
29339 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29340 IF(X(1).GT.1D0-1D-7) RETURN
29341 ELSEIF(MINT(45).EQ.3) THEN
29342 X(1)=MIN(1D0-1.1D-10,X(1))
29343 ENDIF
29344 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29345 IF(X(2).GT.1D0-1D-7) RETURN
29346 ELSEIF(MINT(46).EQ.3) THEN
29347 X(2)=MIN(1D0-1.1D-10,X(2))
29348 ENDIF
29349 SH=MAX(1D0,TAU*VINT(2))
29350 SQM3=VINT(63)
29351 SQM4=VINT(64)
29352 RM3=SQM3/SH
29353 RM4=SQM4/SH
29354 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29355 RPTS=4D0*VINT(71)**2/SH
29356 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29357 RM34=MAX(1D-20,2D0*RM3*RM4)
29358 RSQM=1D0+RM34
29359 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
29360 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
29361 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29362 IF(ISTSB.EQ.0) THEN
29363 TH=VINT(45)
29364 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29365 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
29366 ELSE
29367C...Kinematics with incoming masses tricky: now depends on how
29368C...subprocess has been set up w.r.t. order of incoming partons.
29369 RM1=0D0
29370 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
29371 RM2=0D0
29372 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
29373 IF(ISUB.EQ.35) THEN
29374 RM2=MIN(RM1,RM2)
29375 RM1=0D0
29376 ENDIF
29377 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
29378 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
29379 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
29380 & BE12*BE34*CTH)
29381 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
29382 & BE12*BE34*CTH)
29383 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
29384 ENDIF
29385 SHR=SQRT(SH)
29386 SH2=SH**2
29387 TH2=TH**2
29388 UH2=UH**2
29389
29390C...Choice of Q2 scale for hard process (e.g. alpha_s).
29391 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
29392 Q2=SH
29393 ELSEIF(ISTSB.EQ.8) THEN
29394 IF(MINT(107).EQ.4) Q2=VINT(307)
29395 IF(MINT(108).EQ.4) Q2=VINT(308)
29396 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
29397 Q2IN1=0D0
29398 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
29399 Q2IN2=0D0
29400 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
29401 IF(MSTP(32).EQ.1) THEN
29402 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
29403 ELSEIF(MSTP(32).EQ.2) THEN
29404 Q2=SQPTH+0.5D0*(SQM3+SQM4)
29405 ELSEIF(MSTP(32).EQ.3) THEN
29406 Q2=MIN(-TH,-UH)
29407 ELSEIF(MSTP(32).EQ.4) THEN
29408 Q2=SH
29409 ELSEIF(MSTP(32).EQ.5) THEN
29410 Q2=-TH
29411 ELSEIF(MSTP(32).EQ.6) THEN
29412 XSF1=X(1)
29413 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
29414 XSF2=X(2)
29415 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
29416 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
29417 & (SQPTH+0.5D0*(SQM3+SQM4))
29418 ELSEIF(MSTP(32).EQ.7) THEN
29419 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
29420 ELSEIF(MSTP(32).EQ.8) THEN
29421 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
29422 ELSEIF(MSTP(32).EQ.9) THEN
29423 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
29424 ELSEIF(MSTP(32).EQ.10) THEN
29425 Q2=VINT(2)
29426C..Begin JA 040914
29427 ELSEIF(MSTP(32).EQ.11) THEN
29428 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
29429 ELSEIF(MSTP(32).EQ.12) THEN
29430 Q2=PARP(193)
29431C..End JA
29432 ELSEIF(MSTP(32).EQ.13) THEN
29433 Q2=SQPTH
29434 ENDIF
29435 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
29436 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
29437 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
29438 ENDIF
29439
29440C...Choice of Q2 scale for parton densities.
29441 Q2SF=Q2
29442C..Begin JA 040914
29443 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
29444 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
29445 & Q2=PARP(194)
29446C..End JA
29447 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29448 Q2SF=PMAS(23,1)**2
29449 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
29450 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
29451 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
29452 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
29453 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
29454 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
29455 IF(MSTP(39).EQ.2) Q2SF=
29456 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
29457 IF(MSTP(39).EQ.3) Q2SF=SH
29458 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
29459 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
29460C..Begin JA 040914
29461 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
29462 IF(MSTP(39).EQ.7) Q2SF=
29463 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
29464 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
29465C..End JA
29466 ENDIF
29467 ENDIF
29468 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
29469
29470 Q2PS=Q2SF
29471 Q2SF=Q2SF*PARP(34)
29472 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
29473 IF(MSTP(69).GE.2) Q2SF=VINT(2)
29474
29475C...Identify to which class(es) subprocess belongs
29476 ISMECR=0
29477 ISQCD=0
29478 ISJETS=0
29479 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
29480 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
29481 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
29482 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
29483 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
29484 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
29485 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
29486 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
29487 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
29488 IF (ISTSB.EQ.9) ISQCD=1
29489 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
29490 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
29491 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
29492 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
29493 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
29494 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
29495 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
29496 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
29497C...WBF is special case of ISJETS
29498 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
29499 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
29500 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
29501 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
29502 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
29503 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
29504 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
29505 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
29506 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
29507C...Some processes with photons also belong here.
29508 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
29509 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
29510 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
29511 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
29512 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
29513 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
29514
29515C...Choice of Q2 scale for parton-shower activity.
29516 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
29517 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
29518 XBJ=X(2)
29519 IF(MINT(43).EQ.3) XBJ=X(1)
29520 IF(MSTP(22).EQ.1) THEN
29521 Q2PS=-TH
29522 ELSEIF(MSTP(22).EQ.2) THEN
29523 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
29524 ELSEIF(MSTP(22).EQ.3) THEN
29525 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
29526 ELSE
29527 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
29528 ENDIF
29529 ENDIF
29530C...For multiple interactions, start from scale defined above
29531C...For all other QCD or "+jets"-type events, start shower from pThard.
29532 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
29533 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
29534C...Max shower scale = s for ME corrected processes.
29535C...(pT-ordering: max pT2 is s/4)
29536 Q2PS=VINT(2)
29537 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29538 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
29539C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
29540C...(pT-ordering: max pT2 is s/4)
29541 Q2PS=VINT(2)
29542 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
29543 ENDIF
29544 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
29545
29546C...Elastic and diffractive events not associated with scales so set 0.
29547 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
29548 Q2SF=0D0
29549 Q2PS=0D0
29550 ENDIF
29551
29552C...Store derived kinematical quantities
29553 VINT(41)=X(1)
29554 VINT(42)=X(2)
29555 VINT(44)=SH
29556 VINT(43)=SQRT(SH)
29557 VINT(45)=TH
29558 VINT(46)=UH
29559 IF(ISTSB.NE.8) VINT(48)=SQPTH
29560 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
29561 VINT(50)=TAUP*VINT(2)
29562 VINT(49)=SQRT(MAX(0D0,VINT(50)))
29563 VINT(52)=Q2
29564 VINT(51)=SQRT(Q2)
29565 VINT(54)=Q2SF
29566 VINT(53)=SQRT(Q2SF)
29567 VINT(56)=Q2PS
29568 VINT(55)=SQRT(Q2PS)
29569
29570C...Set starting scale for multiple interactions
29571 IF (ISUBSV.EQ.95) THEN
29572 XT2GMX=0D0
29573 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
29574 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
29575 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
29576 & ISUBSV.NE.96)) THEN
29577C...All accessible phase space allowed.
29578 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
29579 ELSE
29580C...Scale of hard process sets limit.
29581C...2 -> 1. Limit is tau = x1*x2.
29582C...2 -> 2. Limit is XT2 for hard process + FS masses.
29583C...2 -> n > 2. Limit is tau' = tau of outer process.
29584 XT2GMX=VINT(25)
29585 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
29586 IF(ISTSB.EQ.2)
29587 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
29588 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
29589 ENDIF
29590 VINT(62)=0.25D0*XT2GMX*VINT(2)
29591 VINT(61)=SQRT(MAX(0D0,VINT(62)))
29592
29593C...Calculate parton distributions
29594 IF(ISTSB.LE.0) GOTO 160
29595 IF(MINT(47).GE.2) THEN
29596 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
29597 XSF=X(I)
29598 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
29599 IF(ISUB.EQ.99) THEN
29600 IF(MINT(140+I).EQ.0) THEN
29601 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
29602 ELSE
29603 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
29604 ENDIF
29605 VINT(40+I)=XSF
29606 Q2SF=VINT(309-I)
29607 ENDIF
29608 MINT(105)=MINT(102+I)
29609 MINT(109)=MINT(106+I)
29610 VINT(120)=VINT(2+I)
29611C.... ALICE
29612C.... Store side in MINT(124)
29613 MINT(124) = I
29614C....
29615 IF(MSTP(57).LE.1) THEN
29616 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
29617 ELSE
29618 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
29619 ENDIF
29620C...Safety margin against heavy flavour very close to threshold,
29621C...e.g. caused by mismatch in c and b masses.
29622 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
29623 XPQ(4)=0D0
29624 XPQ(-4)=0D0
29625 ENDIF
29626 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
29627 XPQ(5)=0D0
29628 XPQ(-5)=0D0
29629 ENDIF
29630 DO 100 KFL=-25,25
29631 XSFX(I,KFL)=XPQ(KFL)
29632 100 CONTINUE
29633 110 CONTINUE
29634 ENDIF
29635
29636C...Calculate alpha_em, alpha_strong and K-factor
29637 XW=PARU(102)
29638 XWV=XW
29639 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
29640 &1D0-(PMAS(24,1)/PMAS(23,1))**2
29641 XW1=1D0-XW
29642 XWC=1D0/(16D0*XW*XW1)
29643 AEM=PYALEM(Q2)
29644 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
29645 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
29646 FACK=1D0
29647 FACA=1D0
29648 IF(MSTP(33).EQ.1) THEN
29649 FACK=PARP(31)
29650 ELSEIF(MSTP(33).EQ.2) THEN
29651 FACK=PARP(31)
29652 FACA=PARP(32)/PARP(31)
29653 ELSEIF(MSTP(33).EQ.3) THEN
29654 Q2AS=PARP(33)*Q2
29655 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
29656 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
29657 AS=PYALPS(Q2AS)
29658 ENDIF
29659 VINT(138)=1D0
29660 VINT(57)=AEM
29661 VINT(58)=AS
29662
29663C...Set flags for allowed reacting partons/leptons
29664 DO 140 I=1,2
29665 DO 120 J=-25,25
29666 KFAC(I,J)=0
29667 120 CONTINUE
29668 IF(MINT(44+I).EQ.1) THEN
29669 KFAC(I,MINT(10+I))=1
29670 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
29671 KFAC(I,MINT(10+I))=1
29672 KFAC(I,22)=1
29673 KFAC(I,24)=1
29674 KFAC(I,-24)=1
29675 ELSE
29676 DO 130 J=-25,25
29677 KFAC(I,J)=KFIN(I,J)
29678 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
29679 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
29680 130 CONTINUE
29681 ENDIF
29682 140 CONTINUE
29683
29684C...Lower and upper limit for fermion flavour loops
29685 MMIN1=0
29686 MMAX1=0
29687 MMIN2=0
29688 MMAX2=0
29689 DO 150 J=-20,20
29690 IF(KFAC(1,-J).EQ.1) MMIN1=-J
29691 IF(KFAC(1,J).EQ.1) MMAX1=J
29692 IF(KFAC(2,-J).EQ.1) MMIN2=-J
29693 IF(KFAC(2,J).EQ.1) MMAX2=J
29694 150 CONTINUE
29695 MMINA=MIN(MMIN1,MMIN2)
29696 MMAXA=MAX(MMAX1,MMAX2)
29697
29698C...Common resonance mass and width combinations
29699 SQMZ=PMAS(23,1)**2
29700 SQMW=PMAS(24,1)**2
29701 GMMZ=PMAS(23,1)*PMAS(23,2)
29702 GMMW=PMAS(24,1)*PMAS(24,2)
29703
29704C...Polarization factors...implemented so far for W+W-(25)
29705 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
29706 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
29707 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
29708 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
29709
29710C...Phase space integral in tau
29711 COMFAC=PARU(1)*PARU(5)/VINT(2)
29712 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
29713 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
29714 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
29715 ATAU1=LOG(TAUMAX/TAUMIN)
29716 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
29717 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
29718 IF(MINT(72).GE.1) THEN
29719 TAUR1=VINT(73)
29720 GAMR1=VINT(74)
29721 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
29722 ATAU3=ATAUD/TAUR1
29723 IF(ATAUD.GT.1D-10) H1=H1+
29724 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
29725 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
29726 ATAU4=ATAUD/GAMR1
29727 IF(ATAUD.GT.1D-10) H1=H1+
29728 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
29729 ENDIF
29730 IF(MINT(72).GE.2) THEN
29731 TAUR2=VINT(75)
29732 GAMR2=VINT(76)
29733 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
29734 ATAU5=ATAUD/TAUR2
29735 IF(ATAUD.GT.1D-10) H1=H1+
29736 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
29737 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
29738 ATAU6=ATAUD/GAMR2
29739 IF(ATAUD.GT.1D-10) H1=H1+
29740 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
29741 ENDIF
29742 IF(MINT(72).EQ.3) THEN
29743 TAUR3=VINT(77)
29744 GAMR3=VINT(78)
29745 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
29746 ATAU50=ATAUD/TAUR3
29747 IF(ATAUD.GT.1D-10) H1=H1+
29748 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
29749 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
29750 ATAU60=ATAUD/GAMR3
29751 IF(ATAUD.GT.1D-10) H1=H1+
29752 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
29753 ENDIF
29754 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29755 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
29756 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29757 & MAX(2D-10,1D0-TAU)
29758 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
29759 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
29760 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
29761 & MAX(1D-10,1D0-TAU)
29762 ENDIF
29763 COMFAC=COMFAC*ATAU1/(TAU*H1)
29764 ENDIF
29765
29766C...Phase space integral in y*
29767 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
29768 &THEN
29769 AYST0=YSTMAX-YSTMIN
29770 IF(AYST0.LT.1D-10) THEN
29771 COMFAC=0D0
29772 ELSE
29773 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29774 AYST2=AYST1
29775 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29776 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29777 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29778 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29779 IF(MINT(45).EQ.3) THEN
29780 YST0=-0.5D0*LOG(TAUE)
29781 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
29782 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29783 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
29784 & MAX(1D-10,1D0-EXP(YST-YST0))
29785 ENDIF
29786 IF(MINT(46).EQ.3) THEN
29787 YST0=-0.5D0*LOG(TAUE)
29788 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
29789 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29790 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
29791 & MAX(1D-10,1D0-EXP(-YST-YST0))
29792 ENDIF
29793 COMFAC=COMFAC*AYST0/H2
29794 ENDIF
29795 ENDIF
29796
29797C...2 -> 1 processes: reduction in angular part of phase space integral
29798C...for case of decaying resonance
29799 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
29800 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
29801 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
29802 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
29803 & KFPR(ISUB,1).EQ.39) THEN
29804 COMFAC=COMFAC*0.5D0*ACTH0
29805 ELSE
29806 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
29807 & CTPMAX**3-CTPMIN**3)
29808 ENDIF
29809 ENDIF
29810
29811C...2 -> 2 processes: angular part of phase space integral
29812 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29813 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
29814 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
29815 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
29816 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
29817 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
29818 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
29819 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
29820 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
29821 H3=COEF(ISUBSV,13)+
29822 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
29823 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
29824 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
29825 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
29826 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
29827
29828C...2 -> 2 processes: take into account final state Breit-Wigners
29829 COMFAC=COMFAC*VINT(80)
29830 ENDIF
29831
29832C...2 -> 3, 4 processes: phace space integral in tau'
29833 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29834 ATAUP1=LOG(TAUPMX/TAUPMN)
29835 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
29836 H4=COEF(ISUBSV,18)+
29837 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
29838 IF(MINT(47).EQ.5) THEN
29839 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
29840 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
29841 ELSEIF(MINT(47).GE.6) THEN
29842 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
29843 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
29844 ENDIF
29845 COMFAC=COMFAC*ATAUP1/H4
29846 ENDIF
29847
29848C...2 -> 3, 4 processes: effective W/Z parton distributions
29849 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
29850 IF(1D0-TAU/TAUP.GT.1D-4) THEN
29851 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
29852 ELSE
29853 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
29854 ENDIF
29855 COMFAC=COMFAC*FZW
29856 ENDIF
29857
29858C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
29859 IF(ISTSB.EQ.5) THEN
29860 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
29861 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
29862 ENDIF
29863
29864C...Phase space integral for low-pT and multiple interactions
29865 IF(ISTSB.EQ.9) THEN
29866 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
29867 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
29868 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
29869 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
29870 COMFAC=COMFAC*ATAU1/H1
29871 AYST0=YSTMAX-YSTMIN
29872 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
29873 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
29874 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
29875 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
29876 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
29877 COMFAC=COMFAC*AYST0/H2
29878 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
29879C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
29880C...introduced to make cross-section finite for xT2 -> 0
29881 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
29882 & (1D0+VINT(149)))
29883 ENDIF
29884
29885C...Real gamma + gamma: include factor 2 when different nature
29886 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
29887 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
29888
29889C...Extra factors to include the effects of
29890C...longitudinal resolved photons (but not direct or DIS ones).
29891 DO 170 ISDE=1,2
29892 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
29893 & MINT(106+ISDE).LE.3) THEN
29894 VINT(314+ISDE)=1D0
29895 XY=PARP(166+ISDE)
29896 IF(MSTP(16).EQ.0) THEN
29897 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
29898 & XY=VINT(304+ISDE)
29899 ELSE
29900 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
29901 & XY=VINT(308+ISDE)
29902 ENDIF
29903 Q2GA=VINT(306+ISDE)
29904 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
29905 & Q2GA.GT.0D0) THEN
29906 REDUCE=0D0
29907 IF(MSTP(17).EQ.1) THEN
29908 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
29909 ELSEIF(MSTP(17).EQ.2) THEN
29910 REDUCE=4D0*Q2GA/(Q2+Q2GA)
29911 ELSEIF(MSTP(17).EQ.3) THEN
29912 PMVIRT=PMAS(PYCOMP(113),1)
29913 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29914 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
29915 PMVIRT=PMAS(PYCOMP(113),1)
29916 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29917 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
29918 PMVIRT=PMAS(PYCOMP(113),1)
29919 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
29920 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
29921 PMVSMN=4D0*PARP(15)**2
29922 PMVSMX=4D0*VINT(154)**2
29923 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29924 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
29925 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
29926 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
29927 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
29928 PMVIRT=PMAS(PYCOMP(113),1)
29929 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29930 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
29931 PMVIRT=PMAS(PYCOMP(113),1)
29932 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
29933 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
29934 PMVSMN=4D0*PARP(15)**2
29935 PMVSMX=4D0*VINT(154)**2
29936 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
29937 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
29938 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
29939 ENDIF
29940 BEAMAS=PYMASS(11)
29941 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
29942 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
29943 & (1D0-2D0*BEAMAS**2/Q2GA))
29944 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
29945 ENDIF
29946 ELSE
29947 VINT(314+ISDE)=1D0
29948 ENDIF
29949 COMFAC=COMFAC*VINT(314+ISDE)
29950 170 CONTINUE
29951
29952C...Evaluate cross sections - done in separate routines by kind
29953C...of physics, to keep PYSIGH of sensible size.
29954 IF(MAP.EQ.1) THEN
29955C...Standard QCD (including photons).
29956 CALL PYSGQC(NCHN,SIGS)
29957 ELSEIF(MAP.EQ.2) THEN
29958C...Heavy flavours.
29959 CALL PYSGHF(NCHN,SIGS)
29960 ELSEIF(MAP.EQ.3) THEN
29961C...W/Z.
29962 CALL PYSGWZ(NCHN,SIGS)
29963 ELSEIF(MAP.EQ.4) THEN
29964C...Higgs (2 doublets; including longitudinal W/Z scattering).
29965 CALL PYSGHG(NCHN,SIGS)
29966 ELSEIF(MAP.EQ.5) THEN
29967C...SUSY.
29968 CALL PYSGSU(NCHN,SIGS)
29969 ELSEIF(MAP.EQ.6) THEN
29970C...Technicolor.
29971 CALL PYSGTC(NCHN,SIGS)
29972 ELSEIF(MAP.EQ.7) THEN
29973C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29974 CALL PYSGEX(NCHN,SIGS)
29975 ELSEIF(MAP.EQ.8) THEN
29976C... Universal Extra Dimensions
29977 CALL PYXUED(NCHN,SIGS)
29978 ENDIF
29979
29980C...Multiply with parton distributions
29981 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
29982 DO 180 ICHN=1,NCHN
29983 IF(MINT(45).GE.2) THEN
29984 KFL1=ISIG(ICHN,1)
29985 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
29986 ENDIF
29987 IF(MINT(46).GE.2) THEN
29988 KFL2=ISIG(ICHN,2)
29989 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
29990 ENDIF
29991 SIGS=SIGS+SIGH(ICHN)
29992 180 CONTINUE
29993 ENDIF
29994
29995 RETURN
29996 END
29997
29998C*********************************************************************
29999
30000C...PYSGQC
30001C...Subprocess cross sections for QCD processes,
30002C...including photons.
30003C...Auxiliary to PYSIGH.
30004
30005 SUBROUTINE PYSGQC(NCHN,SIGS)
30006
30007C...Double precision and integer declarations
30008 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30009 IMPLICIT INTEGER(I-N)
30010 INTEGER PYK,PYCHGE,PYCOMP
30011C...Parameter statement to help give large particle numbers.
30012 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30013 &KEXCIT=4000000,KDIMEN=5000000)
30014C...Commonblocks
30015 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30016 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30017 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30018 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30019 COMMON/PYINT1/MINT(400),VINT(400)
30020 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30021 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30022 COMMON/PYINT4/MWID(500),WIDS(500,5)
30023 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30024 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30025 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30026 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30027 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30028 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30029 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30030C...Local arrays
30031 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30032
30033C...Differential cross section expressions.
30034
30035 IF(ISUB.LE.20) THEN
30036 IF(ISUB.EQ.10) THEN
30037C...f + f' -> f + f' (gamma/Z/W exchange)
30038 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30039 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30040 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30041 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30042 DO 110 I=MMIN1,MMAX1
30043 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30044 IA=IABS(I)
30045 DO 100 J=MMIN2,MMAX2
30046 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30047 JA=IABS(J)
30048C...Electroweak couplings
30049 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30050 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30051 VI=AI-4D0*EI*XWV
30052 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30053 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30054 VJ=AJ-4D0*EJ*XWV
30055 EPSIJ=ISIGN(1,I*J)
30056C...gamma/Z exchange, only gamma exchange, or only Z exchange
30057 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30058 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30059 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30060 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30061 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30062 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30063 ELSEIF(MSTP(21).EQ.2) THEN
30064 FACNCF=FACGGF*EI**2*EJ**2
30065 ELSE
30066 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30067 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30068 ENDIF
30069C...Extrafactor 2 for only one incoming neutrino spin state.
30070 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30071 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30072 NCHN=NCHN+1
30073 ISIG(NCHN,1)=I
30074 ISIG(NCHN,2)=J
30075 ISIG(NCHN,3)=1
30076 SIGH(NCHN)=FACNCF
30077 ENDIF
30078C...W exchange
30079 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30080 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30081 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30082 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30083 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30084 NCHN=NCHN+1
30085 ISIG(NCHN,1)=I
30086 ISIG(NCHN,2)=J
30087 ISIG(NCHN,3)=2
30088 SIGH(NCHN)=FACCCF
30089 ENDIF
30090 100 CONTINUE
30091 110 CONTINUE
30092
30093 ELSEIF(ISUB.EQ.11) THEN
30094C...f + f' -> f + f' (g exchange)
30095 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30096 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30097 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30098 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30099 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30100 DO 130 I=MMIN1,MMAX1
30101 IA=IABS(I)
30102 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30103 DO 120 J=MMIN2,MMAX2
30104 JA=IABS(J)
30105 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30106 NCHN=NCHN+1
30107 ISIG(NCHN,1)=I
30108 ISIG(NCHN,2)=J
30109 ISIG(NCHN,3)=1
30110 SIGH(NCHN)=FACQQ1
30111 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30112 IF(I.EQ.J) THEN
30113 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30114 NCHN=NCHN+1
30115 ISIG(NCHN,1)=I
30116 ISIG(NCHN,2)=J
30117 ISIG(NCHN,3)=2
30118 SIGH(NCHN)=0.5D0*FACQQ2
30119 ENDIF
30120 120 CONTINUE
30121 130 CONTINUE
30122
30123 ELSEIF(ISUB.EQ.12) THEN
30124C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30125 CALL PYWIDT(21,SH,WDTP,WDTE)
30126 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30127 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30128 DO 140 I=MMINA,MMAXA
30129 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30130 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30131 NCHN=NCHN+1
30132 ISIG(NCHN,1)=I
30133 ISIG(NCHN,2)=-I
30134 ISIG(NCHN,3)=1
30135 SIGH(NCHN)=FACQQB
30136 140 CONTINUE
30137
30138 ELSEIF(ISUB.EQ.13) THEN
30139C...f + fbar -> g + g (q + qbar -> g + g only)
30140 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30141 & UH2/SH2)
30142 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30143 & TH2/SH2)
30144 DO 150 I=MMINA,MMAXA
30145 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30146 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30147 NCHN=NCHN+1
30148 ISIG(NCHN,1)=I
30149 ISIG(NCHN,2)=-I
30150 ISIG(NCHN,3)=1
30151 SIGH(NCHN)=0.5D0*FACGG1
30152 NCHN=NCHN+1
30153 ISIG(NCHN,1)=I
30154 ISIG(NCHN,2)=-I
30155 ISIG(NCHN,3)=2
30156 SIGH(NCHN)=0.5D0*FACGG2
30157 150 CONTINUE
30158
30159 ELSEIF(ISUB.EQ.14) THEN
30160C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30161 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30162 DO 160 I=MMINA,MMAXA
30163 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30164 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30165 EI=KCHG(IABS(I),1)/3D0
30166 NCHN=NCHN+1
30167 ISIG(NCHN,1)=I
30168 ISIG(NCHN,2)=-I
30169 ISIG(NCHN,3)=1
30170 SIGH(NCHN)=FACGG*EI**2
30171 160 CONTINUE
30172
30173 ELSEIF(ISUB.EQ.18) THEN
30174C...f + fbar -> gamma + gamma
30175 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30176 DO 170 I=MMINA,MMAXA
30177 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30178 EI=KCHG(IABS(I),1)/3D0
30179 FCOI=1D0
30180 IF(IABS(I).LE.10) FCOI=FACA/3D0
30181 NCHN=NCHN+1
30182 ISIG(NCHN,1)=I
30183 ISIG(NCHN,2)=-I
30184 ISIG(NCHN,3)=1
30185 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30186 170 CONTINUE
30187 ENDIF
30188
30189 ELSEIF(ISUB.LE.40) THEN
30190 IF(ISUB.EQ.28) THEN
30191C...f + g -> f + g (q + g -> q + g only)
30192 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30193 & UH/SH)*FACA
30194 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30195 & SH/UH)
30196 DO 190 I=MMINA,MMAXA
30197 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30198 DO 180 ISDE=1,2
30199 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30200 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30201 NCHN=NCHN+1
30202 ISIG(NCHN,ISDE)=I
30203 ISIG(NCHN,3-ISDE)=21
30204 ISIG(NCHN,3)=1
30205 SIGH(NCHN)=FACQG1
30206 NCHN=NCHN+1
30207 ISIG(NCHN,ISDE)=I
30208 ISIG(NCHN,3-ISDE)=21
30209 ISIG(NCHN,3)=2
30210 SIGH(NCHN)=FACQG2
30211 180 CONTINUE
30212 190 CONTINUE
30213
30214 ELSEIF(ISUB.EQ.29) THEN
30215C...f + g -> f + gamma (q + g -> q + gamma only)
30216 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30217 DO 210 I=MMINA,MMAXA
30218 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30219 EI=KCHG(IABS(I),1)/3D0
30220 FACGQ=FGQ*EI**2
30221 DO 200 ISDE=1,2
30222 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30223 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30224 NCHN=NCHN+1
30225 ISIG(NCHN,ISDE)=I
30226 ISIG(NCHN,3-ISDE)=21
30227 ISIG(NCHN,3)=1
30228 SIGH(NCHN)=FACGQ
30229 200 CONTINUE
30230 210 CONTINUE
30231
30232 ELSEIF(ISUB.EQ.33) THEN
30233C...f + gamma -> f + g (q + gamma -> q + g only)
30234 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30235 DO 230 I=MMINA,MMAXA
30236 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30237 EI=KCHG(IABS(I),1)/3D0
30238 FACGQ=FGQ*EI**2
30239 DO 220 ISDE=1,2
30240 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30241 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30242 NCHN=NCHN+1
30243 ISIG(NCHN,ISDE)=I
30244 ISIG(NCHN,3-ISDE)=22
30245 ISIG(NCHN,3)=1
30246 SIGH(NCHN)=FACGQ
30247 220 CONTINUE
30248 230 CONTINUE
30249
30250 ELSEIF(ISUB.EQ.34) THEN
30251C...f + gamma -> f + gamma
30252 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30253 DO 250 I=MMINA,MMAXA
30254 IF(I.EQ.0) GOTO 250
30255 EI=KCHG(IABS(I),1)/3D0
30256 FACGQ=FGQ*EI**4
30257 DO 240 ISDE=1,2
30258 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30259 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30260 NCHN=NCHN+1
30261 ISIG(NCHN,ISDE)=I
30262 ISIG(NCHN,3-ISDE)=22
30263 ISIG(NCHN,3)=1
30264 SIGH(NCHN)=FACGQ
30265 240 CONTINUE
30266 250 CONTINUE
30267 ENDIF
30268
30269 ELSEIF(ISUB.LE.80) THEN
30270 IF(ISUB.EQ.53) THEN
30271C...g + g -> f + fbar (g + g -> q + qbar only)
30272 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30273 IDC0=MDCY(21,2)-1
30274C...Begin by d, u, s flavours.
30275 FLAVWT=0D0
30276 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30277 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30278 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30279 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30280 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30281 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30282 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30283 & UH2/SH2)*FLAVWT*FACA
30284 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30285 & TH2/SH2)*FLAVWT*FACA
30286 NCHN=NCHN+1
30287 ISIG(NCHN,1)=21
30288 ISIG(NCHN,2)=21
30289 ISIG(NCHN,3)=1
30290 SIGH(NCHN)=FACQQ1
30291 NCHN=NCHN+1
30292 ISIG(NCHN,1)=21
30293 ISIG(NCHN,2)=21
30294 ISIG(NCHN,3)=2
30295 SIGH(NCHN)=FACQQ2
30296C...Next c and b flavours: modified that and uhat for fixed
30297C...cos(theta-hat).
30298 DO 260 IFL=4,5
30299 SQMAVG=PMAS(IFL,1)**2
30300 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30301 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30302 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30303 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30304 THUHQ=THQ*UHQ-SQMAVG*SH
30305 IF(MSTP(34).EQ.0) THEN
30306 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30307 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30308 ELSE
30309 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30310 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30311 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30312 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30313 ENDIF
30314 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30315 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30316 NCHN=NCHN+1
30317 ISIG(NCHN,1)=21
30318 ISIG(NCHN,2)=21
30319 ISIG(NCHN,3)=1+2*(IFL-3)
30320 SIGH(NCHN)=FACQQ1
30321 NCHN=NCHN+1
30322 ISIG(NCHN,1)=21
30323 ISIG(NCHN,2)=21
30324 ISIG(NCHN,3)=2+2*(IFL-3)
30325 SIGH(NCHN)=FACQQ2
30326 ENDIF
30327 260 CONTINUE
30328 270 CONTINUE
30329
30330 ELSEIF(ISUB.EQ.54) THEN
30331C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30332 CALL PYWIDT(21,SH,WDTP,WDTE)
30333 WDTESU=0D0
30334 DO 280 I=1,MIN(8,MDCY(21,3))
30335 EF=KCHG(I,1)/3D0
30336 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30337 & WDTE(I,4))
30338 280 CONTINUE
30339 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
30340 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30341 NCHN=NCHN+1
30342 ISIG(NCHN,1)=21
30343 ISIG(NCHN,2)=22
30344 ISIG(NCHN,3)=1
30345 SIGH(NCHN)=FACQQ
30346 ENDIF
30347 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30348 NCHN=NCHN+1
30349 ISIG(NCHN,1)=22
30350 ISIG(NCHN,2)=21
30351 ISIG(NCHN,3)=1
30352 SIGH(NCHN)=FACQQ
30353 ENDIF
30354
30355 ELSEIF(ISUB.EQ.58) THEN
30356C...gamma + gamma -> f + fbar
30357 CALL PYWIDT(22,SH,WDTP,WDTE)
30358 WDTESU=0D0
30359 DO 290 I=1,MIN(12,MDCY(22,3))
30360 IF(I.LE.8) EF= KCHG(I,1)/3D0
30361 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30362 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30363 & WDTE(I,4))
30364 290 CONTINUE
30365 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
30366 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30367 NCHN=NCHN+1
30368 ISIG(NCHN,1)=22
30369 ISIG(NCHN,2)=22
30370 ISIG(NCHN,3)=1
30371 SIGH(NCHN)=FACFF
30372 ENDIF
30373
30374 ELSEIF(ISUB.EQ.68) THEN
30375C...g + g -> g + g
30376 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
30377 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
30378 & TH2/SH2)*FACA
30379 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
30380 & SH2/UH2)*FACA
30381 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
30382 & UH2/TH2)
30383 NCHN=NCHN+1
30384 ISIG(NCHN,1)=21
30385 ISIG(NCHN,2)=21
30386 ISIG(NCHN,3)=1
30387 SIGH(NCHN)=0.5D0*FACGG1
30388 NCHN=NCHN+1
30389 ISIG(NCHN,1)=21
30390 ISIG(NCHN,2)=21
30391 ISIG(NCHN,3)=2
30392 SIGH(NCHN)=0.5D0*FACGG2
30393 NCHN=NCHN+1
30394 ISIG(NCHN,1)=21
30395 ISIG(NCHN,2)=21
30396 ISIG(NCHN,3)=3
30397 SIGH(NCHN)=0.5D0*FACGG3
30398 300 CONTINUE
30399
30400 ELSEIF(ISUB.EQ.80) THEN
30401C...q + gamma -> q' + pi+/-
30402 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
30403 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
30404 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
30405 DELSH=UH*SQRT(ASSH*Q2FPSH)
30406 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
30407 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
30408 DELUH=SH*SQRT(ASUH*Q2FPUH)
30409 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
30410 IF(I.EQ.0) GOTO 320
30411 EI=KCHG(IABS(I),1)/3D0
30412 EJ=SIGN(1D0-ABS(EI),EI)
30413 DO 310 ISDE=1,2
30414 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
30415 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
30416 NCHN=NCHN+1
30417 ISIG(NCHN,ISDE)=I
30418 ISIG(NCHN,3-ISDE)=22
30419 ISIG(NCHN,3)=1
30420 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
30421 310 CONTINUE
30422 320 CONTINUE
30423 ENDIF
30424
30425 ELSEIF(ISUB.LE.100) THEN
30426 IF(ISUB.EQ.91) THEN
30427C...Elastic scattering
30428 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
30429
30430 ELSEIF(ISUB.EQ.92) THEN
30431C...Single diffractive scattering (first side, i.e. XB)
30432 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
30433
30434 ELSEIF(ISUB.EQ.93) THEN
30435C...Single diffractive scattering (second side, i.e. AX)
30436 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
30437
30438 ELSEIF(ISUB.EQ.94) THEN
30439C...Double diffractive scattering
30440 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
30441
30442 ELSEIF(ISUB.EQ.95) THEN
30443C...Low-pT scattering
30444 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
30445
30446 ELSEIF(ISUB.EQ.96) THEN
30447C...Multiple interactions: sum of QCD processes
30448 CALL PYWIDT(21,SH,WDTP,WDTE)
30449
30450C...q + q' -> q + q'
30451 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30452 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30453 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30454 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
30455 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
30456 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
30457 DO 340 I=-5,5
30458 IF(I.EQ.0) GOTO 340
30459 DO 330 J=-5,5
30460 IF(J.EQ.0) GOTO 330
30461 NCHN=NCHN+1
30462 ISIG(NCHN,1)=I
30463 ISIG(NCHN,2)=J
30464 ISIG(NCHN,3)=111
30465 SIGH(NCHN)=FACQQ1
30466 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30467 IF(I.EQ.J) THEN
30468 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
30469 NCHN=NCHN+1
30470 ISIG(NCHN,1)=I
30471 ISIG(NCHN,2)=J
30472 ISIG(NCHN,3)=112
30473 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
30474 ENDIF
30475 330 CONTINUE
30476 340 CONTINUE
30477
30478C...q + qbar -> q' + qbar' or g + g
30479 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30480 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
30481 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30482 & UH2/SH2)
30483 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30484 & TH2/SH2)
30485 DO 350 I=-5,5
30486 IF(I.EQ.0) GOTO 350
30487 NCHN=NCHN+1
30488 ISIG(NCHN,1)=I
30489 ISIG(NCHN,2)=-I
30490 ISIG(NCHN,3)=121
30491 SIGH(NCHN)=FACQQB
30492 NCHN=NCHN+1
30493 ISIG(NCHN,1)=I
30494 ISIG(NCHN,2)=-I
30495 ISIG(NCHN,3)=131
30496 SIGH(NCHN)=0.5D0*FACGG1
30497 NCHN=NCHN+1
30498 ISIG(NCHN,1)=I
30499 ISIG(NCHN,2)=-I
30500 ISIG(NCHN,3)=132
30501 SIGH(NCHN)=0.5D0*FACGG2
30502 350 CONTINUE
30503
30504C...q + g -> q + g
30505 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30506 & UH/SH)*FACA
30507 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30508 & SH/UH)
30509 DO 370 I=-5,5
30510 IF(I.EQ.0) GOTO 370
30511 DO 360 ISDE=1,2
30512 NCHN=NCHN+1
30513 ISIG(NCHN,ISDE)=I
30514 ISIG(NCHN,3-ISDE)=21
30515 ISIG(NCHN,3)=281
30516 SIGH(NCHN)=FACQG1
30517 NCHN=NCHN+1
30518 ISIG(NCHN,ISDE)=I
30519 ISIG(NCHN,3-ISDE)=21
30520 ISIG(NCHN,3)=282
30521 SIGH(NCHN)=FACQG2
30522 360 CONTINUE
30523 370 CONTINUE
30524
30525C...g + g -> q + qbar (only d, u, s)
30526 IDC0=MDCY(21,2)-1
30527 FLAVWT=0D0
30528 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30529 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30530 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30531 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30532 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30533 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30534 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30535 & UH2/SH2)*FLAVWT*FACA
30536 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30537 & TH2/SH2)*FLAVWT*FACA
30538 NCHN=NCHN+1
30539 ISIG(NCHN,1)=21
30540 ISIG(NCHN,2)=21
30541 ISIG(NCHN,3)=531
30542 SIGH(NCHN)=FACQQ1
30543 NCHN=NCHN+1
30544 ISIG(NCHN,1)=21
30545 ISIG(NCHN,2)=21
30546 ISIG(NCHN,3)=532
30547 SIGH(NCHN)=FACQQ2
30548
30549C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
30550C...cos(theta-hat)
30551 DO 380 IFL=4,5
30552 SQMAVG=PMAS(IFL,1)**2
30553 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30554 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30555 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30556 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30557 THUHQ=THQ*UHQ-SQMAVG*SH
30558 IF(MSTP(34).EQ.0) THEN
30559 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30560 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30561 ELSE
30562 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30563 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30564 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30565 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30566 ENDIF
30567 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30568 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30569 NCHN=NCHN+1
30570 ISIG(NCHN,1)=21
30571 ISIG(NCHN,2)=21
30572 ISIG(NCHN,3)=531+2*(IFL-3)
30573 SIGH(NCHN)=FACQQ1
30574 NCHN=NCHN+1
30575 ISIG(NCHN,1)=21
30576 ISIG(NCHN,2)=21
30577 ISIG(NCHN,3)=532+2*(IFL-3)
30578 SIGH(NCHN)=FACQQ2
30579 ENDIF
30580 380 CONTINUE
30581
30582C...g + g -> g + g
30583 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
30584 & 2D0*TH/SH+TH2/SH2)*FACA
30585 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
30586 & 2D0*SH/UH+SH2/UH2)*FACA
30587 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
30588 & 2D0*UH/TH+UH2/TH2)
30589 NCHN=NCHN+1
30590 ISIG(NCHN,1)=21
30591 ISIG(NCHN,2)=21
30592 ISIG(NCHN,3)=681
30593 SIGH(NCHN)=0.5D0*FACGG1
30594 NCHN=NCHN+1
30595 ISIG(NCHN,1)=21
30596 ISIG(NCHN,2)=21
30597 ISIG(NCHN,3)=682
30598 SIGH(NCHN)=0.5D0*FACGG2
30599 NCHN=NCHN+1
30600 ISIG(NCHN,1)=21
30601 ISIG(NCHN,2)=21
30602 ISIG(NCHN,3)=683
30603 SIGH(NCHN)=0.5D0*FACGG3
30604
30605 ELSEIF(ISUB.EQ.99) THEN
30606C...f + gamma* -> f.
30607 IF(MINT(107).EQ.4) THEN
30608 Q2GA=VINT(307)
30609 P2GA=VINT(308)
30610 ISDE=2
30611 ELSE
30612 Q2GA=VINT(308)
30613 P2GA=VINT(307)
30614 ISDE=1
30615 ENDIF
30616 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
30617 PM2RHO=PMAS(PYCOMP(113),1)**2
30618 IF(MSTP(19).EQ.0) THEN
30619 COMFAC=COMFAC/Q2GA
30620 ELSEIF(MSTP(19).EQ.1) THEN
30621 COMFAC=COMFAC/(Q2GA+PM2RHO)
30622 ELSEIF(MSTP(19).EQ.2) THEN
30623 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30624 ELSE
30625 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
30626 W2GA=VINT(2)
30627 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
30628 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
30629 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
30630 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
30631 ELSE
30632 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
30633 & Q2GA**0.57D0)
30634 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
30635 ENDIF
30636 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
30637 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
30638 ENDIF
30639 DO 390 I=MMINA,MMAXA
30640 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
30641 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
30642 EI=KCHG(IABS(I),1)/3D0
30643 NCHN=NCHN+1
30644 ISIG(NCHN,ISDE)=I
30645 ISIG(NCHN,3-ISDE)=22
30646 ISIG(NCHN,3)=1
30647 SIGH(NCHN)=COMFAC*EI**2
30648 390 CONTINUE
30649 ENDIF
30650
30651 ELSE
30652 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
30653C...g + g -> gamma + gamma or g + g -> g + gamma
30654 A0STUR=0D0
30655 A0STUI=0D0
30656 A0TSUR=0D0
30657 A0TSUI=0D0
30658 A0UTSR=0D0
30659 A0UTSI=0D0
30660 A1STUR=0D0
30661 A1STUI=0D0
30662 A2STUR=0D0
30663 A2STUI=0D0
30664 ALST=LOG(-SH/TH)
30665 ALSU=LOG(-SH/UH)
30666 ALTU=LOG(TH/UH)
30667 IMAX=2*MSTP(1)
30668 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
30669 DO 400 I=1,IMAX
30670 EI=KCHG(IABS(I),1)/3D0
30671 EIWT=EI**2
30672 IF(ISUB.EQ.115) EIWT=EI
30673 SQMQ=PMAS(I,1)**2
30674 EPSS=4D0*SQMQ/SH
30675 EPST=4D0*SQMQ/TH
30676 EPSU=4D0*SQMQ/UH
30677 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
30678 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
30679 & PARU(1)**2)
30680 B0STUI=0D0
30681 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
30682 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
30683 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
30684 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
30685 B1STUR=-1D0
30686 B1STUI=0D0
30687 B2STUR=-1D0
30688 B2STUI=0D0
30689 ELSE
30690 CALL PYWAUX(1,EPSS,W1SR,W1SI)
30691 CALL PYWAUX(1,EPST,W1TR,W1TI)
30692 CALL PYWAUX(1,EPSU,W1UR,W1UI)
30693 CALL PYWAUX(2,EPSS,W2SR,W2SI)
30694 CALL PYWAUX(2,EPST,W2TR,W2TI)
30695 CALL PYWAUX(2,EPSU,W2UR,W2UI)
30696 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
30697 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
30698 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
30699 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
30700 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
30701 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
30702 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
30703 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
30704 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
30705 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
30706 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30707 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30708 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
30709 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
30710 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
30711 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
30712 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
30713 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30714 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
30715 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
30716 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
30717 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
30718 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30719 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
30720 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
30721 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
30722 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
30723 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
30724 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
30725 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
30726 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
30727 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
30728 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
30729 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
30730 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30731 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
30732 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
30733 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
30734 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
30735 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
30736 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
30737 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
30738 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
30739 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
30740 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
30741 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
30742 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
30743 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
30744 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
30745 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
30746 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
30747 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
30748 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
30749 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
30750 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
30751 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
30752 ENDIF
30753 A0STUR=A0STUR+EIWT*B0STUR
30754 A0STUI=A0STUI+EIWT*B0STUI
30755 A0TSUR=A0TSUR+EIWT*B0TSUR
30756 A0TSUI=A0TSUI+EIWT*B0TSUI
30757 A0UTSR=A0UTSR+EIWT*B0UTSR
30758 A0UTSI=A0UTSI+EIWT*B0UTSI
30759 A1STUR=A1STUR+EIWT*B1STUR
30760 A1STUI=A1STUI+EIWT*B1STUI
30761 A2STUR=A2STUR+EIWT*B2STUR
30762 A2STUI=A2STUI+EIWT*B2STUI
30763 400 CONTINUE
30764 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
30765 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
30766 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
30767 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
30768 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
30769 NCHN=NCHN+1
30770 ISIG(NCHN,1)=21
30771 ISIG(NCHN,2)=21
30772 ISIG(NCHN,3)=1
30773 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
30774 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
30775 410 CONTINUE
30776
30777 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
30778C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
30779 PH=0D0
30780 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30781 & PH=VINT(3)**2
30782 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30783 & PH=VINT(4)**2
30784 IF(ISUB.EQ.131) THEN
30785 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
30786 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30787 ELSE
30788 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30789 ENDIF
30790 DO 430 I=MMINA,MMAXA
30791 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
30792 EI=KCHG(IABS(I),1)/3D0
30793 FACGQ=FGQ*EI**2
30794 DO 420 ISDE=1,2
30795 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
30796 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
30797 NCHN=NCHN+1
30798 ISIG(NCHN,ISDE)=I
30799 ISIG(NCHN,3-ISDE)=22
30800 ISIG(NCHN,3)=1
30801 SIGH(NCHN)=FACGQ
30802 420 CONTINUE
30803 430 CONTINUE
30804
30805 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
30806C...f + gamma*_(T,L) -> f + gamma
30807 PH=0D0
30808 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30809 & PH=VINT(3)**2
30810 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30811 & PH=VINT(4)**2
30812 IF(ISUB.EQ.133) THEN
30813 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
30814 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
30815 ELSE
30816 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
30817 ENDIF
30818 DO 450 I=MMINA,MMAXA
30819 IF(I.EQ.0) GOTO 450
30820 EI=KCHG(IABS(I),1)/3D0
30821 FACGQ=FGQ*EI**4
30822 DO 440 ISDE=1,2
30823 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
30824 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
30825 NCHN=NCHN+1
30826 ISIG(NCHN,ISDE)=I
30827 ISIG(NCHN,3-ISDE)=22
30828 ISIG(NCHN,3)=1
30829 SIGH(NCHN)=FACGQ
30830 440 CONTINUE
30831 450 CONTINUE
30832
30833 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
30834C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
30835 PH=0D0
30836 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
30837 & PH=VINT(3)**2
30838 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
30839 & PH=VINT(4)**2
30840 CALL PYWIDT(21,SH,WDTP,WDTE)
30841 WDTESU=0D0
30842 DO 460 I=1,MIN(8,MDCY(21,3))
30843 EF=KCHG(I,1)/3D0
30844 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30845 & WDTE(I,4))
30846 460 CONTINUE
30847 IF(ISUB.EQ.135) THEN
30848 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
30849 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
30850 ELSE
30851 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
30852 ENDIF
30853 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
30854 NCHN=NCHN+1
30855 ISIG(NCHN,1)=21
30856 ISIG(NCHN,2)=22
30857 ISIG(NCHN,3)=1
30858 SIGH(NCHN)=FACQQ
30859 ENDIF
30860 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
30861 NCHN=NCHN+1
30862 ISIG(NCHN,1)=22
30863 ISIG(NCHN,2)=21
30864 ISIG(NCHN,3)=1
30865 SIGH(NCHN)=FACQQ
30866 ENDIF
30867
30868 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
30869C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
30870 PH1=0D0
30871 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
30872 PH2=0D0
30873 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
30874 CALL PYWIDT(22,SH,WDTP,WDTE)
30875 WDTESU=0D0
30876 DO 470 I=1,MIN(12,MDCY(22,3))
30877 IF(I.LE.8) EF= KCHG(I,1)/3D0
30878 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
30879 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
30880 & WDTE(I,4))
30881 470 CONTINUE
30882 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
30883 IF(ISUB.EQ.137) THEN
30884 FPARAM=-SH*(TH+UH)/DLAMB2
30885 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
30886 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
30887 & 2D0*PH1*PH2*FPARAM**2)
30888 ELSEIF(ISUB.EQ.138) THEN
30889 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30890 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
30891 & 2D0*PH1**2*(TH-UH)**2)
30892 ELSEIF(ISUB.EQ.139) THEN
30893 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
30894 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
30895 & 2D0*PH2**2*(TH-UH)**2)
30896 ELSE
30897 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
30898 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
30899 ENDIF
30900 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
30901 NCHN=NCHN+1
30902 ISIG(NCHN,1)=22
30903 ISIG(NCHN,2)=22
30904 ISIG(NCHN,3)=1
30905 SIGH(NCHN)=FACFF
30906 ENDIF
30907
30908 ENDIF
30909 ENDIF
30910
30911 RETURN
30912 END
30913
30914C*********************************************************************
30915
30916C...PYSGHF
30917C...Subprocess cross sections for heavy flavour production,
30918C...open and closed.
30919C...Auxiliary to PYSIGH.
30920
30921 SUBROUTINE PYSGHF(NCHN,SIGS)
30922
30923C...Double precision and integer declarations
30924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30925 IMPLICIT INTEGER(I-N)
30926 INTEGER PYK,PYCHGE,PYCOMP
30927C...Parameter statement to help give large particle numbers.
30928 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30929 &KEXCIT=4000000,KDIMEN=5000000)
30930C...Commonblocks
30931 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30932 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30933 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30934 COMMON/PYINT1/MINT(400),VINT(400)
30935 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30936 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30937 COMMON/PYINT4/MWID(500),WIDS(500,5)
30938 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30939 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30940 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30941 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30942 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
30943 &/PYINT4/,/PYSGCM/
30944C...Local arrays
30945 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30946
30947C...Determine where are charmonium/bottomonium wave function parameters.
30948 IONIUM=140
30949 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
30950
30951C...Convert bottomonium process into equivalent charmonium ones.
30952 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
30953
30954C...Differential cross section expressions.
30955
30956 IF(ISUB.LE.100) THEN
30957 IF(ISUB.EQ.81) THEN
30958C...q + qbar -> Q + Qbar
30959 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30960 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30961 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30962 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
30963 & 2D0*SQMAVG/SH)
30964 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
30965 WID2=1D0
30966 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
30967 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
30968 FACQQB=FACQQB*WID2
30969 DO 100 I=MMINA,MMAXA
30970 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30971 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
30972 NCHN=NCHN+1
30973 ISIG(NCHN,1)=I
30974 ISIG(NCHN,2)=-I
30975 ISIG(NCHN,3)=1
30976 SIGH(NCHN)=FACQQB
30977 100 CONTINUE
30978
30979 ELSEIF(ISUB.EQ.82) THEN
30980C...g + g -> Q + Qbar
30981 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
30982 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30983 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30984 THUHQ=THQ*UHQ-SQMAVG*SH
30985 IF(MSTP(34).EQ.0) THEN
30986 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30987 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30988 ELSE
30989 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30990 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30991 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30992 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30993 ENDIF
30994 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
30995 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
30996 IF(MSTP(35).GE.1) THEN
30997 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
30998 FACQQ1=FACQQ1*FATRE
30999 FACQQ2=FACQQ2*FATRE
31000 ENDIF
31001 WID2=1D0
31002 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31003 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31004 FACQQ1=FACQQ1*WID2
31005 FACQQ2=FACQQ2*WID2
31006 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31007 NCHN=NCHN+1
31008 ISIG(NCHN,1)=21
31009 ISIG(NCHN,2)=21
31010 ISIG(NCHN,3)=1
31011 SIGH(NCHN)=FACQQ1
31012 NCHN=NCHN+1
31013 ISIG(NCHN,1)=21
31014 ISIG(NCHN,2)=21
31015 ISIG(NCHN,3)=2
31016 SIGH(NCHN)=FACQQ2
31017 110 CONTINUE
31018
31019 ELSEIF(ISUB.EQ.83) THEN
31020C...f + q -> f' + Q
31021 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31022 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31023 DO 130 I=MMIN1,MMAX1
31024 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31025 DO 120 J=MMIN2,MMAX2
31026 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31027 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31028 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31029 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31030 & THEN
31031 NCHN=NCHN+1
31032 ISIG(NCHN,1)=I
31033 ISIG(NCHN,2)=J
31034 ISIG(NCHN,3)=1
31035 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31036 & (IABS(I)+1)/2)*VINT(180+J)
31037 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31038 & (MINT(55)+1)/2)*VINT(180+J)
31039 WID2=1D0
31040 IF(I.GT.0) THEN
31041 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31042 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31043 & WIDS(MINT(55),2)
31044 ELSE
31045 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31046 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31047 & WIDS(MINT(55),3)
31048 ENDIF
31049 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31050 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31051 ENDIF
31052 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31053 & THEN
31054 NCHN=NCHN+1
31055 ISIG(NCHN,1)=I
31056 ISIG(NCHN,2)=J
31057 ISIG(NCHN,3)=2
31058 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31059 & (IABS(J)+1)/2)*VINT(180+I)
31060 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31061 & (MINT(55)+1)/2)*VINT(180+I)
31062 WID2=1D0
31063 IF(J.GT.0) THEN
31064 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31065 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31066 & WIDS(MINT(55),2)
31067 ELSE
31068 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31069 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31070 & WIDS(MINT(55),3)
31071 ENDIF
31072 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31073 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31074 ENDIF
31075 120 CONTINUE
31076 130 CONTINUE
31077
31078 ELSEIF(ISUB.EQ.84) THEN
31079C...g + gamma -> Q + Qbar
31080 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31081 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31082 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31083 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31084 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31085 & (THQ*UHQ)
31086 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31087 WID2=1D0
31088 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31089 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31090 FACQQ=FACQQ*WID2
31091 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31092 NCHN=NCHN+1
31093 ISIG(NCHN,1)=21
31094 ISIG(NCHN,2)=22
31095 ISIG(NCHN,3)=1
31096 SIGH(NCHN)=FACQQ
31097 ENDIF
31098 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31099 NCHN=NCHN+1
31100 ISIG(NCHN,1)=22
31101 ISIG(NCHN,2)=21
31102 ISIG(NCHN,3)=1
31103 SIGH(NCHN)=FACQQ
31104 ENDIF
31105
31106 ELSEIF(ISUB.EQ.85) THEN
31107C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31108 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31109 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31110 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31111 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31112 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31113 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31114 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31115 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31116 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31117 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31118 WID2=1D0
31119 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31120 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31121 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31122 FACFF=FACFF*WID2
31123 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31124 NCHN=NCHN+1
31125 ISIG(NCHN,1)=22
31126 ISIG(NCHN,2)=22
31127 ISIG(NCHN,3)=1
31128 SIGH(NCHN)=FACFF
31129 ENDIF
31130
31131 ELSEIF(ISUB.EQ.86) THEN
31132C...g + g -> J/Psi + g
31133 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31134 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31135 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31136 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31137 NCHN=NCHN+1
31138 ISIG(NCHN,1)=21
31139 ISIG(NCHN,2)=21
31140 ISIG(NCHN,3)=1
31141 SIGH(NCHN)=FACQQG
31142 ENDIF
31143
31144 ELSEIF(ISUB.EQ.87) THEN
31145C...g + g -> chi_0c + g
31146 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31147 QGTW=(SH*TH*UH)/SH**3
31148 RGTW=SQM3/SH
31149 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31150 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31151 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31152 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31153 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31154 & (QGTW*(QGTW-RGTW*PGTW)**4)
31155 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31156 NCHN=NCHN+1
31157 ISIG(NCHN,1)=21
31158 ISIG(NCHN,2)=21
31159 ISIG(NCHN,3)=1
31160 SIGH(NCHN)=FACQQG
31161 ENDIF
31162
31163 ELSEIF(ISUB.EQ.88) THEN
31164C...g + g -> chi_1c + g
31165 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31166 QGTW=(SH*TH*UH)/SH**3
31167 RGTW=SQM3/SH
31168 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31169 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31170 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31171 & (QGTW-RGTW*PGTW)**4
31172 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31173 NCHN=NCHN+1
31174 ISIG(NCHN,1)=21
31175 ISIG(NCHN,2)=21
31176 ISIG(NCHN,3)=1
31177 SIGH(NCHN)=FACQQG
31178 ENDIF
31179
31180 ELSEIF(ISUB.EQ.89) THEN
31181C...g + g -> chi_2c + g
31182 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31183 QGTW=(SH*TH*UH)/SH**3
31184 RGTW=SQM3/SH
31185 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31186 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31187 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31188 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31189 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31190 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31191 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31192 NCHN=NCHN+1
31193 ISIG(NCHN,1)=21
31194 ISIG(NCHN,2)=21
31195 ISIG(NCHN,3)=1
31196 SIGH(NCHN)=FACQQG
31197 ENDIF
31198 ENDIF
31199
31200 ELSEIF(ISUB.LE.200) THEN
31201 IF(ISUB.EQ.104) THEN
31202C...g + g -> chi_c0.
31203 KC=PYCOMP(10441)
31204 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31205 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31206 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31207 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31208 NCHN=NCHN+1
31209 ISIG(NCHN,1)=21
31210 ISIG(NCHN,2)=21
31211 ISIG(NCHN,3)=1
31212 SIGH(NCHN)=FACBW
31213 ENDIF
31214
31215 ELSEIF(ISUB.EQ.105) THEN
31216C...g + g -> chi_c2.
31217 KC=PYCOMP(445)
31218 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31219 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31220 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31221 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31222 NCHN=NCHN+1
31223 ISIG(NCHN,1)=21
31224 ISIG(NCHN,2)=21
31225 ISIG(NCHN,3)=1
31226 SIGH(NCHN)=FACBW
31227 ENDIF
31228
31229 ELSEIF(ISUB.EQ.106) THEN
31230C...g + g -> J/Psi + gamma.
31231 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31232 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31233 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31234 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31235 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31236 NCHN=NCHN+1
31237 ISIG(NCHN,1)=21
31238 ISIG(NCHN,2)=21
31239 ISIG(NCHN,3)=1
31240 SIGH(NCHN)=FACQQG
31241 ENDIF
31242
31243 ELSEIF(ISUB.EQ.107) THEN
31244C...g + gamma -> J/Psi + g.
31245 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31246 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31247 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31248 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31249 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31250 NCHN=NCHN+1
31251 ISIG(NCHN,1)=21
31252 ISIG(NCHN,2)=22
31253 ISIG(NCHN,3)=1
31254 SIGH(NCHN)=FACQQG
31255 ENDIF
31256 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31257 NCHN=NCHN+1
31258 ISIG(NCHN,1)=22
31259 ISIG(NCHN,2)=21
31260 ISIG(NCHN,3)=1
31261 SIGH(NCHN)=FACQQG
31262 ENDIF
31263
31264 ELSEIF(ISUB.EQ.108) THEN
31265C...gamma + gamma -> J/Psi + gamma.
31266 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31267 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31268 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31269 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31270 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31271 NCHN=NCHN+1
31272 ISIG(NCHN,1)=22
31273 ISIG(NCHN,2)=22
31274 ISIG(NCHN,3)=1
31275 SIGH(NCHN)=FACQQG
31276 ENDIF
31277 ENDIF
31278
31279C...QUARKONIA+++
31280C...Additional code by Stefan Wolf
31281 ELSE
31282
31283C...Common code for quarkonium production.
31284 SHTH=SH+TH
31285 THUH=TH+UH
31286 UHSH=UH+SH
31287 SHTH2=SHTH**2
31288 THUH2=THUH**2
31289 UHSH2=UHSH**2
31290 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31291 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31292 SQMQQ=SQM3
31293 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31294 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31295 SQMQQ=SQM4
31296 ENDIF
31297 SQMQQR=SQRT(SQMQQ)
31298 IF(MSTP(145).EQ.1) THEN
31299 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31300 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31301 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31302 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31303 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31304 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31305 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31306 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31307 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31308 & ISUB.GE.437) THEN
31309 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31310 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31311 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31312 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31313 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31314 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31315 ENDIF
31316 AQ2=AQ**2
31317 BQ2=BQ**2
31318 SMQQ2=SQMQQ*VINT(2)
31319C...Polarisation frames
31320 IF(MSTP(146).EQ.1) THEN
31321C...Recoil frame
31322 POLH1=SQRT(AQ2-SMQQ2)
31323 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31324 AZ=-SQMQQR/POLH1
31325 BZ=0D0
31326 AX=AQ*BQ/(POLH1*POLH2)
31327 BX=-POLH1/POLH2
31328 ELSEIF(MSTP(146).EQ.2) THEN
31329C...Gottfried Jackson frame
31330 POLH1=AQ+BQ
31331 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31332 AZ=SQMQQR/POLH1
31333 BZ=AZ
31334 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
31335 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
31336 ELSEIF(MSTP(146).EQ.3) THEN
31337C...Target frame
31338 POLH1=AQ-BQ
31339 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31340 AZ=-SQMQQR/POLH1
31341 BZ=-AZ
31342 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
31343 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
31344 ELSEIF(MSTP(146).EQ.4) THEN
31345C...Collins Soper frame
31346 POLH1=AQ2-BQ2
31347 POLH2=SQRT(VINT(2)*POLH1)
31348 AZ=-BQ/POLH2
31349 BZ=AQ/POLH2
31350 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
31351 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
31352 ENDIF
31353C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
31354 EL1K10=AZ*ATILK1+BZ*BTILK1
31355 EL1K20=AZ*ATILK2+BZ*BTILK2
31356 EL2K10=EL1K10
31357 EL2K20=EL1K20
31358 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
31359 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
31360 EL2K11=EL1K11
31361 EL2K21=EL1K21
31362 ENDIF
31363
31364 IF(ISUB.EQ.421) THEN
31365C...g + g -> QQ~[3S11] + g
31366 IF(MSTP(145).EQ.0) THEN
31367* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31368* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
31369 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31370 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
31371* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
31372* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
31373 ELSE
31374 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
31375 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31376 BB=2D0*(SH2+TH2)
31377 CC=2D0*(SH2+UH2)
31378 DD=2D0*SH2
31379 IF(MSTP(147).EQ.0) THEN
31380 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31381 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31382 ELSEIF(MSTP(147).EQ.1) THEN
31383 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31384 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31385 ELSEIF(MSTP(147).EQ.3) THEN
31386 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31387 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31388 ELSEIF(MSTP(147).EQ.4) THEN
31389 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31390 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31391 ELSEIF(MSTP(147).EQ.5) THEN
31392 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31393 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31394 ELSEIF(MSTP(147).EQ.6) THEN
31395 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31396 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31397 ENDIF
31398 FACQQG=COMFAC*FF*FACQQG
31399 ENDIF
31400 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31401 NCHN=NCHN+1
31402 ISIG(NCHN,1)=21
31403 ISIG(NCHN,2)=21
31404 ISIG(NCHN,3)=1
31405 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
31406 ENDIF
31407
31408 ELSEIF(ISUB.EQ.422) THEN
31409C...g + g -> QQ~[3S18] + g
31410 IF(MSTP(145).EQ.0) THEN
31411 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
31412 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31413 & (SQMQQ*SQMQQR)*
31414 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
31415 ELSE
31416 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
31417 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
31418 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
31419 BB=2D0*(SH2+TH2)
31420 CC=2D0*(SH2+UH2)
31421 DD=2D0*SH2
31422 IF(MSTP(147).EQ.0) THEN
31423 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31424 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31425 ELSEIF(MSTP(147).EQ.1) THEN
31426 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31427 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31428 ELSEIF(MSTP(147).EQ.3) THEN
31429 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31430 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31431 ELSEIF(MSTP(147).EQ.4) THEN
31432 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31433 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31434 ELSEIF(MSTP(147).EQ.5) THEN
31435 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31436 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31437 ELSEIF(MSTP(147).EQ.6) THEN
31438 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31439 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31440 ENDIF
31441 FACQQG=COMFAC*FF*FACQQG
31442 ENDIF
31443C...Split total contribution into different colour flows just like
31444C...in g g -> g g (recalculate kinematics for massless partons).
31445 THP=-0.5D0*SH*(1D0-CTH)
31446 UHP=-0.5D0*SH*(1D0+CTH)
31447 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31448 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31449 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31450 FACGGS=FACGG1+FACGG2+FACGG3
31451 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31452 NCHN=NCHN+1
31453 ISIG(NCHN,1)=21
31454 ISIG(NCHN,2)=21
31455 ISIG(NCHN,3)=1
31456 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31457 NCHN=NCHN+1
31458 ISIG(NCHN,1)=21
31459 ISIG(NCHN,2)=21
31460 ISIG(NCHN,3)=2
31461 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31462 NCHN=NCHN+1
31463 ISIG(NCHN,1)=21
31464 ISIG(NCHN,2)=21
31465 ISIG(NCHN,3)=3
31466 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
31467 ENDIF
31468
31469 ELSEIF(ISUB.EQ.423) THEN
31470C...g + g -> QQ~[1S08] + g
31471 IF(MSTP(145).EQ.0) THEN
31472* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
31473* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
31474* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
31475* & (SHTH2*THUH2*UHSH2)
31476 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
31477 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31478 & TH2/(SHTH2*THUH2))*
31479 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31480 ELSE
31481 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
31482 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
31483 & TH2/(SHTH2*THUH2))*
31484 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
31485 IF(MSTP(147).EQ.0) THEN
31486 FACQQG=COMFAC*FA
31487 ELSEIF(MSTP(147).EQ.1) THEN
31488 FACQQG=COMFAC*2D0*FA
31489 ELSEIF(MSTP(147).EQ.3) THEN
31490 FACQQG=COMFAC*FA
31491 ELSEIF(MSTP(147).EQ.4) THEN
31492 FACQQG=COMFAC*FA
31493 ELSEIF(MSTP(147).EQ.5) THEN
31494 FACQQG=0D0
31495 ELSEIF(MSTP(147).EQ.6) THEN
31496 FACQQG=0D0
31497 ENDIF
31498 ENDIF
31499C...Split total contribution into different colour flows just like
31500C...in g g -> g g (recalculate kinematics for massless partons).
31501 THP=-0.5D0*SH*(1D0-CTH)
31502 UHP=-0.5D0*SH*(1D0+CTH)
31503 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31504 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31505 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31506 FACGGS=FACGG1+FACGG2+FACGG3
31507 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31508 NCHN=NCHN+1
31509 ISIG(NCHN,1)=21
31510 ISIG(NCHN,2)=21
31511 ISIG(NCHN,3)=1
31512 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31513 NCHN=NCHN+1
31514 ISIG(NCHN,1)=21
31515 ISIG(NCHN,2)=21
31516 ISIG(NCHN,3)=2
31517 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31518 NCHN=NCHN+1
31519 ISIG(NCHN,1)=21
31520 ISIG(NCHN,2)=21
31521 ISIG(NCHN,3)=3
31522 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
31523 ENDIF
31524
31525 ELSEIF(ISUB.EQ.424) THEN
31526C...g + g -> QQ~[3PJ8] + g
31527 POLY=SH2+SH*TH+TH2
31528 IF(MSTP(145).EQ.0) THEN
31529 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
31530 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
31531 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
31532 & +7D0*TH**6)
31533 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
31534 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
31535 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
31536 & +35D0*TH**8)
31537 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
31538 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
31539 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
31540 & +84D0*TH**8)
31541 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
31542 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
31543 & +451D0*SH*TH**5+126D0*TH**6)
31544 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
31545 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
31546 & +171D0*SH*TH**5+42D0*TH**6)
31547 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
31548 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
31549 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
31550 & +99D0*SH*TH**3+35D0*TH**4)
31551 & +7D0*SQMQQ**8*SHTH*POLY)/
31552 & (SH*TH*UH*SQMQQR*SQMQQ*
31553 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31554 ELSE
31555 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
31556 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
31557 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
31558 & -SQMQQ*SHTH2*POLY**2*
31559 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
31560 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
31561 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
31562 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
31563 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
31564 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
31565 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
31566 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
31567 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
31568 & +145D0*SH*TH**5+34D0*TH**6)
31569 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
31570 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
31571 & +44D0*TH**6)
31572 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
31573 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
31574 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
31575 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
31576 & +3D0*SQMQQ**8*SHTH*POLY)
31577 BB=4D0*SHTH2*POLY**3
31578 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
31579 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
31580 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
31581 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
31582 & +84D0*SH*TH**9+20D0*TH**10)
31583 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
31584 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
31585 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
31586 & +40D0*TH**8)
31587 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
31588 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
31589 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
31590 & +40D0*TH**8)
31591 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
31592 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
31593 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
31594 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
31595 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
31596 & +4D0*TH**6)
31597 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
31598 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
31599 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
31600 CC=4D0*TH2*POLY**3
31601 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
31602 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
31603 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
31604 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
31605 & +28D0*TH**9)
31606 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
31607 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
31608 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
31609 & +394D0*SH*TH**9+84D0*TH**10)
31610 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
31611 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
31612 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
31613 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
31614 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
31615 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
31616 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
31617 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
31618 & +266D0*SH*TH**6+84D0*TH**7)
31619 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
31620 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
31621 & +28D0*TH**6)
31622 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
31623 & +7D0*SH*TH**3+4*TH**4)
31624 & +SQMQQ**8*SH*(SH-TH)**2*TH
31625 DD=2D0*TH2*SHTH2*POLY**3
31626 & *(-SH2+2*SH*TH+2*TH2)
31627 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
31628 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
31629 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
31630 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
31631 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
31632 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
31633 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
31634 & -210D0*SH*TH**8-60D0*TH**9)
31635 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
31636 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
31637 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
31638 & -80D0*TH**8)
31639 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
31640 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
31641 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
31642 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
31643 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
31644 & -30D0*SH*TH**6-24D0*TH**7)
31645 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
31646 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
31647 & -4D0*TH**6)
31648 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
31649 IF(MSTP(147).EQ.0) THEN
31650 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31651 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31652 ELSEIF(MSTP(147).EQ.1) THEN
31653 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31654 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31655 ELSEIF(MSTP(147).EQ.3) THEN
31656 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31657 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31658 ELSEIF(MSTP(147).EQ.4) THEN
31659 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31660 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31661 ELSEIF(MSTP(147).EQ.5) THEN
31662 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31663 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31664 ELSEIF(MSTP(147).EQ.6) THEN
31665 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31666 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31667 ENDIF
31668 FACQQG=COMFAC*FF*FACQQG
31669 ENDIF
31670C...Split total contribution into different colour flows just like
31671C...in g g -> g g (recalculate kinematics for massless partons).
31672 THP=-0.5D0*SH*(1D0-CTH)
31673 UHP=-0.5D0*SH*(1D0+CTH)
31674 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
31675 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
31676 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
31677 FACGGS=FACGG1+FACGG2+FACGG3
31678 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31679 NCHN=NCHN+1
31680 ISIG(NCHN,1)=21
31681 ISIG(NCHN,2)=21
31682 ISIG(NCHN,3)=1
31683 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
31684 NCHN=NCHN+1
31685 ISIG(NCHN,1)=21
31686 ISIG(NCHN,2)=21
31687 ISIG(NCHN,3)=2
31688 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
31689 NCHN=NCHN+1
31690 ISIG(NCHN,1)=21
31691 ISIG(NCHN,2)=21
31692 ISIG(NCHN,3)=3
31693 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
31694 ENDIF
31695
31696 ELSEIF(ISUB.EQ.425) THEN
31697C...q + g -> q + QQ~[3S18]
31698 IF(MSTP(145).EQ.0) THEN
31699 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
31700 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
31701 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
31702 ELSE
31703 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
31704 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
31705 AA=SHTH2+THUH2
31706 BB=4D0
31707 CC=8D0
31708 DD=4D0
31709 IF(MSTP(147).EQ.0) THEN
31710 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31711 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31712 ELSEIF(MSTP(147).EQ.1) THEN
31713 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31714 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31715 ELSEIF(MSTP(147).EQ.3) THEN
31716 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31717 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31718 ELSEIF(MSTP(147).EQ.4) THEN
31719 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31720 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31721 ELSEIF(MSTP(147).EQ.5) THEN
31722 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31723 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31724 ELSEIF(MSTP(147).EQ.6) THEN
31725 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31726 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31727 ENDIF
31728 FACQQG=COMFAC*FF*FACQQG
31729 ENDIF
31730C...Split total contribution into different colour flows just like
31731C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31732C...(recalculate kinematics for massless partons).
31733 THP=-0.5D0*SH*(1D0-CTH)
31734 UHP=-0.5D0*SH*(1D0+CTH)
31735 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31736 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31737 FACQGS=FACQG1+FACQG2
31738 DO 2442 I=MMINA,MMAXA
31739 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
31740 DO 2441 ISDE=1,2
31741 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
31742 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
31743 NCHN=NCHN+1
31744 ISIG(NCHN,ISDE)=I
31745 ISIG(NCHN,3-ISDE)=21
31746 ISIG(NCHN,3)=1
31747 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
31748 NCHN=NCHN+1
31749 ISIG(NCHN,ISDE)=I
31750 ISIG(NCHN,3-ISDE)=21
31751 ISIG(NCHN,3)=2
31752 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
31753 2441 CONTINUE
31754 2442 CONTINUE
31755
31756 ELSEIF(ISUB.EQ.426) THEN
31757C...q + g -> q + QQ~[1S08]
31758 IF(MSTP(145).EQ.0) THEN
31759 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
31760 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
31761 ELSE
31762 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
31763 IF(MSTP(147).EQ.0) THEN
31764 FACQQG=COMFAC*FA
31765 ELSEIF(MSTP(147).EQ.1) THEN
31766 FACQQG=COMFAC*2D0*FA
31767 ELSEIF(MSTP(147).EQ.3) THEN
31768 FACQQG=COMFAC*FA
31769 ELSEIF(MSTP(147).EQ.4) THEN
31770 FACQQG=COMFAC*FA
31771 ELSEIF(MSTP(147).EQ.5) THEN
31772 FACQQG=0D0
31773 ELSEIF(MSTP(147).EQ.6) THEN
31774 FACQQG=0D0
31775 ENDIF
31776 ENDIF
31777C...Split total contribution into different colour flows just like
31778C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31779C...(recalculate kinematics for massless partons).
31780 THP=-0.5D0*SH*(1D0-CTH)
31781 UHP=-0.5D0*SH*(1D0+CTH)
31782 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31783 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31784 FACQGS=FACQG1+FACQG2
31785 DO 2444 I=MMINA,MMAXA
31786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
31787 DO 2443 ISDE=1,2
31788 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
31789 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
31790 NCHN=NCHN+1
31791 ISIG(NCHN,ISDE)=I
31792 ISIG(NCHN,3-ISDE)=21
31793 ISIG(NCHN,3)=1
31794 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
31795 NCHN=NCHN+1
31796 ISIG(NCHN,ISDE)=I
31797 ISIG(NCHN,3-ISDE)=21
31798 ISIG(NCHN,3)=2
31799 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
31800 2443 CONTINUE
31801 2444 CONTINUE
31802
31803 ELSEIF(ISUB.EQ.427) THEN
31804C...q + g -> q + QQ~[3PJ8]
31805 IF(MSTP(145).EQ.0) THEN
31806 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
31807 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
31808 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
31809 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
31810 ELSE
31811 FF=10D0*PARU(1)*AS**3/
31812 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
31813 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
31814 BB=8D0*(SHTH2+TH*UH)
31815 CC=8D0*UHSH*(SHTH+THUH)
31816 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
31817 IF(MSTP(147).EQ.0) THEN
31818 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31819 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31820 ELSEIF(MSTP(147).EQ.1) THEN
31821 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31822 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31823 ELSEIF(MSTP(147).EQ.3) THEN
31824 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31825 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31826 ELSEIF(MSTP(147).EQ.4) THEN
31827 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31828 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31829 ELSEIF(MSTP(147).EQ.5) THEN
31830 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31831 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31832 ELSEIF(MSTP(147).EQ.6) THEN
31833 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31834 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31835 ENDIF
31836 FACQQG=COMFAC*FF*FACQQG
31837 ENDIF
31838C...Split total contribution into different colour flows just like
31839C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
31840C...(recalculate kinematics for massless partons).
31841 THP=-0.5D0*SH*(1D0-CTH)
31842 UHP=-0.5D0*SH*(1D0+CTH)
31843 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
31844 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
31845 FACQGS=FACQG1+FACQG2
31846 DO 2446 I=MMINA,MMAXA
31847 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
31848 DO 2445 ISDE=1,2
31849 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
31850 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
31851 NCHN=NCHN+1
31852 ISIG(NCHN,ISDE)=I
31853 ISIG(NCHN,3-ISDE)=21
31854 ISIG(NCHN,3)=1
31855 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
31856 NCHN=NCHN+1
31857 ISIG(NCHN,ISDE)=I
31858 ISIG(NCHN,3-ISDE)=21
31859 ISIG(NCHN,3)=2
31860 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
31861 2445 CONTINUE
31862 2446 CONTINUE
31863
31864 ELSEIF(ISUB.EQ.428) THEN
31865C...q + q~ -> g + QQ~[3S18]
31866 IF(MSTP(145).EQ.0) THEN
31867 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
31868 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
31869 & (SQMQQ*SQMQQR*TH*UH*THUH2)
31870 ELSE
31871 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
31872 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
31873 AA=SHTH2+UHSH2
31874 BB=4D0
31875 CC=4D0
31876 DD=0D0
31877 IF(MSTP(147).EQ.0) THEN
31878 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31879 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31880 ELSEIF(MSTP(147).EQ.1) THEN
31881 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31882 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31883 ELSEIF(MSTP(147).EQ.3) THEN
31884 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31885 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31886 ELSEIF(MSTP(147).EQ.4) THEN
31887 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31888 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31889 ELSEIF(MSTP(147).EQ.5) THEN
31890 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31891 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31892 ELSEIF(MSTP(147).EQ.6) THEN
31893 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31894 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31895 ENDIF
31896 FACQQG=COMFAC*FF*FACQQG
31897 ENDIF
31898C...Split total contribution into different colour flows just like
31899C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31900C...(recalculate kinematics for massless partons).
31901 THP=-0.5D0*SH*(1D0-CTH)
31902 UHP=-0.5D0*SH*(1D0+CTH)
31903 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31904 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31905 FACGGS=FACGG1+FACGG2
31906 DO 2447 I=MMINA,MMAXA
31907 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31908 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
31909 NCHN=NCHN+1
31910 ISIG(NCHN,1)=I
31911 ISIG(NCHN,2)=-I
31912 ISIG(NCHN,3)=1
31913 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
31914 NCHN=NCHN+1
31915 ISIG(NCHN,1)=I
31916 ISIG(NCHN,2)=-I
31917 ISIG(NCHN,3)=2
31918 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
31919 2447 CONTINUE
31920
31921 ELSEIF(ISUB.EQ.429) THEN
31922C...q + q~ -> g + QQ~[1S08]
31923 IF(MSTP(145).EQ.0) THEN
31924 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
31925 & (TH2+UH2)/(SQMQQR*SH*THUH2)
31926 ELSE
31927 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
31928 IF(MSTP(147).EQ.0) THEN
31929 FACQQG=COMFAC*FA
31930 ELSEIF(MSTP(147).EQ.1) THEN
31931 FACQQG=COMFAC*2D0*FA
31932 ELSEIF(MSTP(147).EQ.3) THEN
31933 FACQQG=COMFAC*FA
31934 ELSEIF(MSTP(147).EQ.4) THEN
31935 FACQQG=COMFAC*FA
31936 ELSEIF(MSTP(147).EQ.5) THEN
31937 FACQQG=0D0
31938 ELSEIF(MSTP(147).EQ.6) THEN
31939 FACQQG=0D0
31940 ENDIF
31941 ENDIF
31942C...Split total contribution into different colour flows just like
31943C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
31944C...(recalculate kinematics for massless partons).
31945 THP=-0.5D0*SH*(1D0-CTH)
31946 UHP=-0.5D0*SH*(1D0+CTH)
31947 FACGG1=UH/TH-9D0/4D0*UH2/SH2
31948 FACGG2=TH/UH-9D0/4D0*TH2/SH2
31949 FACGGS=FACGG1+FACGG2
31950 DO 2448 I=MMINA,MMAXA
31951 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31952 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
31953 NCHN=NCHN+1
31954 ISIG(NCHN,1)=I
31955 ISIG(NCHN,2)=-I
31956 ISIG(NCHN,3)=1
31957 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
31958 NCHN=NCHN+1
31959 ISIG(NCHN,1)=I
31960 ISIG(NCHN,2)=-I
31961 ISIG(NCHN,3)=2
31962 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
31963 2448 CONTINUE
31964
31965 ELSEIF(ISUB.EQ.430) THEN
31966C...q + q~ -> g + QQ~[3PJ8]
31967 IF(MSTP(145).EQ.0) THEN
31968 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
31969 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
31970 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
31971 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
31972 ELSE
31973 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
31974 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
31975 BB=8D0*(UHSH2+SH*TH)
31976 CC=8D0*(SHTH2+SH*UH)
31977 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
31978 IF(MSTP(147).EQ.0) THEN
31979 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31980 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31981 ELSEIF(MSTP(147).EQ.1) THEN
31982 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31983 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
31984 ELSEIF(MSTP(147).EQ.3) THEN
31985 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
31986 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
31987 ELSEIF(MSTP(147).EQ.4) THEN
31988 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31989 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31990 ELSEIF(MSTP(147).EQ.5) THEN
31991 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
31992 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
31993 ELSEIF(MSTP(147).EQ.6) THEN
31994 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
31995 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
31996 ENDIF
31997 FACQQG=COMFAC*FF*FACQQG
31998 ENDIF
31999C...Split total contribution into different colour flows just like
32000C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32001C...(recalculate kinematics for massless partons).
32002 THP=-0.5D0*SH*(1D0-CTH)
32003 UHP=-0.5D0*SH*(1D0+CTH)
32004 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32005 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32006 FACGGS=FACGG1+FACGG2
32007 DO 2449 I=MMINA,MMAXA
32008 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32009 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32010 NCHN=NCHN+1
32011 ISIG(NCHN,1)=I
32012 ISIG(NCHN,2)=-I
32013 ISIG(NCHN,3)=1
32014 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32015 NCHN=NCHN+1
32016 ISIG(NCHN,1)=I
32017 ISIG(NCHN,2)=-I
32018 ISIG(NCHN,3)=2
32019 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32020 2449 CONTINUE
32021
32022 ELSEIF(ISUB.EQ.431) THEN
32023C...g + g -> QQ~[3P01] + g
32024 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32025 QGTW=(SH*TH*UH)/SH**3
32026 RGTW=SQMQQ/SH
32027 IF(MSTP(145).EQ.0) THEN
32028 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*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 ELSE
32037 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32038 & (9D0*RGTW**2*PGTW**4*
32039 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32040 & -6D0*RGTW*PGTW**3*QGTW*
32041 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32042 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32043 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32044 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32045 IF(MSTP(147).EQ.0) THEN
32046 FACQQG=COMFAC*FC1
32047 ELSEIF(MSTP(147).EQ.1) THEN
32048 FACQQG=COMFAC*2D0*FC1
32049 ELSEIF(MSTP(147).EQ.3) THEN
32050 FACQQG=COMFAC*FC1
32051 ELSEIF(MSTP(147).EQ.4) THEN
32052 FACQQG=COMFAC*FC1
32053 ELSEIF(MSTP(147).EQ.5) THEN
32054 FACQQG=0D0
32055 ELSEIF(MSTP(147).EQ.6) THEN
32056 FACQQG=0D0
32057 ENDIF
32058 ENDIF
32059 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32060 NCHN=NCHN+1
32061 ISIG(NCHN,1)=21
32062 ISIG(NCHN,2)=21
32063 ISIG(NCHN,3)=1
32064 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32065 ENDIF
32066
32067 ELSEIF(ISUB.EQ.432) THEN
32068C...g + g -> QQ~[3P11] + g
32069 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32070 QGTW=(SH*TH*UH)/SH**3
32071 RGTW=SQMQQ/SH
32072 IF(MSTP(145).EQ.0) THEN
32073 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32074 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32075 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32076 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32077 ELSE
32078 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32079 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32080 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32081 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32082 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32083 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32084 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32085 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32086 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32087 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32088 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32089 C4=-4D0*THUH*(TH-UH)**2*
32090 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32091 & -SH2*TH*UH*(TH2+UH2))
32092 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32093 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32094 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32095 IF(MSTP(147).EQ.0) THEN
32096 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32097 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32098 ELSEIF(MSTP(147).EQ.1) THEN
32099 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32100 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32101 ELSEIF(MSTP(147).EQ.3) THEN
32102 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32103 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32104 ELSEIF(MSTP(147).EQ.4) THEN
32105 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32106 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32107 ELSEIF(MSTP(147).EQ.5) THEN
32108 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32109 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32110 ELSEIF(MSTP(147).EQ.6) THEN
32111 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32112 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32113 ENDIF
32114 FACQQG=COMFAC*FF*FACQQG
32115 ENDIF
32116 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32117 NCHN=NCHN+1
32118 ISIG(NCHN,1)=21
32119 ISIG(NCHN,2)=21
32120 ISIG(NCHN,3)=1
32121 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32122 ENDIF
32123
32124 ELSEIF(ISUB.EQ.433) THEN
32125C...g + g -> QQ~[3P21] + g
32126 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32127 QGTW=(SH*TH*UH)/SH**3
32128 RGTW=SQMQQ/SH
32129 IF(MSTP(145).EQ.0) THEN
32130 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32131 & (12D0*RGTW**2*PGTW**4*
32132 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32133 & -3D0*RGTW*PGTW**3*QGTW*
32134 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32135 & +2D0*PGTW**2*QGTW**2*
32136 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32137 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32138 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32139 ELSE
32140 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32141 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32142 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32143 & *SH*SH2**7
32144 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32145 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32146 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32147 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32148 & +10D0*(SH2**2+TH2**2))
32149 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32150 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32151 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32152 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32153 & +4D0*SH*TH*UH2**4*SHTH2)
32154 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32155 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32156 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32157 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32158 & +10D0*(SH2**2+UH2**2))
32159 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32160 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32161 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32162 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32163 & +4D0*SH*UH*TH2**4*UHSH2)
32164 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32165 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32166 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32167 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32168 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32169 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32170 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32171 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32172 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32173 & +3D0*(TH2**3+UH2**3)))
32174 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32175 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32176 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32177 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32178 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32179 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32180 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32181 & 82D0*TH**3)
32182 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32183 & +45D0*TH**3)
32184 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32185 & 8D0*TH**3)
32186 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32187 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32188 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32189 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32190 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32191 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32192 & 82D0*UH**3)
32193 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32194 & +45D0*UH**3)
32195 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32196 & 8D0*UH**3)
32197 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32198 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32199 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32200 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32201 & +4D0*SH*TH2**2*UH2**2*THUH2
32202 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32203 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32204 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32205 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32206 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32207 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32208 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32209 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32210 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32211 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32212 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32213 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32214 & +2D0*(TH2**3+UH2**3))
32215 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32216 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32217 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32218 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32219 IF(MSTP(147).EQ.0) THEN
32220 FACQQG=1D0/3D0*(C1*3D0
32221 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32222 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32223 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32224 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32225 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32226 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32227 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32228 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32229 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32230 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32231 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32232 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32233 ELSEIF(MSTP(147).EQ.1) THEN
32234 FACQQG=C1*2D0
32235 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32236 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32237 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32238 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32239 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32240 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32241 & +EL1K10*EL2K20*EL1K11*EL2K11)
32242 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32243 & +EL1K10*EL2K20*EL1K21*EL2K21)
32244 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32245 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32246 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32247 & +EL1K20*EL2K20*EL1K11*EL2K11)
32248 ELSEIF(MSTP(147).EQ.2) THEN
32249 FACQQG=2D0*(C1
32250 & -C2*EL1K11*EL2K11
32251 & -C3*EL1K21*EL2K21
32252 & -C4*EL1K11*EL2K21
32253 & +C5*(EL1K11*EL2K11)**2
32254 & +C6*(EL1K21*EL2K21)**2
32255 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32256 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32257 & +(C9+C0)*(EL1K11*EL2K21)**2)
32258 ENDIF
32259 FACQQG=COMFAC*FF*FACQQG
32260 ENDIF
32261 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32262 NCHN=NCHN+1
32263 ISIG(NCHN,1)=21
32264 ISIG(NCHN,2)=21
32265 ISIG(NCHN,3)=1
32266 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32267 ENDIF
32268
32269 ELSEIF(ISUB.EQ.434) THEN
32270C...q + g -> q + QQ~[3P01]
32271 IF(MSTP(145).EQ.0) THEN
32272 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32273 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32274 ELSE
32275 FA=-PARU(1)*AS**3*(16D0/243D0)*
32276 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32277 IF(MSTP(147).EQ.0) THEN
32278 FACQQG=COMFAC*FA
32279 ELSEIF(MSTP(147).EQ.1) THEN
32280 FACQQG=COMFAC*2D0*FA
32281 ELSEIF(MSTP(147).EQ.3) THEN
32282 FACQQG=COMFAC*FA
32283 ELSEIF(MSTP(147).EQ.4) THEN
32284 FACQQG=COMFAC*FA
32285 ELSEIF(MSTP(147).EQ.5) THEN
32286 FACQQG=0D0
32287 ELSEIF(MSTP(147).EQ.6) THEN
32288 FACQQG=0D0
32289 ENDIF
32290 ENDIF
32291 DO 2452 I=MMINA,MMAXA
32292 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32293 DO 2451 ISDE=1,2
32294 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32295 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32296 NCHN=NCHN+1
32297 ISIG(NCHN,ISDE)=I
32298 ISIG(NCHN,3-ISDE)=21
32299 ISIG(NCHN,3)=1
32300 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32301 2451 CONTINUE
32302 2452 CONTINUE
32303
32304 ELSEIF(ISUB.EQ.435) THEN
32305C...q + g -> q + QQ~[3P11]
32306 IF(MSTP(145).EQ.0) THEN
32307 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32308 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32309 ELSE
32310 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32311 C1=SH*UH
32312 C2=2D0*SH
32313 C3=0D0
32314 C4=2D0*(SH-UH)
32315 IF(MSTP(147).EQ.0) THEN
32316 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32317 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32318 ELSEIF(MSTP(147).EQ.1) THEN
32319 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32320 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32321 ELSEIF(MSTP(147).EQ.3) THEN
32322 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32323 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32324 ELSEIF(MSTP(147).EQ.4) THEN
32325 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32326 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32327 ELSEIF(MSTP(147).EQ.5) THEN
32328 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32329 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32330 ELSEIF(MSTP(147).EQ.6) THEN
32331 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32332 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32333 ENDIF
32334 FACQQG=COMFAC*FF*FACQQG
32335 ENDIF
32336 DO 2454 I=MMINA,MMAXA
32337 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
32338 DO 2453 ISDE=1,2
32339 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
32340 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
32341 NCHN=NCHN+1
32342 ISIG(NCHN,ISDE)=I
32343 ISIG(NCHN,3-ISDE)=21
32344 ISIG(NCHN,3)=1
32345 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32346 2453 CONTINUE
32347 2454 CONTINUE
32348
32349 ELSEIF(ISUB.EQ.436) THEN
32350C...q + g -> q + QQ~[3P21]
32351 IF(MSTP(145).EQ.0) THEN
32352 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
32353 & ((6D0*SQMQQ**2+TH2)*UHSH2
32354 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
32355 & (SQMQQR*TH*UHSH2**2)
32356 ELSE
32357 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
32358 C1=TH*UHSH2
32359 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
32360 C3=4D0*UHSH2
32361 C4=8D0*SH*UHSH
32362 C5=8D0*TH
32363 C6=0D0
32364 C7=16D0*TH
32365 C8=0D0
32366 C9=-16D0*UHSH
32367 C0=16D0*SQMQQ
32368 IF(MSTP(147).EQ.0) THEN
32369 FACQQG=1D0/3D0*(C1*3D0
32370 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32371 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32372 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32373 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32374 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32375 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32376 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32377 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32378 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32379 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32380 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32381 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32382 ELSEIF(MSTP(147).EQ.1) THEN
32383 FACQQG=C1*2D0
32384 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32385 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32386 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32387 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32388 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32389 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32390 & +EL1K10*EL2K20*EL1K11*EL2K11)
32391 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32392 & +EL1K10*EL2K20*EL1K21*EL2K21)
32393 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32394 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32395 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32396 & +EL1K20*EL2K20*EL1K11*EL2K11)
32397 ELSEIF(MSTP(147).EQ.2) THEN
32398 FACQQG=2D0*(C1
32399 & -C2*EL1K11*EL2K11
32400 & -C3*EL1K21*EL2K21
32401 & -C4*EL1K11*EL2K21
32402 & +C5*(EL1K11*EL2K11)**2
32403 & +C6*(EL1K21*EL2K21)**2
32404 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32405 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32406 & +(C9+C0)*(EL1K11*EL2K21)**2)
32407 ENDIF
32408 FACQQG=COMFAC*FF*FACQQG
32409 ENDIF
32410 DO 2456 I=MMINA,MMAXA
32411 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
32412 DO 2455 ISDE=1,2
32413 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
32414 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
32415 NCHN=NCHN+1
32416 ISIG(NCHN,ISDE)=I
32417 ISIG(NCHN,3-ISDE)=21
32418 ISIG(NCHN,3)=1
32419 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32420 2455 CONTINUE
32421 2456 CONTINUE
32422
32423 ELSEIF(ISUB.EQ.437) THEN
32424C...q + q~ -> g + QQ~[3P01]
32425 IF(MSTP(145).EQ.0) THEN
32426 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
32427 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32428 ELSE
32429 FA=PARU(1)*AS**3*(128D0/729D0)*
32430 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
32431 IF(MSTP(147).EQ.0) THEN
32432 FACQQG=COMFAC*FA
32433 ELSEIF(MSTP(147).EQ.1) THEN
32434 FACQQG=COMFAC*2D0*FA
32435 ELSEIF(MSTP(147).EQ.3) THEN
32436 FACQQG=COMFAC*FA
32437 ELSEIF(MSTP(147).EQ.4) THEN
32438 FACQQG=COMFAC*FA
32439 ELSEIF(MSTP(147).EQ.5) THEN
32440 FACQQG=0D0
32441 ELSEIF(MSTP(147).EQ.6) THEN
32442 FACQQG=0D0
32443 ENDIF
32444 ENDIF
32445 DO 2457 I=MMINA,MMAXA
32446 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32447 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
32448 NCHN=NCHN+1
32449 ISIG(NCHN,1)=I
32450 ISIG(NCHN,2)=-I
32451 ISIG(NCHN,3)=1
32452 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32453 2457 CONTINUE
32454
32455 ELSEIF(ISUB.EQ.438) THEN
32456C...q + q~ -> g + QQ~[3P11]
32457 IF(MSTP(145).EQ.0) THEN
32458 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
32459 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
32460 ELSE
32461 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
32462 C1=TH*UH
32463 C2=2D0*UH
32464 C3=2D0*TH
32465 C4=2D0*THUH
32466 IF(MSTP(147).EQ.0) THEN
32467 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32468 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32469 ELSEIF(MSTP(147).EQ.1) THEN
32470 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32471 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32472 ELSEIF(MSTP(147).EQ.3) THEN
32473 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32474 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32475 ELSEIF(MSTP(147).EQ.4) THEN
32476 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32477 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32478 ELSEIF(MSTP(147).EQ.5) THEN
32479 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32480 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32481 ELSEIF(MSTP(147).EQ.6) THEN
32482 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32483 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32484 ENDIF
32485 FACQQG=COMFAC*FF*FACQQG
32486 ENDIF
32487 DO 2458 I=MMINA,MMAXA
32488 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32489 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
32490 NCHN=NCHN+1
32491 ISIG(NCHN,1)=I
32492 ISIG(NCHN,2)=-I
32493 ISIG(NCHN,3)=1
32494 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32495 2458 CONTINUE
32496
32497 ELSEIF(ISUB.EQ.439) THEN
32498C...q + q~ -> g + QQ~[3P21]
32499 IF(MSTP(145).EQ.0) THEN
32500 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
32501 & ((6D0*SQMQQ**2+SH2)*THUH2
32502 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
32503 & (SQMQQR*SH*THUH2**2)
32504 ELSE
32505 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
32506 C1=SH*THUH2
32507 C2=4D0*(SH2+UH2+2D0*SH*THUH)
32508 C3=4D0*(SH2+TH2+2D0*SH*THUH)
32509 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
32510 C5=8D0*SH
32511 C6=C5
32512 C7=16D0*SH
32513 C8=C7
32514 C9=-16D0*THUH
32515 C0=16D0*SQMQQ
32516 IF(MSTP(147).EQ.0) THEN
32517 FACQQG=1D0/3D0*(C1*3D0
32518 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32519 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32520 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32521 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32522 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32523 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32524 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32525 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32526 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32527 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32528 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32529 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32530 ELSEIF(MSTP(147).EQ.1) THEN
32531 FACQQG=C1*2D0
32532 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32533 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32534 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32535 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32536 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32537 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32538 & +EL1K10*EL2K20*EL1K11*EL2K11)
32539 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32540 & +EL1K10*EL2K20*EL1K21*EL2K21)
32541 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32542 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32543 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32544 & +EL1K20*EL2K20*EL1K11*EL2K11)
32545 ELSEIF(MSTP(147).EQ.2) THEN
32546 FACQQG=2D0*(C1
32547 & -C2*EL1K11*EL2K11
32548 & -C3*EL1K21*EL2K21
32549 & -C4*EL1K11*EL2K21
32550 & +C5*(EL1K11*EL2K11)**2
32551 & +C6*(EL1K21*EL2K21)**2
32552 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32553 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32554 & +(C9+C0)*(EL1K11*EL2K21)**2)
32555 ENDIF
32556 FACQQG=COMFAC*FF*FACQQG
32557 ENDIF
32558 DO 2459 I=MMINA,MMAXA
32559 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32560 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
32561 NCHN=NCHN+1
32562 ISIG(NCHN,1)=I
32563 ISIG(NCHN,2)=-I
32564 ISIG(NCHN,3)=1
32565 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32566 2459 CONTINUE
32567 ENDIF
32568C...QUARKONIA---
32569
32570 ENDIF
32571
32572 RETURN
32573 END
32574
32575C*********************************************************************
32576
32577C...PYSGWZ
32578C...Subprocess cross sections for W/Z processes,
32579C...except that longitudinal WW scattering is in Higgs sector.
32580C...Auxiliary to PYSIGH.
32581
32582 SUBROUTINE PYSGWZ(NCHN,SIGS)
32583
32584C...Double precision and integer declarations
32585 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
32586 IMPLICIT INTEGER(I-N)
32587 INTEGER PYK,PYCHGE,PYCOMP
32588C...Parameter statement to help give large particle numbers.
32589 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
32590 &KEXCIT=4000000,KDIMEN=5000000)
32591C...Commonblocks
32592 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
32593 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
32594 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
32595 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
32596 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
32597 COMMON/PYINT1/MINT(400),VINT(400)
32598 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
32599 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
32600 COMMON/PYINT4/MWID(500),WIDS(500,5)
32601 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
32602 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
32603 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
32604 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
32605 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
32606 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
32607 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
32608C...Local arrays and complex numbers
32609 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
32610 &HL4(3),HR4(3)
32611 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
32612
32613C...Differential cross section expressions.
32614
32615 IF(ISUB.LE.20) THEN
32616 IF(ISUB.EQ.1) THEN
32617C...f + fbar -> gamma*/Z0
32618 MINT(61)=2
32619 CALL PYWIDT(23,SH,WDTP,WDTE)
32620 HS=SHR*WDTP(0)
32621 FACZ=4D0*COMFAC*3D0
32622 HP0=AEM/3D0*SH
32623 HP1=AEM/3D0*XWC*SH
32624 DO 100 I=MMINA,MMAXA
32625 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
32626 EI=KCHG(IABS(I),1)/3D0
32627 AI=SIGN(1D0,EI)
32628 VI=AI-4D0*EI*XWV
32629 HI0=HP0
32630 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
32631 HI1=HP1
32632 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
32633 NCHN=NCHN+1
32634 ISIG(NCHN,1)=I
32635 ISIG(NCHN,2)=-I
32636 ISIG(NCHN,3)=1
32637 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
32638 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
32639 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
32640 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
32641 100 CONTINUE
32642
32643 ELSEIF(ISUB.EQ.2) THEN
32644C...f + fbar' -> W+/-
32645 CALL PYWIDT(24,SH,WDTP,WDTE)
32646 HS=SHR*WDTP(0)
32647 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
32648 HP=AEM/(24D0*XW)*SH
32649 DO 120 I=MMIN1,MMAX1
32650 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
32651 IA=IABS(I)
32652 DO 110 J=MMIN2,MMAX2
32653 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
32654 JA=IABS(J)
32655 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
32656 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32657 & GOTO 110
32658 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32659 HI=HP*2D0
32660 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
32661 NCHN=NCHN+1
32662 ISIG(NCHN,1)=I
32663 ISIG(NCHN,2)=J
32664 ISIG(NCHN,3)=1
32665 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
32666 SIGH(NCHN)=HI*FACBW*HF
32667 110 CONTINUE
32668 120 CONTINUE
32669
32670 ELSEIF(ISUB.EQ.15) THEN
32671C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
32672 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32673C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32674 HFGG=0D0
32675 HFGZ=0D0
32676 HFZZ=0D0
32677 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32678 DO 130 I=1,MIN(16,MDCY(23,3))
32679 IDC=I+MDCY(23,2)-1
32680 IF(MDME(IDC,1).LT.0) GOTO 130
32681 IMDM=0
32682 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32683 & IMDM=1
32684 IF(I.LE.8) THEN
32685 EF=KCHG(I,1)/3D0
32686 AF=SIGN(1D0,EF+0.1D0)
32687 VF=AF-4D0*EF*XWV
32688 ELSEIF(I.LE.16) THEN
32689 EF=KCHG(I+2,1)/3D0
32690 AF=SIGN(1D0,EF+0.1D0)
32691 VF=AF-4D0*EF*XWV
32692 ENDIF
32693 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32694 IF(4D0*RM1.LT.1D0) THEN
32695 FCOF=1D0
32696 IF(I.LE.8) FCOF=3D0*RADC4
32697 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32698 IF(IMDM.EQ.1) THEN
32699 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32700 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32701 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32702 & AF**2*(1D0-4D0*RM1))*BE34
32703 ENDIF
32704 ENDIF
32705 130 CONTINUE
32706C...Propagators: as simulated in PYOFSH and as desired
32707 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32708 MINT15=MINT(15)
32709 MINT(15)=1
32710 MINT(61)=1
32711 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32712 MINT(15)=MINT15
32713 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32714 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32715 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32716 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32717C...Loop over flavours; consider full gamma/Z structure
32718 DO 140 I=MMINA,MMAXA
32719 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32720 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
32721 EI=KCHG(IABS(I),1)/3D0
32722 AI=SIGN(1D0,EI)
32723 VI=AI-4D0*EI*XWV
32724 NCHN=NCHN+1
32725 ISIG(NCHN,1)=I
32726 ISIG(NCHN,2)=-I
32727 ISIG(NCHN,3)=1
32728 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
32729 & (VI**2+AI**2)*HFZZ)/HBW4
32730 140 CONTINUE
32731
32732 ELSEIF(ISUB.EQ.16) THEN
32733C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
32734 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32735C...Propagators: as simulated in PYOFSH and as desired
32736 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32737 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32738 GMMWC=SQRT(SQM4)*WDTP(0)
32739 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32740 FACWG=FACWG*HBW4C/HBW4
32741 DO 160 I=MMIN1,MMAX1
32742 IA=IABS(I)
32743 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
32744 DO 150 J=MMIN2,MMAX2
32745 JA=IABS(J)
32746 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
32747 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
32748 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32749 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32750 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32751 NCHN=NCHN+1
32752 ISIG(NCHN,1)=I
32753 ISIG(NCHN,2)=J
32754 ISIG(NCHN,3)=1
32755 SIGH(NCHN)=FACWG*FCKM*WIDSC
32756 150 CONTINUE
32757 160 CONTINUE
32758
32759 ELSEIF(ISUB.EQ.19) THEN
32760C...f + fbar -> gamma + (gamma*/Z0)
32761 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32762C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32763 HFGG=0D0
32764 HFGZ=0D0
32765 HFZZ=0D0
32766 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32767 DO 170 I=1,MIN(16,MDCY(23,3))
32768 IDC=I+MDCY(23,2)-1
32769 IF(MDME(IDC,1).LT.0) GOTO 170
32770 IMDM=0
32771 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
32772 & IMDM=1
32773 IF(I.LE.8) THEN
32774 EF=KCHG(I,1)/3D0
32775 AF=SIGN(1D0,EF+0.1D0)
32776 VF=AF-4D0*EF*XWV
32777 ELSEIF(I.LE.16) THEN
32778 EF=KCHG(I+2,1)/3D0
32779 AF=SIGN(1D0,EF+0.1D0)
32780 VF=AF-4D0*EF*XWV
32781 ENDIF
32782 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32783 IF(4D0*RM1.LT.1D0) THEN
32784 FCOF=1D0
32785 IF(I.LE.8) FCOF=3D0*RADC4
32786 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32787 IF(IMDM.EQ.1) THEN
32788 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32789 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32790 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
32791 & AF**2*(1D0-4D0*RM1))*BE34
32792 ENDIF
32793 ENDIF
32794 170 CONTINUE
32795C...Propagators: as simulated in PYOFSH and as desired
32796 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32797 MINT15=MINT(15)
32798 MINT(15)=1
32799 MINT(61)=1
32800 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32801 MINT(15)=MINT15
32802 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32803 HFGG=HFGG*HFAEM*VINT(111)/SQM4
32804 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
32805 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
32806C...Loop over flavours; consider full gamma/Z structure
32807 DO 180 I=MMINA,MMAXA
32808 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
32809 EI=KCHG(IABS(I),1)/3D0
32810 AI=SIGN(1D0,EI)
32811 VI=AI-4D0*EI*XWV
32812 FCOI=1D0
32813 IF(IABS(I).LE.10) FCOI=FACA/3D0
32814 NCHN=NCHN+1
32815 ISIG(NCHN,1)=I
32816 ISIG(NCHN,2)=-I
32817 ISIG(NCHN,3)=1
32818 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
32819 & (VI**2+AI**2)*HFZZ)/HBW4
32820 180 CONTINUE
32821
32822 ELSEIF(ISUB.EQ.20) THEN
32823C...f + fbar' -> gamma + W+/-
32824 FACGW=COMFAC*0.5D0*AEM**2/XW
32825C...Propagators: as simulated in PYOFSH and as desired
32826 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
32827 CALL PYWIDT(24,SQM4,WDTP,WDTE)
32828 GMMWC=SQRT(SQM4)*WDTP(0)
32829 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
32830 FACGW=FACGW*HBW4C/HBW4
32831C...Anomalous couplings
32832 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
32833 TERM2=0D0
32834 TERM3=0D0
32835 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
32836 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
32837 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
32838 & (4D0*SQMW))/(TH+UH)**2
32839 ENDIF
32840 DO 200 I=MMIN1,MMAX1
32841 IA=IABS(I)
32842 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
32843 DO 190 J=MMIN2,MMAX2
32844 JA=IABS(J)
32845 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
32846 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
32847 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32848 & GOTO 190
32849 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32850 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
32851 IF(IA.LE.10) THEN
32852 FACWR=UH/(TH+UH)-1D0/3D0
32853 FCKM=VCKM((IA+1)/2,(JA+1)/2)
32854 FCOI=FACA/3D0
32855 ELSE
32856 FACWR=-TH/(TH+UH)
32857 FCKM=1D0
32858 FCOI=1D0
32859 ENDIF
32860 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
32861 NCHN=NCHN+1
32862 ISIG(NCHN,1)=I
32863 ISIG(NCHN,2)=J
32864 ISIG(NCHN,3)=1
32865 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
32866 190 CONTINUE
32867 200 CONTINUE
32868 ENDIF
32869
32870 ELSEIF(ISUB.LE.40) THEN
32871 IF(ISUB.EQ.22) THEN
32872C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
32873C...Kinematics dependence
32874 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
32875 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
32876C...gamma, gamma/Z interference and Z couplings to final fermion pairs
32877 DO 220 I=1,6
32878 DO 210 J=1,3
32879 HGZ(I,J)=0D0
32880 210 CONTINUE
32881 220 CONTINUE
32882 RADC3=1D0+PYALPS(SQM3)/PARU(1)
32883 RADC4=1D0+PYALPS(SQM4)/PARU(1)
32884 DO 230 I=1,MIN(16,MDCY(23,3))
32885 IDC=I+MDCY(23,2)-1
32886 IF(MDME(IDC,1).LT.0) GOTO 230
32887 IMDM=0
32888 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
32889 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
32890 IF(I.LE.8) THEN
32891 EF=KCHG(I,1)/3D0
32892 AF=SIGN(1D0,EF+0.1D0)
32893 VF=AF-4D0*EF*XWV
32894 ELSEIF(I.LE.16) THEN
32895 EF=KCHG(I+2,1)/3D0
32896 AF=SIGN(1D0,EF+0.1D0)
32897 VF=AF-4D0*EF*XWV
32898 ENDIF
32899 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
32900 IF(4D0*RM1.LT.1D0) THEN
32901 FCOF=1D0
32902 IF(I.LE.8) FCOF=3D0*RADC3
32903 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32904 IF(IMDM.GE.1) THEN
32905 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32906 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32907 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32908 & AF**2*(1D0-4D0*RM1))*BE34
32909 ENDIF
32910 ENDIF
32911 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
32912 IF(4D0*RM1.LT.1D0) THEN
32913 FCOF=1D0
32914 IF(I.LE.8) FCOF=3D0*RADC4
32915 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
32916 IF(IMDM.GE.1) THEN
32917 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
32918 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
32919 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
32920 & AF**2*(1D0-4D0*RM1))*BE34
32921 ENDIF
32922 ENDIF
32923 230 CONTINUE
32924C...Propagators: as simulated in PYOFSH and as desired
32925 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
32926 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
32927 MINT15=MINT(15)
32928 MINT(15)=1
32929 MINT(61)=1
32930 CALL PYWIDT(23,SQM3,WDTP,WDTE)
32931 MINT(15)=MINT15
32932 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32933 DO 240 J=1,3
32934 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
32935 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
32936 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
32937 240 CONTINUE
32938 MINT15=MINT(15)
32939 MINT(15)=1
32940 MINT(61)=1
32941 CALL PYWIDT(23,SQM4,WDTP,WDTE)
32942 MINT(15)=MINT15
32943 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
32944 DO 250 J=1,3
32945 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
32946 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
32947 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
32948 250 CONTINUE
32949C...Loop over flavours; separate left- and right-handed couplings
32950 DO 270 I=MMINA,MMAXA
32951 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
32952 EI=KCHG(IABS(I),1)/3D0
32953 AI=SIGN(1D0,EI)
32954 VI=AI-4D0*EI*XWV
32955 VALI=VI-AI
32956 VARI=VI+AI
32957 FCOI=1D0
32958 IF(IABS(I).LE.10) FCOI=FACA/3D0
32959 DO 260 J=1,3
32960 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
32961 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
32962 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
32963 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
32964 260 CONTINUE
32965 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
32966 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
32967 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
32968 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
32969 NCHN=NCHN+1
32970 ISIG(NCHN,1)=I
32971 ISIG(NCHN,2)=-I
32972 ISIG(NCHN,3)=1
32973 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
32974 270 CONTINUE
32975
32976 ELSEIF(ISUB.EQ.23) THEN
32977C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
32978 FACZW=COMFAC*0.5D0*(AEM/XW)**2
32979 FACZW=FACZW*WIDS(23,2)
32980 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
32981 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
32982 DO 290 I=MMIN1,MMAX1
32983 IA=IABS(I)
32984 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
32985 DO 280 J=MMIN2,MMAX2
32986 JA=IABS(J)
32987 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
32988 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
32989 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
32990 & GOTO 280
32991 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
32992 EI=KCHG(IA,1)/3D0
32993 AI=SIGN(1D0,EI+0.1D0)
32994 VI=AI-4D0*EI*XWV
32995 EJ=KCHG(JA,1)/3D0
32996 AJ=SIGN(1D0,EJ+0.1D0)
32997 VJ=AJ-4D0*EJ*XWV
32998 IF(VI+AI.GT.0) THEN
32999 VISAV=VI
33000 AISAV=AI
33001 VI=VJ
33002 AI=AJ
33003 VJ=VISAV
33004 AJ=AISAV
33005 ENDIF
33006 FCKM=1D0
33007 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33008 FCOI=1D0
33009 IF(IA.LE.10) FCOI=FACA/3D0
33010 NCHN=NCHN+1
33011 ISIG(NCHN,1)=I
33012 ISIG(NCHN,2)=J
33013 ISIG(NCHN,3)=1
33014 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33015 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33016 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33017 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33018 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33019 & WIDS(24,(5-KCHW)/2)
33020C***Protect against slightly negative cross sections. (Reason yet to be
33021C***sorted out. One possibility: addition of width to the W propagator.)
33022 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33023 280 CONTINUE
33024 290 CONTINUE
33025
33026 ELSEIF(ISUB.EQ.25) THEN
33027C...f + fbar -> W+ + W-
33028C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33029 GMMZC=GMMZ
33030 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33031 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33032 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33033 GMMW3=SQRT(SQM3)*WDTP(0)
33034 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33035 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33036 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33037 GMMW4=SQRT(SQM4)*WDTP(0)
33038 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33039C...Kinematical functions
33040 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33041 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33042 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33043 GT=THUH34+4D0*THUH/TH2
33044 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33045 GU=THUH34+4D0*THUH/UH2
33046 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33047C...Common factors and couplings
33048 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33049 FACWW=FACWW*WIDS(24,1)
33050 CGG=AEM**2/2D0
33051 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33052 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33053 CNG=AEM**2/(4D0*XW)
33054 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33055 CNN=AEM**2/(16D0*XW**2)
33056C...Coulomb factor for W+W- pair
33057 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33058 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33059 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33060 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33061 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33062 & PMAS(24,2)**2)-COULE))
33063 ELSE
33064 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33065 ENDIF
33066 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33067 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33068 & PMAS(24,2)**2)+COULE))
33069 ELSE
33070 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33071 & ABS(COULE)))
33072 ENDIF
33073 IF(MSTP(40).EQ.1) THEN
33074 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33075 & MAX(1D-10,2D0*COULP*COULP1))
33076 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33077 ELSEIF(MSTP(40).EQ.2) THEN
33078 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33079 COULCP=DCMPLX(0D0,DBLE(COULP))
33080 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33081 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33082 & (4D0*COULCP)*LOG(COULCD)
33083 COULCS=DCMPLX(0D0,0D0)
33084 NSTP=100
33085 DO 300 ISTP=1,NSTP
33086 COULXX=(ISTP-0.5)/NSTP
33087 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33088 & (1D0+COULXX/COULCD))
33089 300 CONTINUE
33090 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33091 & (COULCS/NSTP)
33092 FACCOU=ABS(COULCR)**2
33093 ELSEIF(MSTP(40).EQ.3) THEN
33094 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33095 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33096 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33097 ENDIF
33098 ELSEIF(MSTP(40).EQ.4) THEN
33099 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33100 ELSE
33101 FACCOU=1D0
33102 ENDIF
33103 VINT(95)=FACCOU
33104 FACWW=FACWW*FACCOU
33105C...Loop over allowed flavours
33106 DO 310 I=MMINA,MMAXA
33107 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33108 EI=KCHG(IABS(I),1)/3D0
33109 AI=SIGN(1D0,EI+0.1D0)
33110 VI=AI-4D0*EI*XWV
33111 FCOI=1D0
33112 IF(IABS(I).LE.10) FCOI=FACA/3D0
33113 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33114 IF(AI.LT.0D0) THEN
33115 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33116 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33117 ELSE
33118 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33119 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33120 ENDIF
33121 ELSE
33122 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33123 BET=SQRT(1D0-4D0*XMW02/SH)
33124 GAT=1D0/SQRT(1D0-BET**2)
33125 STHE2=1D0-CTH**2
33126 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33127 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33128 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33129 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33130 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33131 & (1D0-2D0*BET*CTH+BET**2))
33132 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33133 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33134 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33135 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33136 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33137 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33138 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33139 DSIGWW=ATOT
33140 ENDIF
33141 NCHN=NCHN+1
33142 ISIG(NCHN,1)=I
33143 ISIG(NCHN,2)=-I
33144 ISIG(NCHN,3)=1
33145 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33146 310 CONTINUE
33147
33148 ELSEIF(ISUB.EQ.30) THEN
33149C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33150 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33151 & (-SH*UH)
33152C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33153 HFGG=0D0
33154 HFGZ=0D0
33155 HFZZ=0D0
33156 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33157 DO 320 I=1,MIN(16,MDCY(23,3))
33158 IDC=I+MDCY(23,2)-1
33159 IF(MDME(IDC,1).LT.0) GOTO 320
33160 IMDM=0
33161 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33162 & IMDM=1
33163 IF(I.LE.8) THEN
33164 EF=KCHG(I,1)/3D0
33165 AF=SIGN(1D0,EF+0.1D0)
33166 VF=AF-4D0*EF*XWV
33167 ELSEIF(I.LE.16) THEN
33168 EF=KCHG(I+2,1)/3D0
33169 AF=SIGN(1D0,EF+0.1D0)
33170 VF=AF-4D0*EF*XWV
33171 ENDIF
33172 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33173 IF(4D0*RM1.LT.1D0) THEN
33174 FCOF=1D0
33175 IF(I.LE.8) FCOF=3D0*RADC4
33176 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33177 IF(IMDM.EQ.1) THEN
33178 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33179 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33180 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33181 & AF**2*(1D0-4D0*RM1))*BE34
33182 ENDIF
33183 ENDIF
33184 320 CONTINUE
33185C...Propagators: as simulated in PYOFSH and as desired
33186 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33187 MINT15=MINT(15)
33188 MINT(15)=1
33189 MINT(61)=1
33190 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33191 MINT(15)=MINT15
33192 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33193 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33194 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33195 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33196C...Loop over flavours; consider full gamma/Z structure
33197 DO 340 I=MMINA,MMAXA
33198 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33199 EI=KCHG(IABS(I),1)/3D0
33200 AI=SIGN(1D0,EI)
33201 VI=AI-4D0*EI*XWV
33202 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33203 & (VI**2+AI**2)*HFZZ)/HBW4
33204 DO 330 ISDE=1,2
33205 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33206 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33207 NCHN=NCHN+1
33208 ISIG(NCHN,ISDE)=I
33209 ISIG(NCHN,3-ISDE)=21
33210 ISIG(NCHN,3)=1
33211 SIGH(NCHN)=FACZQ
33212 330 CONTINUE
33213 340 CONTINUE
33214
33215 ELSEIF(ISUB.EQ.31) THEN
33216C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33217 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33218 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33219C...Propagators: as simulated in PYOFSH and as desired
33220 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33221 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33222 GMMWC=SQRT(SQM4)*WDTP(0)
33223 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33224 FACWQ=FACWQ*HBW4C/HBW4
33225 DO 360 I=MMINA,MMAXA
33226 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33227 IA=IABS(I)
33228 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33229 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33230 DO 350 ISDE=1,2
33231 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33232 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33233 NCHN=NCHN+1
33234 ISIG(NCHN,ISDE)=I
33235 ISIG(NCHN,3-ISDE)=21
33236 ISIG(NCHN,3)=1
33237 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33238 350 CONTINUE
33239 360 CONTINUE
33240
33241 ELSEIF(ISUB.EQ.35) THEN
33242C...f + gamma -> f + (gamma*/Z0)
33243 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33244 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33245 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33246 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33247 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33248 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33249 ELSE
33250 FZQN=SH2+UH2+2D0*SQM4*TH
33251 FZQDTM=-SH*UH
33252 ENDIF
33253 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33254C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33255 HFGG=0D0
33256 HFGZ=0D0
33257 HFZZ=0D0
33258 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33259 DO 370 I=1,MIN(16,MDCY(23,3))
33260 IDC=I+MDCY(23,2)-1
33261 IF(MDME(IDC,1).LT.0) GOTO 370
33262 IMDM=0
33263 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33264 & IMDM=1
33265 IF(I.LE.8) THEN
33266 EF=KCHG(I,1)/3D0
33267 AF=SIGN(1D0,EF+0.1D0)
33268 VF=AF-4D0*EF*XWV
33269 ELSEIF(I.LE.16) THEN
33270 EF=KCHG(I+2,1)/3D0
33271 AF=SIGN(1D0,EF+0.1D0)
33272 VF=AF-4D0*EF*XWV
33273 ENDIF
33274 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33275 IF(4D0*RM1.LT.1D0) THEN
33276 FCOF=1D0
33277 IF(I.LE.8) FCOF=3D0*RADC4
33278 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33279 IF(IMDM.EQ.1) THEN
33280 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33281 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33282 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33283 & AF**2*(1D0-4D0*RM1))*BE34
33284 ENDIF
33285 ENDIF
33286 370 CONTINUE
33287C...Propagators: as simulated in PYOFSH and as desired
33288 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33289 MINT15=MINT(15)
33290 MINT(15)=1
33291 MINT(61)=1
33292 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33293 MINT(15)=MINT15
33294 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33295 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33296 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33297 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33298C...Loop over flavours; consider full gamma/Z structure
33299 DO 390 I=MMINA,MMAXA
33300 IF(I.EQ.0) GOTO 390
33301 EI=KCHG(IABS(I),1)/3D0
33302 AI=SIGN(1D0,EI)
33303 VI=AI-4D0*EI*XWV
33304 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33305 & (VI**2+AI**2)*HFZZ)/HBW4
33306 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33307 DO 380 ISDE=1,2
33308 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33309 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33310 NCHN=NCHN+1
33311 ISIG(NCHN,ISDE)=I
33312 ISIG(NCHN,3-ISDE)=22
33313 ISIG(NCHN,3)=1
33314 SIGH(NCHN)=FACZQ*FZQN/FZQD
33315 380 CONTINUE
33316 390 CONTINUE
33317
33318 ELSEIF(ISUB.EQ.36) THEN
33319C...f + gamma -> f' + W+/-
33320 FWQ=COMFAC*AEM**2/(2D0*XW)*
33321 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33322C...Propagators: as simulated in PYOFSH and as desired
33323 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33324 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33325 GMMWC=SQRT(SQM4)*WDTP(0)
33326 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33327 FWQ=FWQ*HBW4C/HBW4
33328 DO 410 I=MMINA,MMAXA
33329 IF(I.EQ.0) GOTO 410
33330 IA=IABS(I)
33331 EIA=ABS(KCHG(IABS(I),1)/3D0)
33332 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33333 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33334 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33335 DO 400 ISDE=1,2
33336 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
33337 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
33338 NCHN=NCHN+1
33339 ISIG(NCHN,ISDE)=I
33340 ISIG(NCHN,3-ISDE)=22
33341 ISIG(NCHN,3)=1
33342 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33343 400 CONTINUE
33344 410 CONTINUE
33345 ENDIF
33346
33347 ELSEIF(ISUB.LE.100) THEN
33348 IF(ISUB.EQ.69) THEN
33349C...gamma + gamma -> W+ + W-
33350 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33351 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
33352 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
33353 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
33354 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
33355 NCHN=NCHN+1
33356 ISIG(NCHN,1)=22
33357 ISIG(NCHN,2)=22
33358 ISIG(NCHN,3)=1
33359 SIGH(NCHN)=FACWW
33360 420 CONTINUE
33361
33362 ELSEIF(ISUB.EQ.70) THEN
33363C...gamma + W+/- -> Z0 + W+/-
33364 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
33365 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
33366 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
33367 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
33368 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
33369 DO 440 KCHW=1,-1,-2
33370 DO 430 ISDE=1,2
33371 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
33372 NCHN=NCHN+1
33373 ISIG(NCHN,ISDE)=22
33374 ISIG(NCHN,3-ISDE)=24*KCHW
33375 ISIG(NCHN,3)=1
33376 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
33377 430 CONTINUE
33378 440 CONTINUE
33379 ENDIF
33380 ENDIF
33381
33382 RETURN
33383 END
33384
33385C*********************************************************************
33386
33387C...PYSGHG
33388C...Subprocess cross sections for Higgs processes,
33389C...except Higgs pairs in PYSGSU, but including WW scattering.
33390C...Auxiliary to PYSIGH.
33391
33392 SUBROUTINE PYSGHG(NCHN,SIGS)
33393
33394C...Double precision and integer declarations
33395 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33396 IMPLICIT INTEGER(I-N)
33397 INTEGER PYK,PYCHGE,PYCOMP
33398C...Parameter statement to help give large particle numbers.
33399 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33400 &KEXCIT=4000000,KDIMEN=5000000)
33401C...Commonblocks
33402 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33403 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33404 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33405 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33406 COMMON/PYINT1/MINT(400),VINT(400)
33407 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33408 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33409 COMMON/PYINT4/MWID(500),WIDS(500,5)
33410 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33411 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
33412 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33413 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33414 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33415 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33416 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
33417 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
33418C...Local arrays and complex variables
33419 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
33420 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
33421 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
33422
33423C...Convert H or A process into equivalent h one
33424 IHIGG=1
33425 KFHIGG=25
33426 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
33427 KFHIGG=KFPR(ISUB,1)
33428 END IF
33429 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
33430 &ISUB.LE.190)) THEN
33431 IHIGG=2
33432 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
33433 KFHIGG=33+IHIGG
33434 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
33435 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
33436 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
33437 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
33438 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
33439 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
33440 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
33441 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
33442 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
33443 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
33444 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
33445 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
33446 ENDIF
33447 SQMH=PMAS(KFHIGG,1)**2
33448 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
33449
33450C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33451 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
33452 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
33453C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
33454 IF(MSTP(46).LE.4) THEN
33455 HDTLH=LOG(PMAS(25,1)/PARP(44))
33456 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
33457 HDTNR=-1D0/18D0+HDTLH/6D0
33458 ELSE
33459 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
33460 HDTLQ=LOG(PARP(45)/PARP(44))
33461 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
33462 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
33463 ENDIF
33464
33465C...Calculate lowest and next-to-lowest order partial wave amplitudes
33466 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
33467 A00L=DBLE(HDTV*SH)
33468 A20L=-0.5D0*A00L
33469 A11L=A00L/6D0
33470 HDTLS=LOG(SH/PARP(44)**2)
33471 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33472 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
33473 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
33474 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
33475 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
33476 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
33477 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
33478 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
33479
33480C...Unitarize partial wave amplitudes with Pade or K-matrix method
33481 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
33482 A00U=A00L/(1D0-A004/A00L)
33483 A20U=A20L/(1D0-A204/A20L)
33484 A11U=A11L/(1D0-A114/A11L)
33485 ELSE
33486 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
33487 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
33488 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
33489 ENDIF
33490 ENDIF
33491
33492C...Differential cross section expressions.
33493
33494 IF(ISUB.LE.60) THEN
33495 IF(ISUB.EQ.3) THEN
33496C...f + fbar -> h0 (or H0, or A0)
33497 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
33498 HS=SHR*WDTP(0)
33499 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33500 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
33501 & FACBW=0D0
33502 HP=AEM/(8D0*XW)*SH/SQMW*SH
33503 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33504 DO 100 I=MMINA,MMAXA
33505 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33506 IA=IABS(I)
33507 RMQ=PYMRUN(IA,SH)**2/SH
33508 HI=HP*RMQ
33509 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
33510 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
33511 IKFI=1
33512 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
33513 IF(IA.GT.10) IKFI=3
33514 HI=HI*PARU(150+10*IHIGG+IKFI)**2
33515 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
33516 HI=HI/(1D0+RMSS(41))**2
33517 IF(IHIGG.NE.3) THEN
33518 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
33519 & PARU(151+10*IHIGG))**2
33520 ENDIF
33521 ENDIF
33522 ENDIF
33523 NCHN=NCHN+1
33524 ISIG(NCHN,1)=I
33525 ISIG(NCHN,2)=-I
33526 ISIG(NCHN,3)=1
33527 SIGH(NCHN)=HI*FACBW*HF
33528 100 CONTINUE
33529
33530 ELSEIF(ISUB.EQ.5) THEN
33531C...Z0 + Z0 -> h0
33532 CALL PYWIDT(25,SH,WDTP,WDTE)
33533 HS=SHR*WDTP(0)
33534 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33535 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33536 HP=AEM/(8D0*XW)*SH/SQMW*SH
33537 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33538 HI=HP/4D0
33539 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
33540 DO 120 I=MMIN1,MMAX1
33541 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33542 DO 110 J=MMIN2,MMAX2
33543 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33544 EI=KCHG(IABS(I),1)/3D0
33545 AI=SIGN(1D0,EI)
33546 VI=AI-4D0*EI*XWV
33547 EJ=KCHG(IABS(J),1)/3D0
33548 AJ=SIGN(1D0,EJ)
33549 VJ=AJ-4D0*EJ*XWV
33550 NCHN=NCHN+1
33551 ISIG(NCHN,1)=I
33552 ISIG(NCHN,2)=J
33553 ISIG(NCHN,3)=1
33554 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
33555 110 CONTINUE
33556 120 CONTINUE
33557
33558 ELSEIF(ISUB.EQ.8) THEN
33559C...W+ + W- -> h0
33560 CALL PYWIDT(25,SH,WDTP,WDTE)
33561 HS=SHR*WDTP(0)
33562 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
33563 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
33564 HP=AEM/(8D0*XW)*SH/SQMW*SH
33565 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
33566 HI=HP/2D0
33567 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
33568 DO 140 I=MMIN1,MMAX1
33569 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
33570 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33571 DO 130 J=MMIN2,MMAX2
33572 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
33573 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33574 IF(EI*EJ.GT.0D0) GOTO 130
33575 NCHN=NCHN+1
33576 ISIG(NCHN,1)=I
33577 ISIG(NCHN,2)=J
33578 ISIG(NCHN,3)=1
33579 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
33580 130 CONTINUE
33581 140 CONTINUE
33582
33583 ELSEIF(ISUB.EQ.24) THEN
33584C...f + fbar -> Z0 + h0 (or H0, or A0)
33585C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
33586 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33587 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33588 GMMZ3=SQRT(SQM3)*WDTP(0)
33589 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
33590 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33591 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33592 GMMH4=SQRT(SQM4)*WDTP(0)
33593 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33594 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33595 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
33596 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
33597 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
33598 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
33599 & PARU(154+10*IHIGG)**2
33600 DO 150 I=MMINA,MMAXA
33601 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
33602 EI=KCHG(IABS(I),1)/3D0
33603 AI=SIGN(1D0,EI)
33604 VI=AI-4D0*EI*XWV
33605 FCOI=1D0
33606 IF(IABS(I).LE.10) FCOI=FACA/3D0
33607 NCHN=NCHN+1
33608 ISIG(NCHN,1)=I
33609 ISIG(NCHN,2)=-I
33610 ISIG(NCHN,3)=1
33611 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
33612 150 CONTINUE
33613
33614 ELSEIF(ISUB.EQ.26) THEN
33615C...f + fbar' -> W+/- + h0 (or H0, or A0)
33616C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
33617 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33618 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33619 GMMW3=SQRT(SQM3)*WDTP(0)
33620 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33621 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
33622 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
33623 GMMH4=SQRT(SQM4)*WDTP(0)
33624 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
33625 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33626 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
33627 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
33628 FACHW=FACHW*WIDS(KFHIGG,2)
33629 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
33630 & PARU(155+10*IHIGG)**2
33631 DO 170 I=MMIN1,MMAX1
33632 IA=IABS(I)
33633 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
33634 DO 160 J=MMIN2,MMAX2
33635 JA=IABS(J)
33636 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
33637 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
33638 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33639 & GOTO 160
33640 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33641 FCKM=1D0
33642 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33643 FCOI=1D0
33644 IF(IA.LE.10) FCOI=FACA/3D0
33645 NCHN=NCHN+1
33646 ISIG(NCHN,1)=I
33647 ISIG(NCHN,2)=J
33648 ISIG(NCHN,3)=1
33649 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
33650 160 CONTINUE
33651 170 CONTINUE
33652
33653 ELSEIF(ISUB.EQ.32) THEN
33654C...f + g -> f + h0 (q + g -> q + h0 only)
33655 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
33656C...H propagator: as simulated in PYOFSH and as desired
33657 SQMHC=PMAS(25,1)**2
33658 GMMHC=PMAS(25,1)*PMAS(25,2)
33659 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
33660 CALL PYWIDT(25,SQM4,WDTP,WDTE)
33661 GMMHCC=SQRT(SQM4)*WDTP(0)
33662 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
33663 FHCQ=FHCQ*HBW4C/HBW4
33664 DO 190 I=MMINA,MMAXA
33665 IA=IABS(I)
33666 IF(IA.NE.5) GOTO 190
33667 SQML=PYMRUN(IA,SH)**2
33668 SQMQ=PMAS(IA,1)**2
33669 FACHCQ=FHCQ*SQML/SQMW*
33670 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
33671 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
33672 & (SQM4-SQMQ-SH)/SH)
33673 DO 180 ISDE=1,2
33674 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
33675 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
33676 NCHN=NCHN+1
33677 ISIG(NCHN,ISDE)=I
33678 ISIG(NCHN,3-ISDE)=21
33679 ISIG(NCHN,3)=1
33680 SIGH(NCHN)=FACHCQ*WIDS(25,2)
33681 180 CONTINUE
33682 190 CONTINUE
33683 ENDIF
33684
33685 ELSEIF(ISUB.LE.80) THEN
33686 IF(ISUB.EQ.71) THEN
33687C...Z0 + Z0 -> Z0 + Z0
33688 IF(SH.LE.4.01D0*SQMZ) GOTO 220
33689
33690 IF(MSTP(46).LE.2) THEN
33691C...Exact scattering ME:s for on-mass-shell gauge bosons
33692 BE2=1D0-4D0*SQMZ/SH
33693 TH=-0.5D0*SH*BE2*(1D0-CTH)
33694 UH=-0.5D0*SH*BE2*(1D0+CTH)
33695 IF(MAX(TH,UH).GT.-1D0) GOTO 220
33696 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
33697 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33698 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33699 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
33700 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33701 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33702 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
33703 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33704 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33705 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33706 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33707 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33708 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
33709 & (ASHIM+ATHIM+AUHIM)**2)
33710 IF(MSTP(46).EQ.2) FACZZ=0D0
33711
33712 ELSE
33713C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33714 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33715 & ABS(A00U+2D0*A20U)**2
33716 ENDIF
33717 FACZZ=FACZZ*WIDS(23,1)
33718
33719 DO 210 I=MMIN1,MMAX1
33720 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
33721 EI=KCHG(IABS(I),1)/3D0
33722 AI=SIGN(1D0,EI)
33723 VI=AI-4D0*EI*XWV
33724 AVI=AI**2+VI**2
33725 DO 200 J=MMIN2,MMAX2
33726 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
33727 EJ=KCHG(IABS(J),1)/3D0
33728 AJ=SIGN(1D0,EJ)
33729 VJ=AJ-4D0*EJ*XWV
33730 AVJ=AJ**2+VJ**2
33731 NCHN=NCHN+1
33732 ISIG(NCHN,1)=I
33733 ISIG(NCHN,2)=J
33734 ISIG(NCHN,3)=1
33735 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
33736 200 CONTINUE
33737 210 CONTINUE
33738 220 CONTINUE
33739
33740 ELSEIF(ISUB.EQ.72) THEN
33741C...Z0 + Z0 -> W+ + W-
33742 IF(SH.LE.4.01D0*SQMZ) GOTO 250
33743
33744 IF(MSTP(46).LE.2) THEN
33745C...Exact scattering ME:s for on-mass-shell gauge bosons
33746 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33747 CTH2=CTH**2
33748 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33749 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33750 IF(MAX(TH,UH).GT.-1D0) GOTO 250
33751 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33752 & (1D0-2D0*SQMZ/SH)
33753 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33754 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33755 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33756 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33757 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33758 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33759 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33760 ATWIM=0D0
33761 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33762 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33763 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33764 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33765 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33766 AUWIM=0D0
33767 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33768 A4IM=0D0
33769 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
33770 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
33771 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
33772 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33773 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33774 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
33775 & (ATWIM+AUWIM+A4IM)**2)
33776
33777 ELSE
33778C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33779 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
33780 & ABS(A00U-A20U)**2
33781 ENDIF
33782 FACWW=FACWW*WIDS(24,1)
33783
33784 DO 240 I=MMIN1,MMAX1
33785 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
33786 EI=KCHG(IABS(I),1)/3D0
33787 AI=SIGN(1D0,EI)
33788 VI=AI-4D0*EI*XWV
33789 AVI=AI**2+VI**2
33790 DO 230 J=MMIN2,MMAX2
33791 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
33792 EJ=KCHG(IABS(J),1)/3D0
33793 AJ=SIGN(1D0,EJ)
33794 VJ=AJ-4D0*EJ*XWV
33795 AVJ=AJ**2+VJ**2
33796 NCHN=NCHN+1
33797 ISIG(NCHN,1)=I
33798 ISIG(NCHN,2)=J
33799 ISIG(NCHN,3)=1
33800 SIGH(NCHN)=FACWW*AVI*AVJ
33801 230 CONTINUE
33802 240 CONTINUE
33803 250 CONTINUE
33804
33805 ELSEIF(ISUB.EQ.73) THEN
33806C...Z0 + W+/- -> Z0 + W+/-
33807 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
33808
33809 IF(MSTP(46).LE.2) THEN
33810C...Exact scattering ME:s for on-mass-shell gauge bosons
33811 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
33812 EP1=1D0-(SQMZ-SQMW)/SH
33813 EP2=1D0+(SQMZ-SQMW)/SH
33814 TH=-0.5D0*SH*BE2*(1D0-CTH)
33815 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
33816 IF(MAX(TH,UH).GT.-1D0) GOTO 280
33817 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
33818 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33819 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33820 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
33821 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
33822 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
33823 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
33824 ASWIM=0D0
33825 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
33826 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
33827 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
33828 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
33829 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
33830 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
33831 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
33832 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
33833 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
33834 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
33835 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
33836 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
33837 AUWIM=0D0
33838 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
33839 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
33840 A4IM=0D0
33841 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
33842 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
33843 IF(MSTP(46).LE.0) FACZW=0D0
33844 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
33845 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
33846 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
33847 & (ASWIM+AUWIM+A4IM)**2)
33848
33849 ELSE
33850C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33851 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
33852 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
33853 ENDIF
33854 FACZW=FACZW*WIDS(23,2)
33855
33856 DO 270 I=MMIN1,MMAX1
33857 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
33858 EI=KCHG(IABS(I),1)/3D0
33859 AI=SIGN(1D0,EI)
33860 VI=AI-4D0*EI*XWV
33861 AVI=AI**2+VI**2
33862 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
33863 DO 260 J=MMIN2,MMAX2
33864 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
33865 EJ=KCHG(IABS(J),1)/3D0
33866 AJ=SIGN(1D0,EJ)
33867 VJ=AI-4D0*EJ*XWV
33868 AVJ=AJ**2+VJ**2
33869 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
33870 NCHN=NCHN+1
33871 ISIG(NCHN,1)=I
33872 ISIG(NCHN,2)=J
33873 ISIG(NCHN,3)=1
33874 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
33875 NCHN=NCHN+1
33876 ISIG(NCHN,1)=I
33877 ISIG(NCHN,2)=J
33878 ISIG(NCHN,3)=2
33879 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
33880 260 CONTINUE
33881 270 CONTINUE
33882 280 CONTINUE
33883
33884 ELSEIF(ISUB.EQ.75) THEN
33885C...W+ + W- -> gamma + gamma
33886
33887 ELSEIF(ISUB.EQ.76) THEN
33888C...W+ + W- -> Z0 + Z0
33889 IF(SH.LE.4.01D0*SQMZ) GOTO 310
33890
33891 IF(MSTP(46).LE.2) THEN
33892C...Exact scattering ME:s for on-mass-shell gauge bosons
33893 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
33894 CTH2=CTH**2
33895 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
33896 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
33897 IF(MAX(TH,UH).GT.-1D0) GOTO 310
33898 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
33899 & (1D0-2D0*SQMZ/SH)
33900 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33901 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33902 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
33903 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33904 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33905 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
33906 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33907 ATWIM=0D0
33908 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
33909 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
33910 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
33911 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
33912 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
33913 AUWIM=0D0
33914 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
33915 A4IM=0D0
33916 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33917 & (SH/SQMW)**2*SH2
33918 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
33919 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
33920 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
33921 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
33922 & (ATWIM+AUWIM+A4IM)**2)
33923
33924 ELSE
33925C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
33926 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
33927 & ABS(A00U-A20U)**2
33928 ENDIF
33929 FACZZ=FACZZ*WIDS(23,1)
33930
33931 DO 300 I=MMIN1,MMAX1
33932 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
33933 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
33934 DO 290 J=MMIN2,MMAX2
33935 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
33936 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
33937 IF(EI*EJ.GT.0D0) GOTO 290
33938 NCHN=NCHN+1
33939 ISIG(NCHN,1)=I
33940 ISIG(NCHN,2)=J
33941 ISIG(NCHN,3)=1
33942 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
33943 290 CONTINUE
33944 300 CONTINUE
33945 310 CONTINUE
33946
33947 ELSEIF(ISUB.EQ.77) THEN
33948C...W+/- + W+/- -> W+/- + W+/-
33949 IF(SH.LE.4.01D0*SQMW) GOTO 340
33950
33951 IF(MSTP(46).LE.2) THEN
33952C...Exact scattering ME:s for on-mass-shell gauge bosons
33953 BE2=1D0-4D0*SQMW/SH
33954 BE4=BE2**2
33955 CTH2=CTH**2
33956 CTH3=CTH**3
33957 TH=-0.5D0*SH*BE2*(1D0-CTH)
33958 UH=-0.5D0*SH*BE2*(1D0+CTH)
33959 IF(MAX(TH,UH).GT.-1D0) GOTO 340
33960 SHANG=(1D0+BE2)**2
33961 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
33962 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
33963 THANG=(BE2-CTH)**2
33964 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
33965 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
33966 UHANG=(BE2+CTH)**2
33967 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
33968 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
33969 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
33970 ASGRE=XW*SGZANG
33971 ASGIM=0D0
33972 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
33973 ASZIM=0D0
33974 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
33975 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
33976 ATGRE=0.5D0*XW*SH/TH*TGZANG
33977 ATGIM=0D0
33978 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
33979 ATZIM=0D0
33980 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
33981 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
33982 AUGRE=0.5D0*XW*SH/UH*UGZANG
33983 AUGIM=0D0
33984 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
33985 AUZIM=0D0
33986 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
33987 A4AIM=0D0
33988 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
33989 A4SIM=0D0
33990 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
33991 & (SH/SQMW)**2*SH2
33992 IF(MSTP(46).LE.0) THEN
33993 AWWARE=ASHRE
33994 AWWAIM=ASHIM
33995 AWWSRE=0D0
33996 AWWSIM=0D0
33997 ELSEIF(MSTP(46).EQ.1) THEN
33998 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
33999 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34000 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34001 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34002 ELSE
34003 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34004 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34005 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34006 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34007 ENDIF
34008 AWWA2=AWWARE**2+AWWAIM**2
34009 AWWS2=AWWSRE**2+AWWSIM**2
34010
34011 ELSE
34012C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34013 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34014 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34015 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34016 ENDIF
34017
34018 DO 330 I=MMIN1,MMAX1
34019 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34020 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34021 DO 320 J=MMIN2,MMAX2
34022 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34023 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34024 IF(EI*EJ.LT.0D0) THEN
34025C...W+W-
34026 IF(MSTP(45).EQ.1) GOTO 320
34027 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34028 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34029 ELSE
34030C...W+W+/W-W-
34031 IF(MSTP(45).EQ.2) GOTO 320
34032 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34033 IF(MSTP(46).GE.3) FACWW=FWWS
34034 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34035 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34036 ENDIF
34037 NCHN=NCHN+1
34038 ISIG(NCHN,1)=I
34039 ISIG(NCHN,2)=J
34040 ISIG(NCHN,3)=1
34041 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34042 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34043 320 CONTINUE
34044 330 CONTINUE
34045 340 CONTINUE
34046 ENDIF
34047
34048 ELSEIF(ISUB.LE.120) THEN
34049 IF(ISUB.EQ.102) THEN
34050C...g + g -> h0 (or H0, or A0)
34051 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34052 HS=SHR*WDTP(0)
34053 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34054 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34055 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34056 & FACBW=0D0
34057C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34058 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34059 WDTP13=0D0
34060 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34061 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34062 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34063 345 CONTINUE
34064 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34065 & '(PYSGHG:) did not find Higgs -> g g channel')
34066 HI=SHR*WDTP13/32D0
34067 ELSE
34068 HI=SHR*WDTP(13)/32D0
34069 ENDIF
34070 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34071 NCHN=NCHN+1
34072 ISIG(NCHN,1)=21
34073 ISIG(NCHN,2)=21
34074 ISIG(NCHN,3)=1
34075 SIGH(NCHN)=HI*FACBW*HF
34076 350 CONTINUE
34077
34078 ELSEIF(ISUB.EQ.103) THEN
34079C...gamma + gamma -> h0 (or H0, or A0)
34080 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34081 HS=SHR*WDTP(0)
34082 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34083 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34084 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34085 & FACBW=0D0
34086C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34087 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34088 WDTP14=0D0
34089 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34090 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34091 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34092 355 CONTINUE
34093 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34094 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34095 HI=SHR*WDTP14*2D0
34096 ELSE
34097 HI=SHR*WDTP(14)*2D0
34098 ENDIF
34099 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34100 NCHN=NCHN+1
34101 ISIG(NCHN,1)=22
34102 ISIG(NCHN,2)=22
34103 ISIG(NCHN,3)=1
34104 SIGH(NCHN)=HI*FACBW*HF
34105 360 CONTINUE
34106
34107 ELSEIF(ISUB.EQ.110) THEN
34108C...f + fbar -> gamma + h0
34109 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34110 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34111 FACHG=FACHG*WIDS(KFHIGG,2)
34112C...Calculate loop contributions for intermediate gamma* and Z0
34113 CIGTOT=DCMPLX(0D0,0D0)
34114 CIZTOT=DCMPLX(0D0,0D0)
34115 JMAX=3*MSTP(1)+1
34116 DO 370 J=1,JMAX
34117 IF(J.LE.2*MSTP(1)) THEN
34118 FNC=1D0
34119 EJ=KCHG(J,1)/3D0
34120 AJ=SIGN(1D0,EJ+0.1D0)
34121 VJ=AJ-4D0*EJ*XWV
34122 BALP=SQM4/(2D0*PMAS(J,1))**2
34123 BBET=SH/(2D0*PMAS(J,1))**2
34124 ELSEIF(J.LE.3*MSTP(1)) THEN
34125 FNC=3D0
34126 JL=2*(J-2*MSTP(1))-1
34127 EJ=KCHG(10+JL,1)/3D0
34128 AJ=SIGN(1D0,EJ+0.1D0)
34129 VJ=AJ-4D0*EJ*XWV
34130 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34131 BBET=SH/(2D0*PMAS(10+JL,1))**2
34132 ELSE
34133 BALP=SQM4/(2D0*PMAS(24,1))**2
34134 BBET=SH/(2D0*PMAS(24,1))**2
34135 ENDIF
34136 BABI=1D0/(BALP-BBET)
34137 IF(BALP.LT.1D0) THEN
34138 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34139 F1ALP=F0ALP**2
34140 ELSE
34141 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34142 & -DBLE(0.5D0*PARU(1)))
34143 F1ALP=-F0ALP**2
34144 ENDIF
34145 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34146 IF(BBET.LT.1D0) THEN
34147 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34148 F1BET=F0BET**2
34149 ELSE
34150 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34151 & -DBLE(0.5D0*PARU(1)))
34152 F1BET=-F0BET**2
34153 ENDIF
34154 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34155 IF(J.LE.3*MSTP(1)) THEN
34156 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34157 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34158 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34159 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34160 ELSE
34161 TXW=XW/XW1
34162 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34163 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34164 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34165 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34166 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34167 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34168 & (F1BET-F1ALP))
34169 ENDIF
34170 370 CONTINUE
34171 CIGTOT=CIGTOT/DBLE(SH)
34172 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34173C...Loop over initial flavours
34174 DO 380 I=MMINA,MMAXA
34175 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34176 EI=KCHG(IABS(I),1)/3D0
34177 AI=SIGN(1D0,EI)
34178 VI=AI-4D0*EI*XWV
34179 FCOI=1D0
34180 IF(IABS(I).LE.10) FCOI=FACA/3D0
34181 NCHN=NCHN+1
34182 ISIG(NCHN,1)=I
34183 ISIG(NCHN,2)=-I
34184 ISIG(NCHN,3)=1
34185 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34186 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34187 380 CONTINUE
34188
34189 ELSEIF(ISUB.EQ.111) THEN
34190C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34191 IF(MSTP(38).NE.0) THEN
34192C...Simple case: only do gg <-> h exactly.
34193 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34194C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34195 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34196 WDTP13=0D0
34197 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34198 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34199 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34200 385 CONTINUE
34201 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34202 & '(PYSGHG:) did not find Higgs -> g g channel')
34203 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34204 & (TH**2+UH**2)/(SH*SQM4)
34205 ELSE
34206 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34207 & (TH**2+UH**2)/(SH*SQM4)
34208 ENDIF
34209C...Propagators: as simulated in PYOFSH and as desired
34210 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34211 GMMHC=SQRT(SQM4)*WDTP(0)
34212 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34213 & ((SQM4-SQMH)**2+GMMHC**2)
34214 FACGH=FACGH*HBW4C/HBW4
34215 ELSE
34216C...Messy case: do full loop integrals
34217 A5STUR=0D0
34218 A5STUI=0D0
34219 DO 390 I=1,2*MSTP(1)
34220 SQMQ=PMAS(I,1)**2
34221 EPSS=4D0*SQMQ/SH
34222 EPSH=4D0*SQMQ/SQMH
34223 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34224 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34225 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34226 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34227 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34228 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34229 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34230 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34231 390 CONTINUE
34232 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34233 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34234 FACGH=FACGH*WIDS(25,2)
34235 ENDIF
34236 DO 400 I=MMINA,MMAXA
34237 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34238 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34239 NCHN=NCHN+1
34240 ISIG(NCHN,1)=I
34241 ISIG(NCHN,2)=-I
34242 ISIG(NCHN,3)=1
34243 SIGH(NCHN)=FACGH
34244 400 CONTINUE
34245
34246 ELSEIF(ISUB.EQ.112) THEN
34247C...f + g -> f + h0 (q + g -> q + h0 only)
34248 IF(MSTP(38).NE.0) THEN
34249C...Simple case: only do gg <-> h exactly.
34250 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34251C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34252 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34253 WDTP13=0D0
34254 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34255 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34256 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34257 405 CONTINUE
34258 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34259 & '(PYSGHG:) did not find Higgs -> g g channel')
34260 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34261 & (SH**2+UH**2)/(-TH*SQM4)
34262 ELSE
34263 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34264 & (SH**2+UH**2)/(-TH*SQM4)
34265 ENDIF
34266C...Propagators: as simulated in PYOFSH and as desired
34267 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34268 GMMHC=SQRT(SQM4)*WDTP(0)
34269 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34270 & ((SQM4-SQMH)**2+GMMHC**2)
34271 FACQH=FACQH*HBW4C/HBW4
34272 ELSE
34273C...Messy case: do full loop integrals
34274 A5TSUR=0D0
34275 A5TSUI=0D0
34276 DO 410 I=1,2*MSTP(1)
34277 SQMQ=PMAS(I,1)**2
34278 EPST=4D0*SQMQ/TH
34279 EPSH=4D0*SQMQ/SQMH
34280 CALL PYWAUX(1,EPST,W1TR,W1TI)
34281 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34282 CALL PYWAUX(2,EPST,W2TR,W2TI)
34283 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34284 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34285 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34286 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34287 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34288 410 CONTINUE
34289 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34290 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34291 FACQH=FACQH*WIDS(25,2)
34292 ENDIF
34293 DO 430 I=MMINA,MMAXA
34294 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34295 DO 420 ISDE=1,2
34296 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34297 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34298 NCHN=NCHN+1
34299 ISIG(NCHN,ISDE)=I
34300 ISIG(NCHN,3-ISDE)=21
34301 ISIG(NCHN,3)=1
34302 SIGH(NCHN)=FACQH
34303 420 CONTINUE
34304 430 CONTINUE
34305
34306 ELSEIF(ISUB.EQ.113) THEN
34307C...g + g -> g + h0
34308 IF(MSTP(38).NE.0) THEN
34309C...Simple case: only do gg <-> h exactly.
34310 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34311C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34312 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34313 WDTP13=0D0
34314 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34315 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34316 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34317 435 CONTINUE
34318 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34319 & '(PYSGHG:) did not find Higgs -> g g channel')
34320 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34321 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34322 ELSE
34323 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34324 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34325 ENDIF
34326C...Propagators: as simulated in PYOFSH and as desired
34327 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34328 GMMHC=SQRT(SQM4)*WDTP(0)
34329 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34330 & ((SQM4-SQMH)**2+GMMHC**2)
34331 FACGH=FACGH*HBW4C/HBW4
34332 ELSE
34333C...Messy case: do full loop integrals
34334 A2STUR=0D0
34335 A2STUI=0D0
34336 A2USTR=0D0
34337 A2USTI=0D0
34338 A2TUSR=0D0
34339 A2TUSI=0D0
34340 A4STUR=0D0
34341 A4STUI=0D0
34342 DO 440 I=1,2*MSTP(1)
34343 SQMQ=PMAS(I,1)**2
34344 EPSS=4D0*SQMQ/SH
34345 EPST=4D0*SQMQ/TH
34346 EPSU=4D0*SQMQ/UH
34347 EPSH=4D0*SQMQ/SQMH
34348 IF(EPSH.LT.1D-6) GOTO 440
34349 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34350 CALL PYWAUX(1,EPST,W1TR,W1TI)
34351 CALL PYWAUX(1,EPSU,W1UR,W1UI)
34352 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34353 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34354 CALL PYWAUX(2,EPST,W2TR,W2TI)
34355 CALL PYWAUX(2,EPSU,W2UR,W2UI)
34356 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34357 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
34358 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
34359 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
34360 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
34361 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
34362 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
34363 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
34364 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
34365 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
34366 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
34367 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
34368 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
34369 W3STUR=YHSTUR-Y3STUR-Y3UTSR
34370 W3STUI=YHSTUI-Y3STUI-Y3UTSI
34371 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
34372 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
34373 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
34374 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
34375 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
34376 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
34377 W3USTR=YHUSTR-Y3USTR-Y3TSUR
34378 W3USTI=YHUSTI-Y3USTI-Y3TSUI
34379 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
34380 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
34381 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
34382 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
34383 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
34384 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
34385 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
34386 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
34387 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
34388 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
34389 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
34390 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
34391 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
34392 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
34393 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
34394 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
34395 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
34396 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
34397 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
34398 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
34399 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
34400 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
34401 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
34402 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
34403 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
34404 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
34405 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
34406 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
34407 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
34408 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
34409 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
34410 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
34411 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
34412 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
34413 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
34414 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
34415 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
34416 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
34417 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
34418 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
34419 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
34420 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
34421 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
34422 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
34423 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
34424 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
34425 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
34426 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
34427 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
34428 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
34429 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
34430 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
34431 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
34432 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
34433 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
34434 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
34435 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
34436 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
34437 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
34438 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
34439 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
34440 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
34441 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34442 & (W2SR-W2HR+W3STUR))
34443 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
34444 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34445 & (W2TR-W2HR+W3TUSR))
34446 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
34447 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
34448 & (W2UR-W2HR+W3USTR))
34449 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
34450 A2STUR=A2STUR+B2STUR+B2SUTR
34451 A2STUI=A2STUI+B2STUI+B2SUTI
34452 A2USTR=A2USTR+B2USTR+B2UTSR
34453 A2USTI=A2USTI+B2USTI+B2UTSI
34454 A2TUSR=A2TUSR+B2TUSR+B2TSUR
34455 A2TUSI=A2TUSI+B2TUSI+B2TSUI
34456 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
34457 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
34458 440 CONTINUE
34459 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
34460 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
34461 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
34462 FACGH=FACGH*WIDS(25,2)
34463 ENDIF
34464 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
34465 NCHN=NCHN+1
34466 ISIG(NCHN,1)=21
34467 ISIG(NCHN,2)=21
34468 ISIG(NCHN,3)=1
34469 SIGH(NCHN)=FACGH
34470 450 CONTINUE
34471 ENDIF
34472
34473 ELSEIF(ISUB.LE.170) THEN
34474 IF(ISUB.EQ.121) THEN
34475C...g + g -> Q + Qbar + h0
34476 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
34477 IA=KFPR(ISUBSV,2)
34478 PMF=PYMRUN(IA,SH)
34479 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34480 & (0.5D0*PMF/PMAS(24,1))**2
34481 WID2=1D0
34482 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34483 FACQQH=FACQQH*WID2
34484 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34485 IKFI=1
34486 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34487 IF(IA.GT.10) IKFI=3
34488 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34489 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34490 FACQQH=FACQQH/(1D0+RMSS(41))**2
34491 IF(IHIGG.NE.3) THEN
34492 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34493 & PARU(151+10*IHIGG))**2
34494 ENDIF
34495 ENDIF
34496 ENDIF
34497 CALL PYQQBH(WTQQBH)
34498 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34499 HS=SHR*WDTP(0)
34500 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34501 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34502 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34503 & FACBW=0D0
34504 NCHN=NCHN+1
34505 ISIG(NCHN,1)=21
34506 ISIG(NCHN,2)=21
34507 ISIG(NCHN,3)=1
34508 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34509 460 CONTINUE
34510
34511 ELSEIF(ISUB.EQ.122) THEN
34512C...q + qbar -> Q + Qbar + h0
34513 IA=KFPR(ISUBSV,2)
34514 PMF=PYMRUN(IA,SH)
34515 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
34516 & (0.5D0*PMF/PMAS(24,1))**2
34517 WID2=1D0
34518 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
34519 FACQQH=FACQQH*WID2
34520 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34521 IKFI=1
34522 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34523 IF(IA.GT.10) IKFI=3
34524 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
34525 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34526 FACQQH=FACQQH/(1D0+RMSS(41))**2
34527 IF(IHIGG.NE.3) THEN
34528 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34529 & PARU(151+10*IHIGG))**2
34530 ENDIF
34531 ENDIF
34532 ENDIF
34533 CALL PYQQBH(WTQQBH)
34534 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34535 HS=SHR*WDTP(0)
34536 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34537 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34538 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34539 & FACBW=0D0
34540 DO 470 I=MMINA,MMAXA
34541 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34542 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
34543 NCHN=NCHN+1
34544 ISIG(NCHN,1)=I
34545 ISIG(NCHN,2)=-I
34546 ISIG(NCHN,3)=1
34547 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
34548 470 CONTINUE
34549
34550 ELSEIF(ISUB.EQ.123) THEN
34551C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
34552C...inner process)
34553 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
34554 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34555 & PARU(154+10*IHIGG)**2
34556 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34557 & (VINT(216)-VINT(209)**2))**2
34558 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34559 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
34560 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34561 HS=SHR*WDTP(0)
34562 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34563 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34564 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34565 & FACBW=0D0
34566 DO 490 I=MMIN1,MMAX1
34567 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
34568 IA=IABS(I)
34569 DO 480 J=MMIN2,MMAX2
34570 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
34571 JA=IABS(J)
34572 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
34573 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
34574 VI=AI-4D0*EI*XWV
34575 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
34576 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
34577 VJ=AJ-4D0*EJ*XWV
34578 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
34579 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
34580 NCHN=NCHN+1
34581 ISIG(NCHN,1)=I
34582 ISIG(NCHN,2)=J
34583 ISIG(NCHN,3)=1
34584 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
34585 480 CONTINUE
34586 490 CONTINUE
34587
34588 ELSEIF(ISUB.EQ.124) THEN
34589C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
34590C...inner process)
34591 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
34592 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
34593 & PARU(155+10*IHIGG)**2
34594 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
34595 & (VINT(216)-VINT(209)**2))**2
34596 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
34597 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34598 HS=SHR*WDTP(0)
34599 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34600 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
34601 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34602 & FACBW=0D0
34603 DO 510 I=MMIN1,MMAX1
34604 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
34605 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34606 DO 500 J=MMIN2,MMAX2
34607 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
34608 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34609 IF(EI*EJ.GT.0D0) GOTO 500
34610 FACLR=VINT(180+I)*VINT(180+J)
34611 NCHN=NCHN+1
34612 ISIG(NCHN,1)=I
34613 ISIG(NCHN,2)=J
34614 ISIG(NCHN,3)=1
34615 SIGH(NCHN)=FACLR*FACWW*FACBW
34616 500 CONTINUE
34617 510 CONTINUE
34618
34619 ELSEIF(ISUB.EQ.143) THEN
34620C...f + fbar' -> H+/-
34621 SQMHC=PMAS(37,1)**2
34622 CALL PYWIDT(37,SH,WDTP,WDTE)
34623 HS=SHR*WDTP(0)
34624 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
34625 HP=AEM/(8D0*XW)*SH/SQMW*SH
34626 DO 530 I=MMIN1,MMAX1
34627 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
34628 IA=IABS(I)
34629 IM=(MOD(IA,10)+1)/2
34630 DO 520 J=MMIN2,MMAX2
34631 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
34632 JA=IABS(J)
34633 JM=(MOD(JA,10)+1)/2
34634 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
34635 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34636 & GOTO 520
34637 IF(MOD(IA,2).EQ.0) THEN
34638 IU=IA
34639 IL=JA
34640 ELSE
34641 IU=JA
34642 IL=IA
34643 ENDIF
34644 RML=PYMRUN(IL,SH)**2/SH
34645 RMU=PYMRUN(IU,SH)**2/SH
34646 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
34647 IF(IA.LE.10) HI=HI*FACA/3D0
34648 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34649 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
34650 NCHN=NCHN+1
34651 ISIG(NCHN,1)=I
34652 ISIG(NCHN,2)=J
34653 ISIG(NCHN,3)=1
34654 SIGH(NCHN)=HI*FACBW*HF
34655 520 CONTINUE
34656 530 CONTINUE
34657
34658 ELSEIF(ISUB.EQ.161) THEN
34659C...f + g -> f' + H+/- (b + g -> t + H+/- only)
34660C...(choice of only b and t to avoid kinematics problems)
34661 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
34662C...H propagator: as simulated in PYOFSH and as desired
34663 SQMHC=PMAS(37,1)**2
34664 GMMHC=PMAS(37,1)*PMAS(37,2)
34665 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34666 CALL PYWIDT(37,SQM4,WDTP,WDTE)
34667 GMMHCC=SQRT(SQM4)*WDTP(0)
34668 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34669 FHCQ=FHCQ*HBW4C/HBW4
34670 Q2RM=SH
34671 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
34672 DO 550 I=MMINA,MMAXA
34673 IA=IABS(I)
34674 IF(IA.NE.5) GOTO 550
34675 SQML=PYMRUN(IA,Q2RM)**2
34676 IUA=IA+MOD(IA,2)
34677 SQMQ=PYMRUN(IUA,Q2RM)**2
34678 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
34679 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34680 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
34681 & (SQMHC-SQMQ-SH)/SH)
34682 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34683 DO 540 ISDE=1,2
34684 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
34685 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
34686 NCHN=NCHN+1
34687 ISIG(NCHN,ISDE)=I
34688 ISIG(NCHN,3-ISDE)=21
34689 ISIG(NCHN,3)=1
34690 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
34691 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
34692 540 CONTINUE
34693 550 CONTINUE
34694 ENDIF
34695
34696 ELSEIF(ISUB.LE.402) THEN
34697 IF(ISUB.EQ.401) THEN
34698C... g + g -> t + bbar + H-
34699 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
34700 IA=KFPR(ISUBSV,2)
34701 CALL PYSTBH(WTTBH)
34702 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34703 HS=SHR*WDTP(0)
34704 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34705 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34706 & FACBW=0D0
34707 NCHN=NCHN+1
34708 ISIG(NCHN,1)=21
34709 ISIG(NCHN,2)=21
34710 ISIG(NCHN,3)=1
34711 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34712c Since we don't know yet if H+ or H-, assume H+
34713c when calculating suppression due to closed channels.
34714 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34715 IF(ABS(WIDS(37,2)-WIDS(37,3))
34716 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
34717 & ABS(WIDS(6,2)-WIDS(6,3))
34718 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
34719 WRITE(*,*)'Error: Process 401 cannot handle different'
34720 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34721 WRITE(*,*)'Execution stopped.'
34722 CALL PYSTOP(108)
34723 END IF
34724 560 CONTINUE
34725
34726 ELSEIF(ISUB.EQ.402) THEN
34727C... q + qbar -> t + bbar + H-
34728 IA=KFPR(ISUBSV,2)
34729 CALL PYSTBH(WTTBH)
34730 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34731 HS=SHR*WDTP(0)
34732 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
34733 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34734 & FACBW=0D0
34735 DO 570 I=MMINA,MMAXA
34736 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34737 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
34738 NCHN=NCHN+1
34739 ISIG(NCHN,1)=I
34740 ISIG(NCHN,2)=-I
34741 ISIG(NCHN,3)=1
34742 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
34743c Since we don't know yet if H+ or H-, assume H+
34744c when calculating suppression due to closed channels.
34745 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
34746 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
34747 & .GE.1D-6.OR.
34748 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
34749 & .GE.1D-6) THEN
34750 WRITE(*,*)'Error: Process 402 cannot handle different'
34751 WRITE(*,*)'decays for H+ and H- or t and tbar.'
34752 WRITE(*,*)'Execution stopped.'
34753 CALL PYSTOP(108)
34754 END IF
34755 570 CONTINUE
34756 ENDIF
34757 ENDIF
34758
34759 RETURN
34760 END
34761
34762C*********************************************************************
34763
34764C...PYSGSU
34765C...Subprocess cross sections for SUSY processes,
34766C...including Higgs pair production.
34767C...Auxiliary to PYSIGH.
34768
34769 SUBROUTINE PYSGSU(NCHN,SIGS)
34770
34771C...Double precision and integer declarations
34772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34773 IMPLICIT INTEGER(I-N)
34774 INTEGER PYK,PYCHGE,PYCOMP
34775C...Parameter statement to help give large particle numbers.
34776 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34777 &KEXCIT=4000000,KDIMEN=5000000)
34778C...Commonblocks
34779 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34780 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34781 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34782 COMMON/PYINT1/MINT(400),VINT(400)
34783 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34784 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34785 COMMON/PYINT4/MWID(500),WIDS(500,5)
34786 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34787 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
34788 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
34789 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34790 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34791 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34792 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34793 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
34794 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
34795C...Local arrays and complex variables
34796 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34797 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
34798 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
34799 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
34800
34801CMRENNA++
34802C...Z and W width, combinations of weak mixing angle
34803 ZWID=PMAS(23,2)
34804 WWID=PMAS(24,2)
34805 TANW=SQRT(XW/XW1)
34806 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
34807
34808C...Convert almost equivalent SUSY processes into each other
34809C...Extract differences in flavours and couplings
34810
34811C...Sleptons and sneutrinos
34812 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
34813 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34814 ISUB=201
34815 ILR=0
34816 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
34817 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34818 ISUB=201
34819 ILR=1
34820 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
34821 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34822 ISUB=203
34823 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
34824 IF(ISUB.EQ.210) THEN
34825 RKF=2.0D0
34826 ELSEIF(ISUB.EQ.211) THEN
34827 RKF=SFMIX(15,1)**2
34828 ELSEIF(ISUB.EQ.212) THEN
34829 RKF=SFMIX(15,2)**2
34830 ENDIF
34831 ISUB=210
34832 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
34833 IF(ISUB.EQ.213) THEN
34834 KFID=MOD(KFPR(ISUB,1),KSUSY1)
34835 RKF=2.0D0
34836 ELSEIF(ISUB.EQ.214) THEN
34837 KFID=16
34838 RKF=1.0D0
34839 ENDIF
34840 ISUB=213
34841
34842C...Neutralinos
34843 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
34844 IF(ISUB.EQ.216) THEN
34845 IZID1=1
34846 IZID2=1
34847 ELSEIF(ISUB.EQ.217) THEN
34848 IZID1=2
34849 IZID2=2
34850 ELSEIF(ISUB.EQ.218) THEN
34851 IZID1=3
34852 IZID2=3
34853 ELSEIF(ISUB.EQ.219) THEN
34854 IZID1=4
34855 IZID2=4
34856 ELSEIF(ISUB.EQ.220) THEN
34857 IZID1=1
34858 IZID2=2
34859 ELSEIF(ISUB.EQ.221) THEN
34860 IZID1=1
34861 IZID2=3
34862 ELSEIF(ISUB.EQ.222) THEN
34863 IZID1=1
34864 IZID2=4
34865 ELSEIF(ISUB.EQ.223) THEN
34866 IZID1=2
34867 IZID2=3
34868 ELSEIF(ISUB.EQ.224) THEN
34869 IZID1=2
34870 IZID2=4
34871 ELSEIF(ISUB.EQ.225) THEN
34872 IZID1=3
34873 IZID2=4
34874 ENDIF
34875 ISUB=216
34876
34877C...Charginos
34878 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
34879 IF(ISUB.EQ.226) THEN
34880 IZID1=1
34881 IZID2=1
34882 ELSEIF(ISUB.EQ.227) THEN
34883 IZID1=2
34884 IZID2=2
34885 ELSEIF(ISUB.EQ.228) THEN
34886 IZID1=1
34887 IZID2=2
34888 ENDIF
34889 ISUB=226
34890
34891C...Neutralino + chargino
34892 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
34893 IF(ISUB.EQ.229) THEN
34894 IZID1=1
34895 IZID2=1
34896 ELSEIF(ISUB.EQ.230) THEN
34897 IZID1=1
34898 IZID2=2
34899 ELSEIF(ISUB.EQ.231) THEN
34900 IZID1=1
34901 IZID2=3
34902 ELSEIF(ISUB.EQ.232) THEN
34903 IZID1=1
34904 IZID2=4
34905 ELSEIF(ISUB.EQ.233) THEN
34906 IZID1=2
34907 IZID2=1
34908 ELSEIF(ISUB.EQ.234) THEN
34909 IZID1=2
34910 IZID2=2
34911 ELSEIF(ISUB.EQ.235) THEN
34912 IZID1=2
34913 IZID2=3
34914 ELSEIF(ISUB.EQ.236) THEN
34915 IZID1=2
34916 IZID2=4
34917 ENDIF
34918 ISUB=229
34919
34920C...Gluino + neutralino
34921 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
34922 IF(ISUB.EQ.237) THEN
34923 IZID=1
34924 ELSEIF(ISUB.EQ.238) THEN
34925 IZID=2
34926 ELSEIF(ISUB.EQ.239) THEN
34927 IZID=3
34928 ELSEIF(ISUB.EQ.240) THEN
34929 IZID=4
34930 ENDIF
34931 ISUB=237
34932
34933C...Gluino + chargino
34934 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
34935 IF(ISUB.EQ.241) THEN
34936 IZID=1
34937 ELSEIF(ISUB.EQ.242) THEN
34938 IZID=2
34939 ENDIF
34940 ISUB=241
34941
34942C...Squark + neutralino
34943 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
34944 ILR=0
34945 IF(MOD(ISUB,2).NE.0) ILR=1
34946 IF(ISUB.LE.247) THEN
34947 IZID=1
34948 ELSEIF(ISUB.LE.249) THEN
34949 IZID=2
34950 ELSEIF(ISUB.LE.251) THEN
34951 IZID=3
34952 ELSEIF(ISUB.LE.253) THEN
34953 IZID=4
34954 ENDIF
34955 ISUB=246
34956 RKF=5D0
34957
34958C...Squark + chargino
34959 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
34960 IF(ISUB.LE.255) THEN
34961 IZID=1
34962 ELSEIF(ISUB.LE.257) THEN
34963 IZID=2
34964 ENDIF
34965 IF(MOD(ISUB,2).EQ.0) THEN
34966 ILR=0
34967 ELSE
34968 ILR=1
34969 ENDIF
34970 ISUB=254
34971 RKF=5D0
34972
34973C...Squark + gluino
34974 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
34975 ISUB=258
34976 RKF=4D0
34977
34978C...Stops
34979 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
34980 ILR=0
34981 IF(ISUB.EQ.262) ILR=1
34982 ISUB=261
34983 ELSEIF(ISUB.EQ.265) THEN
34984 ISUB=264
34985
34986C...Squarks
34987 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
34988 ILR=0
34989 IF(ISUB.LE.273) THEN
34990 IF(ISUB.EQ.273) ILR=1
34991 ISUB=271
34992 RKF=16D0
34993 ELSEIF(ISUB.LE.276) THEN
34994 IF(ISUB.EQ.276) ILR=1
34995 ISUB=274
34996 RKF=16D0
34997 ELSEIF(ISUB.LE.278) THEN
34998 IF(ISUB.EQ.278) ILR=1
34999 ISUB=277
35000 RKF=4D0
35001 ELSE
35002 IF(ISUB.EQ.280) ILR=1
35003 ISUB=279
35004 RKF=4D0
35005 ENDIF
35006C...Sbottoms
35007 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35008 ILR=0
35009 IF(ISUB.LE.283) THEN
35010 IF(ISUB.EQ.283) ILR=1
35011 ISUB=271
35012 RKF=4D0
35013 ELSEIF(ISUB.LE.286) THEN
35014 IF(ISUB.EQ.286) ILR=1
35015 ISUB=274
35016 RKF=4D0
35017 ELSEIF(ISUB.LE.288) THEN
35018 IF(ISUB.EQ.288) ILR=1
35019 ISUB=277
35020 RKF=1D0
35021 ELSEIF(ISUB.LE.290) THEN
35022 IF(ISUB.EQ.290) ILR=1
35023 ISUB=279
35024 RKF=1D0
35025 ELSEIF(ISUB.LE.293) THEN
35026 IF(ISUB.EQ.293) ILR=1
35027 ISUB=271
35028 RKF=1D0
35029 ELSEIF(ISUB.EQ.296) THEN
35030 ILR=1
35031 ISUB=274
35032 RKF=1D0
35033C...Squark + gluino
35034 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35035 ISUB=258
35036 RKF=1D0
35037 ENDIF
35038C...H+/- + H0
35039 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35040 IF(ISUB.EQ.297) THEN
35041 RKF=.5D0*PARU(195)**2
35042 ELSEIF(ISUB.EQ.298) THEN
35043 RKF=.5D0*(1D0-PARU(195)**2)
35044 ENDIF
35045 ISUB=210
35046C...A0 + H0
35047 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35048 IF(ISUB.EQ.299) THEN
35049 RKF=PARU(186)**2
35050 KFID=25
35051 ELSEIF(ISUB.EQ.300) THEN
35052 RKF=PARU(187)**2
35053 KFID=35
35054 ENDIF
35055 ISUB=213
35056C...H+ + H-
35057 ELSEIF(ISUB.EQ.301) THEN
35058 KFID=37
35059 RKF=1D0
35060 ISUB=201
35061 ENDIF
35062
35063C...Supersymmetric processes - all of type 2 -> 2 :
35064C...correct final-state Breit-Wigners from fixed to running width.
35065 IF(MSTP(42).GT.0) THEN
35066 DO 100 I=1,2
35067 KFLW=KFPR(ISUBSV,I)
35068 KCW=PYCOMP(KFLW)
35069 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35070 IF(I.EQ.1) SQMI=SQM3
35071 IF(I.EQ.2) SQMI=SQM4
35072 SQMS=PMAS(KCW,1)**2
35073 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35074 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35075 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35076 GMMI=SQRT(SQMI)*WDTP(0)
35077 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35078 COMFAC=COMFAC*(HBWI/HBWS)
35079 100 CONTINUE
35080 ENDIF
35081
35082C...Differential cross section expressions.
35083
35084 IF(ISUB.LE.210) THEN
35085 IF(ISUB.EQ.201) THEN
35086C...f + fbar -> e_L + e_Lbar
35087 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35088 DO 130 I=MMIN1,MMAX1
35089 IA=IABS(I)
35090 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35091 EI=KCHG(IA,1)/3D0
35092 TT3I=SIGN(1D0,EI+1D-6)/2D0
35093 EJ=-1D0
35094 TT3J=-1D0/2D0
35095 FCOL=1D0
35096C...Color factor for e+ e-
35097 IF(IA.GE.11) FCOL=3D0
35098 IF(ISUBSV.EQ.301) THEN
35099 A1=1D0
35100 A2=0D0
35101 ELSEIF(ILR.EQ.1) THEN
35102 A1=SFMIX(KFID,3)**2
35103 A2=SFMIX(KFID,4)**2
35104 ELSEIF(ILR.EQ.0) THEN
35105 A1=SFMIX(KFID,1)**2
35106 A2=SFMIX(KFID,2)**2
35107 ENDIF
35108 XLQ=(TT3J-EJ*XW)*A1
35109 XRQ=(-EJ*XW)*A2
35110 XLF=(TT3I-EI*XW)
35111 XRF=(-EI*XW)
35112 TAA=(EI*EJ)**2*(POLL+POLR)
35113 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35114 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35115 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35116 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35117 TNN=0.0D0
35118 TAN=0.0D0
35119 TZN=0.0D0
35120 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35121 FAC2=SQRT(2D0)
35122 TNN1=0D0
35123 TNN2=0D0
35124 TNN3=0D0
35125 DO 120 II=1,4
35126 DK=1D0/(TH-SMZ(II)**2)
35127 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35128 & ZMIX(II,1))
35129 FREK=FAC2*TANW*EI*ZMIX(II,1)
35130 TNN1=TNN1+FLEK**2*DK
35131 TNN2=TNN2+FREK**2*DK
35132 DO 110 JJ=1,4
35133 DL=1D0/(TH-SMZ(JJ)**2)
35134 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35135 & ZMIX(JJ,1))
35136 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35137 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35138 110 CONTINUE
35139 120 CONTINUE
35140 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35141 & A2**2*TNN2**2*POLR)
35142 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35143 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35144 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35145 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35146 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35147 & (1D0-SQMZ/SH)/SH
35148 TZN=TZN/XW**2/XW1
35149 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35150 & A2*TNN2*POLR)/XW
35151 ENDIF
35152 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35153 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35154 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35155 NCHN=NCHN+1
35156 ISIG(NCHN,1)=I
35157 ISIG(NCHN,2)=-I
35158 ISIG(NCHN,3)=1
35159 SIGH(NCHN)=FACQQ1+FACQQ2
35160 130 CONTINUE
35161
35162 ELSEIF(ISUB.EQ.203) THEN
35163C...f + fbar -> e_L + e_Rbar
35164 DO 160 I=MMIN1,MMAX1
35165 IA=IABS(I)
35166 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35167 EI=KCHG(IABS(I),1)/3D0
35168 TT3I=SIGN(1D0,EI)/2D0
35169 EJ=-1
35170 TT3J=-1D0/2D0
35171 FCOL=1D0
35172C...Color factor for e+ e-
35173 IF(IA.GE.11) FCOL=3D0
35174 A1=SFMIX(KFID,1)**2
35175 A2=SFMIX(KFID,2)**2
35176 XLQ=(TT3J-EJ*XW)
35177 XRQ=(-EJ*XW)
35178 XLF=(TT3I-EI*XW)
35179 XRF=(-EI*XW)
35180 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35181 & /XW**2/XW1**2*A1*A2
35182 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35183 TNN=0.0D0
35184 TZN=0.0D0
35185 TNNA=0D0
35186 TNNB=0D0
35187 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35188 FAC2=SQRT(2D0)
35189 TNN1=0D0
35190 TNN2=0D0
35191 TNN3=0D0
35192 DO 150 II=1,4
35193 DK=1D0/(TH-SMZ(II)**2)
35194 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35195 & ZMIX(II,1))
35196 FREK=FAC2*TANW*EI*ZMIX(II,1)
35197 TNN1=TNN1+FLEK**2*DK
35198 TNN2=TNN2+FREK**2*DK
35199 DO 140 JJ=1,4
35200 DL=1D0/(TH-SMZ(JJ)**2)
35201 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35202 & ZMIX(JJ,1))
35203 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35204 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35205 140 CONTINUE
35206 150 CONTINUE
35207 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35208 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35209 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35210 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35211 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35212 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35213 & (1D0-SQMZ/SH)/SH
35214 ENDIF
35215 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35216 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35217 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35218C%%%%%%%%%%%
35219 NCHN=NCHN+1
35220 ISIG(NCHN,1)=I
35221 ISIG(NCHN,2)=-I
35222 ISIG(NCHN,3)=1
35223 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35224 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35225 NCHN=NCHN+1
35226 ISIG(NCHN,1)=I
35227 ISIG(NCHN,2)=-I
35228 ISIG(NCHN,3)=2
35229 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35230 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35231 160 CONTINUE
35232
35233 ELSEIF(ISUB.EQ.210) THEN
35234C...q + qbar' -> W*- > ~l_L + ~nu_L
35235 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35236 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35237 DO 180 I=MMIN1,MMAX1
35238 IA=IABS(I)
35239 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35240 DO 170 J=MMIN2,MMAX2
35241 JA=IABS(J)
35242 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35243 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35244 FCKM=3D0
35245 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35246 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35247 KCHW=2
35248 IF(KCHSUM.LT.0) KCHW=3
35249 NCHN=NCHN+1
35250 ISIG(NCHN,1)=I
35251 ISIG(NCHN,2)=J
35252 ISIG(NCHN,3)=1
35253 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35254 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35255 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35256 ELSE
35257 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35258 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35259 ENDIF
35260 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35261 170 CONTINUE
35262 180 CONTINUE
35263 ENDIF
35264
35265 ELSEIF(ISUB.LE.220) THEN
35266 IF(ISUB.EQ.213) THEN
35267C...f + fbar -> ~nu_L + ~nu_Lbar
35268 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35269 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35270 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35271 ELSE
35272 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35273 ENDIF
35274 COMFAC=COMFAC*FACR
35275 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35276 XLL=0.5D0
35277 XLR=0.0D0
35278 DO 190 I=MMIN1,MMAX1
35279 IA=IABS(I)
35280 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35281 EI=KCHG(IA,1)/3D0
35282 FCOL=1D0
35283C...Color factor for e+ e-
35284 IF(IA.GE.11) FCOL=3D0
35285 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35286 XRQ=-EI*XW
35287 TZC=0.0D0
35288 TCC=0.0D0
35289 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35290 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35291 & (TH-SMW(2)**2)
35292 TCC=TZC**2
35293 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35294 ENDIF
35295 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35296 FACQQ2=TZC+TCC/4D0
35297 NCHN=NCHN+1
35298 ISIG(NCHN,1)=I
35299 ISIG(NCHN,2)=-I
35300 ISIG(NCHN,3)=1
35301 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35302 & *AEM**2*FCOL/3D0/XW**2
35303 190 CONTINUE
35304
35305 ELSEIF(ISUB.EQ.216) THEN
35306C...q + qbar -> ~chi0_1 + ~chi0_1
35307 IF(IZID1.EQ.IZID2) THEN
35308 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35309 ELSE
35310 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35311 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35312 ENDIF
35313 FACXX=COMFAC*AEM**2/3D0/XW**2
35314 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35315 ZM12=SQM3
35316 ZM22=SQM4
35317 WU2 = (UH-ZM12)*(UH-ZM22)
35318 WT2 = (TH-ZM12)*(TH-ZM22)
35319 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35320 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35321 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35322 DO 200 I=1,4
35323 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35324 IF(IZID2.NE.IZID1) THEN
35325 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35326 ENDIF
35327 200 CONTINUE
35328 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35329 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35330 ORPP=DCONJG(OLPP)
35331 DO 210 I=MMINA,MMAXA
35332 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35333 EI=KCHG(IABS(I),1)/3D0
35334 T3I=SIGN(1D0,EI+1D-6)/2D0
35335 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
35336 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
35337 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
35338 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
35339 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
35340 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
35341 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
35342 & /DCMPLX(TH-XML2)
35343 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
35344 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
35345 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
35346 FCOL=1D0
35347 IF(IABS(I).GE.11) FCOL=3D0
35348 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35349 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35350 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35351 & QRL*DCONJG(QRR)*POLR)*WS2
35352 NCHN=NCHN+1
35353 ISIG(NCHN,1)=I
35354 ISIG(NCHN,2)=-I
35355 ISIG(NCHN,3)=1
35356 SIGH(NCHN)=FACXX*FACGG1*FCOL
35357 210 CONTINUE
35358 ENDIF
35359
35360 ELSEIF(ISUB.LE.230) THEN
35361 IF(ISUB.EQ.226) THEN
35362C...f + fbar -> ~chi+_1 + ~chi-_1
35363 FACXX=COMFAC*AEM**2/3D0
35364 ZM12=SQM3
35365 ZM22=SQM4
35366 WU2 = (UH-ZM12)*(UH-ZM22)
35367 WT2 = (TH-ZM12)*(TH-ZM22)
35368 WS2 = SMW(IZID1)*SMW(IZID2)*SH
35369 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35370 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35371 DIFF=0D0
35372 IF(IZID1.EQ.IZID2) DIFF=1D0
35373 DO 220 I=1,2
35374 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35375 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35376 IF(IZID2.NE.IZID1) THEN
35377 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
35378 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
35379 ENDIF
35380 220 CONTINUE
35381 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
35382 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
35383 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
35384 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
35385 DO 230 I=MMINA,MMAXA
35386 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
35387 EI=KCHG(IABS(I),1)/3D0
35388 T3I=SIGN(1D0,EI+1D-6)/2D0
35389 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
35390 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
35391 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
35392 IF(MOD(I,2).EQ.0) THEN
35393 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
35394 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35395 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
35396 & DCMPLX(T3I/XW/(TH-XML2))
35397 ELSE
35398 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
35399 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
35400 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
35401 & DCMPLX(T3I/XW/(TH-XML2))
35402 ENDIF
35403 FCOL=1D0
35404 IF(IABS(I).GE.11) FCOL=3D0
35405 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
35406 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
35407 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
35408 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
35409 NCHN=NCHN+1
35410 ISIG(NCHN,1)=I
35411 ISIG(NCHN,2)=-I
35412 ISIG(NCHN,3)=1
35413 IF(IZID1.EQ.IZID2) THEN
35414 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35415 ELSE
35416 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35417 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35418 NCHN=NCHN+1
35419 ISIG(NCHN,1)=I
35420 ISIG(NCHN,2)=-I
35421 ISIG(NCHN,3)=2
35422 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35423 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35424 ENDIF
35425 230 CONTINUE
35426
35427 ELSEIF(ISUB.EQ.229) THEN
35428C...q + qbar' -> ~chi0_1 + ~chi+-_1
35429 FACXX=COMFAC*AEM**2/6D0/XW**2
35430 ZM12=SQM3
35431 ZM22=SQM4
35432 WU2 = (UH-ZM12)*(UH-ZM22)
35433 WT2 = (TH-ZM12)*(TH-ZM22)
35434 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
35435 RT2I = 1D0/SQRT(2D0)
35436 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
35437 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
35438 DO 240 I=1,2
35439 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
35440 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
35441 240 CONTINUE
35442 DO 250 I=1,4
35443 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35444 250 CONTINUE
35445 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
35446 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
35447 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
35448 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
35449
35450 DO 270 I=MMIN1,MMAX1
35451 IA=IABS(I)
35452 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
35453 EI=KCHG(IA,1)/3D0
35454 T3I=SIGN(1D0,EI+1D-6)/2D0
35455 DO 260 J=MMIN2,MMAX2
35456 JA=IABS(J)
35457 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
35458 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
35459 EJ=KCHG(JA,1)/3D0
35460 T3J=SIGN(1D0,EJ+1D-6)/2D0
35461 FCKM=3D0
35462 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35463 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35464 KCHW=2
35465 IF(KCHSUM.LT.0) KCHW=3
35466 IF(MOD(IA,2).EQ.0) THEN
35467 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35468 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35469 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
35470 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
35471 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35472 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
35473 & /DCMPLX(TH-ZMJ2)
35474 ELSE
35475 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
35476 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
35477 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
35478 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
35479 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
35480 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
35481 & /DCMPLX(TH-ZMI2)
35482 ENDIF
35483 ZINTR=DBLE(QLR*DCONJG(QLL))
35484 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
35485 & 2D0*ZINTR*WS2)
35486 NCHN=NCHN+1
35487 ISIG(NCHN,1)=I
35488 ISIG(NCHN,2)=J
35489 ISIG(NCHN,3)=1
35490 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35491 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35492 260 CONTINUE
35493 270 CONTINUE
35494 ENDIF
35495
35496 ELSEIF(ISUB.LE.240) THEN
35497 IF(ISUB.EQ.237) THEN
35498C...q + qbar -> gluino + ~chi0_1
35499 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35500 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35501 ASYUK=RMSS(42)*AS
35502 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
35503 GM2=SQM3
35504 ZM2=SQM4
35505 DO 280 I=MMINA,MMAXA
35506 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 280
35507 EI=KCHG(IABS(I),1)/3D0
35508 IA=IABS(I)
35509 XLQC = -TANW*EI*ZMIX(IZID,1)
35510 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35511 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35512 XLQ2=XLQC**2
35513 XRQ2=XRQC**2
35514 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
35515 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
35516 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
35517 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
35518 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
35519 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35520 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
35521 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
35522 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
35523 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
35524 NCHN=NCHN+1
35525 ISIG(NCHN,1)=I
35526 ISIG(NCHN,2)=-I
35527 ISIG(NCHN,3)=1
35528 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
35529 280 CONTINUE
35530 ENDIF
35531
35532 ELSEIF(ISUB.LE.250) THEN
35533 IF(ISUB.EQ.241) THEN
35534C...q + qbar' -> ~chi+-_1 + gluino
35535 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
35536 GM2=SQM3
35537 ZM2=SQM4
35538 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
35539 FAC0=UMIX(IZID,1)**2
35540 FAC1=VMIX(IZID,1)**2
35541 DO 300 I=MMIN1,MMAX1
35542 IA=IABS(I)
35543 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
35544 DO 290 J=MMIN2,MMAX2
35545 JA=IABS(J)
35546 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
35547 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
35548 FCKM=1D0
35549 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35550 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35551 KCHW=2
35552 IF(KCHSUM.LT.0) KCHW=3
35553 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
35554 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
35555 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
35556 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
35557 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
35558 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
35559 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
35560 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
35561 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
35562 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
35563 & SH/(TH-XMU2)/(UH-XMD2))/2D0
35564 NCHN=NCHN+1
35565 ISIG(NCHN,1)=I
35566 ISIG(NCHN,2)=J
35567 ISIG(NCHN,3)=1
35568 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
35569 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35570 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35571 290 CONTINUE
35572 300 CONTINUE
35573
35574 ELSEIF(ISUB.EQ.243) THEN
35575C...q + qbar -> gluino + gluino
35576 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35577 XMT=SQM3-TH
35578 XMU=SQM3-UH
35579 DO 310 I=MMINA,MMAXA
35580 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35581 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
35582 NCHN=NCHN+1
35583 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
35584 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
35585 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35586 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35587 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35588 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35589 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
35590 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
35591 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
35592 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
35593 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
35594 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
35595 ISIG(NCHN,1)=I
35596 ISIG(NCHN,2)=-I
35597 ISIG(NCHN,3)=1
35598C...1/2 for identical particles
35599 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
35600 310 CONTINUE
35601
35602 ELSEIF(ISUB.EQ.244) THEN
35603C...g + g -> gluino + gluino
35604 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35605 XMT=SQM3-TH
35606 XMU=SQM3-UH
35607 FACQQ1=COMFAC*AS**2*9D0/4D0*(
35608 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
35609 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
35610 FACQQ2=COMFAC*AS**2*9D0/4D0*(
35611 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
35612 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
35613 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
35614 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
35615 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
35616 NCHN=NCHN+1
35617 ISIG(NCHN,1)=21
35618 ISIG(NCHN,2)=21
35619 ISIG(NCHN,3)=1
35620 SIGH(NCHN)=FACQQ1/2D0
35621 NCHN=NCHN+1
35622 ISIG(NCHN,1)=21
35623 ISIG(NCHN,2)=21
35624 ISIG(NCHN,3)=2
35625 SIGH(NCHN)=FACQQ2/2D0
35626 NCHN=NCHN+1
35627 ISIG(NCHN,1)=21
35628 ISIG(NCHN,2)=21
35629 ISIG(NCHN,3)=3
35630 SIGH(NCHN)=FACQQ3/2D0
35631 320 CONTINUE
35632
35633 ELSEIF(ISUB.EQ.246) THEN
35634C...g + q_j -> ~chi0_1 + ~q_j
35635 FAC0=COMFAC*AS*AEM/6D0/XW
35636 ZM2=SQM4
35637 QM2=SQM3
35638 FACZQ0=FAC0*( (ZM2-TH)/SH +
35639 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35640 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35641 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35642 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
35643 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
35644 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
35645 EI=KCHG(IABS(I),1)/3D0
35646 IA=IABS(I)
35647 XRQZ = -TANW*EI*ZMIX(IZID,1)
35648 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
35649 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
35650 IF(ILR.EQ.0) THEN
35651 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
35652 ELSE
35653 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
35654 ENDIF
35655 FACZQ=FACZQ0*BS
35656 KCHQ=2
35657 IF(I.LT.0) KCHQ=3
35658 DO 330 ISDE=1,2
35659 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
35660 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
35661 NCHN=NCHN+1
35662 ISIG(NCHN,ISDE)=I
35663 ISIG(NCHN,3-ISDE)=21
35664 ISIG(NCHN,3)=1
35665 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35666 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35667 330 CONTINUE
35668 340 CONTINUE
35669 ENDIF
35670
35671 ELSEIF(ISUB.LE.260) THEN
35672 IF(ISUB.EQ.254) THEN
35673C...g + q_j -> ~chi1_1 + ~q_i
35674 FAC0=COMFAC*AS*AEM/12D0/XW
35675 ZM2=SQM4
35676 QM2=SQM3
35677 AU=UMIX(IZID,1)**2
35678 AD=VMIX(IZID,1)**2
35679 FACZQ0=FAC0*( (ZM2-TH)/SH +
35680 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
35681 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
35682 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
35683 IF(MOD(KFNSQ1,2).EQ.0) THEN
35684 KFNSQ=KFNSQ1-1
35685 KCHW=2
35686 ELSE
35687 KFNSQ=KFNSQ1+1
35688 KCHW=3
35689 ENDIF
35690 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
35691 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
35692 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
35693 IA=IABS(I)
35694 IF(MOD(IA,2).EQ.0) THEN
35695 FACZQ=FACZQ0*AU
35696 ELSE
35697 FACZQ=FACZQ0*AD
35698 ENDIF
35699 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
35700 KCHQ=2
35701 IF(I.LT.0) KCHQ=3
35702 KCHWQ=KCHW
35703 IF(I.LT.0) KCHWQ=5-KCHW
35704 DO 350 ISDE=1,2
35705 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
35706 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
35707 NCHN=NCHN+1
35708 ISIG(NCHN,ISDE)=I
35709 ISIG(NCHN,3-ISDE)=21
35710 ISIG(NCHN,3)=1
35711 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35712 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
35713 350 CONTINUE
35714 360 CONTINUE
35715
35716 ELSEIF(ISUB.EQ.258) THEN
35717C...g + q_j -> gluino + ~q_i
35718 XG2=SQM4
35719 XQ2=SQM3
35720 XMT=XG2-TH
35721 XMU=XG2-UH
35722 XST=XQ2-TH
35723 XSU=XQ2-UH
35724 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
35725 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
35726 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
35727 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
35728 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
35729 & (SH*(UH+XG2)
35730 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
35731 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
35732 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
35733 ASYUK=RMSS(42)*AS
35734 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
35735 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
35736 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35737 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
35738 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
35739 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
35740 KCHQ=2
35741 IF(I.LT.0) KCHQ=3
35742 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35743 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35744 DO 370 ISDE=1,2
35745 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
35746 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
35747 NCHN=NCHN+1
35748 ISIG(NCHN,ISDE)=I
35749 ISIG(NCHN,3-ISDE)=21
35750 ISIG(NCHN,3)=1
35751 SIGH(NCHN)=FACQG1*FACSEL
35752 NCHN=NCHN+1
35753 ISIG(NCHN,ISDE)=I
35754 ISIG(NCHN,3-ISDE)=21
35755 ISIG(NCHN,3)=2
35756 SIGH(NCHN)=FACQG2*FACSEL
35757 370 CONTINUE
35758 380 CONTINUE
35759 ENDIF
35760
35761 ELSEIF(ISUB.LE.270) THEN
35762 IF(ISUB.EQ.261) THEN
35763C...q_i + q_ibar -> ~t_1 + ~t_1bar
35764 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
35765 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35766 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35767 FAC0=AS**2*4D0/9D0
35768 DO 390 I=MMIN1,MMAX1
35769 IA=IABS(I)
35770 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
35771 IF(IA.GE.11.AND.IA.LE.18) THEN
35772 EI=KCHG(IA,1)/3D0
35773 EJ=KCHG(KFNSQ,1)/3D0
35774 T3I=SIGN(1D0,EI)/2D0
35775 T3J=SIGN(1D0,EJ)/2D0
35776 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
35777 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
35778 XLF=2D0*(T3I-EI*XW)
35779 XRF=2D0*(-EI*XW)
35780 TAA=0.5D0*(EI*EJ)**2
35781 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35782 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35783 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35784 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35785 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35786 ENDIF
35787 NCHN=NCHN+1
35788 ISIG(NCHN,1)=I
35789 ISIG(NCHN,2)=-I
35790 ISIG(NCHN,3)=1
35791 SIGH(NCHN)=FACQQ1*FAC0
35792 390 CONTINUE
35793
35794 ELSEIF(ISUB.EQ.263) THEN
35795C...f + fbar -> ~t1 + ~t2bar
35796 DO 400 I=MMIN1,MMAX1
35797 IA=IABS(I)
35798 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
35799 EI=KCHG(IABS(I),1)/3D0
35800 TT3I=SIGN(1D0,EI)/2D0
35801 EJ=2D0/3D0
35802 TT3J=1D0/2D0
35803 FCOL=1D0
35804C...Color factor for e+ e-
35805 IF(IA.GE.11) FCOL=3D0
35806 XLQ=2D0*(TT3J-EJ*XW)
35807 XRQ=2D0*(-EJ*XW)
35808 XLF=2D0*(TT3I-EI*XW)
35809 XRF=2D0*(-EI*XW)
35810 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
35811 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
35812 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35813C...Factor of 2 for t1 t2bar + t2 t1bar
35814 FACQQ1=2D0*COMFAC*AEM**2*TZZ*FCOL*4D0
35815 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
35816 NCHN=NCHN+1
35817 ISIG(NCHN,1)=I
35818 ISIG(NCHN,2)=-I
35819 ISIG(NCHN,3)=1
35820 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35821 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35822 NCHN=NCHN+1
35823 ISIG(NCHN,1)=I
35824 ISIG(NCHN,2)=-I
35825 ISIG(NCHN,3)=2
35826 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35827 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35828 400 CONTINUE
35829
35830 ELSEIF(ISUB.EQ.264) THEN
35831C...g + g -> ~t_1 + ~t_1bar
35832 XSU=SQM3-UH
35833 XST=SQM3-TH
35834 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
35835 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35836 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
35837 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
35838 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
35839 NCHN=NCHN+1
35840 ISIG(NCHN,1)=21
35841 ISIG(NCHN,2)=21
35842 ISIG(NCHN,3)=1
35843 SIGH(NCHN)=FACQQ1
35844 NCHN=NCHN+1
35845 ISIG(NCHN,1)=21
35846 ISIG(NCHN,2)=21
35847 ISIG(NCHN,3)=2
35848 SIGH(NCHN)=FACQQ2
35849 410 CONTINUE
35850 ENDIF
35851
35852 ELSEIF(ISUB.LE.280) THEN
35853 IF(ISUB.EQ.271) THEN
35854C...q + q' -> ~q + ~q' (~g exchange)
35855 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35856 XMT=XMG2-TH
35857 XMU=XMG2-UH
35858 XSU1=SQM3-UH
35859 XSU2=SQM4-UH
35860 XST1=SQM3-TH
35861 XST2=SQM4-TH
35862 ASYUK=RMSS(42)*AS
35863 IF(ILR.EQ.1) THEN
35864 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
35865 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
35866 FACQQB=0.0D0
35867 ELSE
35868 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
35869 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
35870 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
35871 & XMT/XMU )
35872 ENDIF
35873 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35874 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35875 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
35876 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
35877 IA=IABS(I)
35878 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
35879 KCHQ=2
35880 IF(I.LT.0) KCHQ=3
35881 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35882 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
35883 JA=IABS(J)
35884 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
35885 IF(I*J.LT.0) GOTO 420
35886 NCHN=NCHN+1
35887 ISIG(NCHN,1)=I
35888 ISIG(NCHN,2)=J
35889 ISIG(NCHN,3)=1
35890 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35891 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35892 IF(I.EQ.J) THEN
35893 IF(ILR.EQ.0) THEN
35894 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
35895 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35896 ELSE
35897 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
35898 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35899 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35900 ENDIF
35901 NCHN=NCHN+1
35902 ISIG(NCHN,1)=I
35903 ISIG(NCHN,2)=J
35904 ISIG(NCHN,3)=2
35905 IF(ILR.EQ.0) THEN
35906 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
35907 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
35908 ELSE
35909 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
35910 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35911 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
35912 ENDIF
35913 ENDIF
35914 420 CONTINUE
35915 430 CONTINUE
35916
35917 ELSEIF(ISUB.EQ.274) THEN
35918C...q + qbar' -> ~q + ~qbar'
35919 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
35920 XMT=XMG2-TH
35921 XMU=XMG2-UH
35922 IF(ILR.EQ.0) THEN
35923C...Mrenna...Normalization.and.1/XMT
35924 FACQQ1=COMFAC*AS**2*2D0/9D0*(
35925 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
35926 FACQQB=COMFAC*AS**2*4D0/9D0*(
35927 & (UH*TH-SQM3*SQM4)/SH2 )
35928 FACQQI=-COMFAC*AS**2*4D0/27D0*(
35929 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
35930 FACQQB=FACQQB+FACQQ1+FACQQI
35931 ELSE
35932 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
35933 FACQQB=FACQQ1
35934 ENDIF
35935 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
35936 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
35937 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
35938 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
35939 IA=IABS(I)
35940 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
35941 KCHQ=2
35942 IF(I.LT.0) KCHQ=3
35943 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
35944 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
35945 JA=IABS(J)
35946 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
35947 IF(I*J.GT.0) GOTO 440
35948 NCHN=NCHN+1
35949 ISIG(NCHN,1)=I
35950 ISIG(NCHN,2)=J
35951 ISIG(NCHN,3)=1
35952 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
35953 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
35954 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
35955 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35956 440 CONTINUE
35957 450 CONTINUE
35958
35959 ELSEIF(ISUB.EQ.277) THEN
35960C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
35961C...if i .eq. j covered in 274
35962 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
35963 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
35964 FAC0=0D0
35965 DO 460 I=MMIN1,MMAX1
35966 IA=IABS(I)
35967 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
35968 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
35969 IF(IA.EQ.KFNSQ) GOTO 460
35970 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
35971 EI=KCHG(IA,1)/3D0
35972 EJ=KCHG(KFNSQ,1)/3D0
35973 T3J=SIGN(0.5D0,EJ)
35974 T3I=SIGN(1D0,EI)/2D0
35975 IF(ILR.EQ.0) THEN
35976 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
35977 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
35978 ELSE
35979 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
35980 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
35981 ENDIF
35982 XLF=2D0*(T3I-EI*XW)
35983 XRF=2D0*(-EI*XW)
35984 IF(ILR.EQ.0) THEN
35985 XRQ=0D0
35986 ELSE
35987 XLQ=0D0
35988 ENDIF
35989 TAA=0.5D0*(EI*EJ)**2
35990 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
35991 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35992 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
35993 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35994 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
35995 ELSEIF(IA.LE.6) THEN
35996 FAC0=AS**2*8D0/9D0/2D0
35997 ENDIF
35998 NCHN=NCHN+1
35999 ISIG(NCHN,1)=I
36000 ISIG(NCHN,2)=-I
36001 ISIG(NCHN,3)=1
36002 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36003 460 CONTINUE
36004
36005 ELSEIF(ISUB.EQ.279) THEN
36006C...g + g -> ~q_j + ~q_jbar
36007 XSU=SQM3-UH
36008 XST=SQM3-TH
36009C...5=RKF because ~t ~tbar treated separately
36010 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36011 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36012 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36013 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36014 NCHN=NCHN+1
36015 ISIG(NCHN,1)=21
36016 ISIG(NCHN,2)=21
36017 ISIG(NCHN,3)=1
36018 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36019 NCHN=NCHN+1
36020 ISIG(NCHN,1)=21
36021 ISIG(NCHN,2)=21
36022 ISIG(NCHN,3)=2
36023 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36024 470 CONTINUE
36025
36026 ENDIF
36027 ENDIF
36028CMRENNA--
36029
36030 RETURN
36031 END
36032
36033C*********************************************************************
36034
36035C...PYSGTC
36036C...Subprocess cross sections for Technicolor processes.
36037C...Auxiliary to PYSIGH.
36038
36039 SUBROUTINE PYSGTC(NCHN,SIGS)
36040
36041C...Double precision and integer declarations
36042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36043 IMPLICIT INTEGER(I-N)
36044 INTEGER PYK,PYCHGE,PYCOMP
36045C...Parameter statement to help give large particle numbers.
36046 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36047 &KEXCIT=4000000,KDIMEN=5000000)
36048C...Commonblocks
36049 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36050 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36051 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36052 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36053 COMMON/PYINT1/MINT(400),VINT(400)
36054 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36055 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36056 COMMON/PYINT4/MWID(500),WIDS(500,5)
36057 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36058 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36059 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36060 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36061 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36062 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36063 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36064C...Local arrays and complex variables
36065 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36066 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36067 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36068 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36069 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36070 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36071 COMPLEX*16 DVVS,DVVT,DVVU
36072 INTEGER INDX(6)
36073
36074C...Combinations of weak mixing angle.
36075 TANW=SQRT(XW/XW1)
36076 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36077
36078C...Convert almost equivalent technicolor processes into
36079C...a few basic processes, and set distinguishing parameters.
36080 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36081 SQTV=RTCM(12)**2
36082 SQTA=RTCM(13)**2
36083 SN2W=2D0*SQRT(XW*XW1)
36084 CS2W=1D0-2D0*XW
36085 CT2W=CS2W/SN2W
36086 CSXI=COS(ASIN(RTCM(3)))
36087 CSXIP=COS(ASIN(RTCM(4)))
36088 QUPD=2D0*RTCM(2)-1D0
36089 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36090 CAB2=0D0
36091 VOGP=0D0
36092 VRGP=0D0
36093 AOGP=0D0
36094 ARGP=0D0
36095 VXGP=0D0
36096 AXGP=0D0
36097 VAGP=0D0
36098 VZGP=0D0
36099 VWGP=0D0
36100C... rho_tc0, etc. -> W_L W_L, W_L W_T
36101 IF(ISUB.EQ.361) THEN
36102 KFA=24
36103 KFB=24
36104 CAB2=RTCM(3)**4
36105 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36106 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36107 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36108C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36109 AXGP = SQRT(2D0)*AXGP
36110 ARGP = SQRT(2D0)*ARGP
36111 VOGP = SQRT(2D0)*VOGP
36112C... rho_tc0 -> W_L pi_tc-
36113 ELSEIF(ISUB.EQ.362) THEN
36114 KFA=24
36115 KFB=KTECHN+211
36116 ISUB=361
36117 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36118C... pi_tc pi_tc
36119 ELSEIF(ISUB.EQ.363) THEN
36120 KFA=KTECHN+211
36121 KFB=KTECHN+211
36122 ISUB=361
36123 CAB2=(1D0-RTCM(3)**2)**2
36124C... rho_tc0/omega_tc -> gamma pi_tc
36125 ELSEIF(ISUB.EQ.364) THEN
36126 KFA=22
36127 KFB=KTECHN+111
36128 ISUB=361
36129 VOGP=CSXI/RTCM(12)
36130 VRGP=VOGP*QUPD
36131 VAGP=2D0*QUPD*CSXI
36132 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36133C... gamma pi_tc'
36134 ELSEIF(ISUB.EQ.365) THEN
36135 KFA=22
36136 KFB=KTECHN+221
36137 ISUB=361
36138 VRGP=CSXIP/RTCM(12)
36139 VOGP=VRGP*QUPD
36140 VAGP=2D0*Q2UD*CSXIP
36141 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36142C... Z pi_tc
36143 ELSEIF(ISUB.EQ.366) THEN
36144 KFA=23
36145 KFB=KTECHN+111
36146 ISUB=361
36147 VOGP=CSXI*CT2W/RTCM(12)
36148 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36149 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36150 VZGP=-QUPD*CSXI*CS2W/XW1
36151C... Z pi_tc'
36152 ELSEIF(ISUB.EQ.367) THEN
36153 KFA=23
36154 KFB=KTECHN+221
36155 ISUB=361
36156C...RTCM(48) is the M_V for the techni-a
36157 VXGP=-CSXIP/SN2W/RTCM(48)
36158 VRGP=CSXIP*CT2W/RTCM(12)
36159 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36160 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36161 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36162C... W_T pi_tc
36163 ELSEIF(ISUB.EQ.368) THEN
36164 KFA=24
36165 KFB=KTECHN+211
36166 ISUB=361
36167C...RTCM(49) is the M_A for the techni-a
36168 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36169 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36170 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36171 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36172 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36173C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36174 ELSEIF(ISUB.EQ.370) THEN
36175 KFA=24
36176 KFB=23
36177 CAB2=RTCM(3)**4
36178 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36179 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36180C... W_L pi_tc0
36181 ELSEIF(ISUB.EQ.371) THEN
36182 KFA=24
36183 KFB=KTECHN+111
36184 ISUB=370
36185 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36186C... Z_L pi_tc+
36187 ELSEIF(ISUB.EQ.372) THEN
36188 KFA=KTECHN+211
36189 KFB=23
36190 ISUB=370
36191 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36192C... pi_tc+ pi_tc0
36193 ELSEIF(ISUB.EQ.373) THEN
36194 KFA=KTECHN+211
36195 KFB=KTECHN+111
36196 ISUB=370
36197 CAB2=(1D0-RTCM(3)**2)**2
36198C... gamma pi_tc+
36199 ELSEIF(ISUB.EQ.374) THEN
36200 KFA=KTECHN+211
36201 KFB=22
36202 ISUB=370
36203 VRGP=QUPD*CSXI/RTCM(12)
36204 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36205 AXGP=-CSXI/RTCM(49)
36206C... Z_T pi_tc+
36207 ELSEIF(ISUB.EQ.375) THEN
36208 KFA=KTECHN+211
36209 KFB=23
36210 ISUB=370
36211 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36212 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36213 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36214 AXGP=-CSXI*CT2W/RTCM(49)
36215C... W_T pi_tc0
36216 ELSEIF(ISUB.EQ.376) THEN
36217 KFA=24
36218 KFB=KTECHN+111
36219 ISUB=370
36220 VRGP=0D0
36221 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36222 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36223C... W_T pi_tc0'
36224 ELSEIF(ISUB.EQ.377) THEN
36225 KFA=24
36226 KFB=KTECHN+221
36227 ISUB=370
36228 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36229 VWGP=CSXIP/(2D0*XW)
36230 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36231C... gamma W+
36232 ELSEIF(ISUB.EQ.378) THEN
36233 KFA=24
36234 KFB=22
36235 ISUB=370
36236 VRGP=QUPD*RTCM(3)/RTCM(12)
36237 AXGP=-RTCM(3)/RTCM(49)
36238C... gamma Z
36239 ELSEIF(ISUB.EQ.379) THEN
36240 KFA=23
36241 KFB=22
36242 ISUB=361
36243 VOGP=RTCM(3)/RTCM(12)
36244 VRGP=QUPD*RTCM(3)/RTCM(12)
36245 ELSEIF(ISUB.EQ.380) THEN
36246 KFA=23
36247 KFB=23
36248 ISUB=361
36249 VOGP=RTCM(3)*CT2W/RTCM(12)
36250 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36251 ENDIF
36252 ENDIF
36253
36254C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36255 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36256 IF(ITCM(5).LE.4) THEN
36257 SQDQQS=1D0/SH2
36258 SQDQQT=1D0/TH2
36259 SQDQQU=1D0/UH2
36260 SQDGGS=SQDQQS
36261 SQDGGT=SQDQQT
36262 SQDGGU=SQDQQU
36263 REDGGS=1D0/SH
36264 REDGGT=1D0/TH
36265 REDGGU=1D0/UH
36266 REDGTU=1D0/UH/TH
36267 REDGSU=1D0/SH/UH
36268 REDGST=1D0/SH/TH
36269 REDQST=1D0/SH/TH
36270 REDQTU=1D0/UH/TH
36271 SQDLGS=0D0
36272 SQDLGT=0D0
36273 SQDQTS=SQDQQS
36274 ELSEIF(ITCM(5).EQ.5) THEN
36275 TANT3=RTCM(21)
36276 IF(ITCM(2).EQ.0) THEN
36277 IMDL=1
36278 ELSE
36279 IMDL=2
36280 ENDIF
36281 ALPRHT=2.16D0*(3D0/ITCM(1))
36282 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36283 SINT3=TANT3/SQRT(TANT3**2+1D0)
36284 XIG=SQRT(PYALPS(SH)/ALPRHT)
36285 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36286 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36287 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36288 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36289 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36290 & SINT3**2)*2D0/SIN2T
36291 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36292 & SINT3**2)*2D0/SIN2T
36293
36294 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36295 SM1112=X12*RTCM(28)**2*SIN2T
36296 SM1121=-X21*RTCM(28)**2*SIN2T
36297 SM2212=-SM1112
36298 SM2221=-SM1121
36299 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36300 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36301
36302C.........SH LOOP
36303 ZTC(1,1)=DCMPLX(SH,0D0)
36304 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36305 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36306 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36307 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36308 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36309 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36310 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36311 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36312 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36313 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36314 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36315 ZTC(1,2)=(0D0,0D0)
36316 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36317 ZTC(1,4)=ZTC(1,3)
36318 ZTC(1,5)=ZTC(1,2)
36319 ZTC(1,6)=ZTC(1,2)
36320 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36321 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36322 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36323 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36324 ZTC(3,4)=-SM1122
36325 ZTC(3,5)=-SM1112
36326 ZTC(3,6)=-SM1121
36327 ZTC(4,5)=-SM2212
36328 ZTC(4,6)=-SM2221
36329 ZTC(5,6)=-SM1221
36330
36331 DO 110 I=1,5
36332 DO 100 J=I+1,6
36333 ZTC(J,I)=ZTC(I,J)
36334 100 CONTINUE
36335 110 CONTINUE
36336 CALL PYLDCM(ZTC,6,6,INDX,D)
36337 DO 130 I=1,6
36338 DO 120 J=1,6
36339 YTC(I,J)=(0D0,0D0)
36340 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36341 120 CONTINUE
36342 130 CONTINUE
36343
36344 DO 140 I=1,6
36345 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36346 140 CONTINUE
36347 DGGS=YTC(1,1)
36348 DVVS=YTC(2,2)
36349 DGVS=YTC(1,2)
36350
36351 XIG=SQRT(PYALPS(-TH)/ALPRHT)
36352C.........TH LOOP
36353 ZTC(1,1)=DCMPLX(TH)
36354 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
36355 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
36356 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
36357 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
36358 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
36359 ZTC(1,2)=(0D0,0D0)
36360 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
36361 ZTC(1,4)=ZTC(1,3)
36362 ZTC(1,5)=ZTC(1,2)
36363 ZTC(1,6)=ZTC(1,2)
36364 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
36365 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
36366 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
36367 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
36368 ZTC(3,4)=-SM1122
36369 ZTC(3,5)=-SM1112
36370 ZTC(3,6)=-SM1121
36371 ZTC(4,5)=-SM2212
36372 ZTC(4,6)=-SM2221
36373 ZTC(5,6)=-SM1221
36374 DO 160 I=1,5
36375 DO 150 J=I+1,6
36376 ZTC(J,I)=ZTC(I,J)
36377 150 CONTINUE
36378 160 CONTINUE
36379 CALL PYLDCM(ZTC,6,6,INDX,D)
36380 DO 180 I=1,6
36381 DO 170 J=1,6
36382 YTC(I,J)=(0D0,0D0)
36383 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36384 170 CONTINUE
36385 180 CONTINUE
36386 DO 190 I=1,6
36387 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36388 190 CONTINUE
36389 DGGT=YTC(1,1)
36390 DVVT=YTC(2,2)
36391 DGVT=YTC(1,2)
36392
36393 XIG=SQRT(PYALPS(-UH)/ALPRHT)
36394C.........UH LOOP
36395 ZTC(1,1)=DCMPLX(UH,0D0)
36396 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
36397 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
36398 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
36399 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
36400 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
36401 ZTC(1,2)=(0D0,0D0)
36402 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
36403 ZTC(1,4)=ZTC(1,3)
36404 ZTC(1,5)=ZTC(1,2)
36405 ZTC(1,6)=ZTC(1,2)
36406 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
36407 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
36408 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
36409 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
36410 ZTC(3,4)=-SM1122
36411 ZTC(3,5)=-SM1112
36412 ZTC(3,6)=-SM1121
36413 ZTC(4,5)=-SM2212
36414 ZTC(4,6)=-SM2221
36415 ZTC(5,6)=-SM1221
36416 DO 210 I=1,5
36417 DO 200 J=I+1,6
36418 ZTC(J,I)=ZTC(I,J)
36419 200 CONTINUE
36420 210 CONTINUE
36421 CALL PYLDCM(ZTC,6,6,INDX,D)
36422 DO 230 I=1,6
36423 DO 220 J=1,6
36424 YTC(I,J)=(0D0,0D0)
36425 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
36426 220 CONTINUE
36427 230 CONTINUE
36428 DO 240 I=1,6
36429 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
36430 240 CONTINUE
36431 DGGU=YTC(1,1)
36432 DVVU=YTC(2,2)
36433 DGVU=YTC(1,2)
36434
36435 IF(IMDL.EQ.1) THEN
36436 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
36437 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
36438 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
36439 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
36440 DQGS=DGGS-DGVS*DCMPLX(TANT3)
36441 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36442 ELSE
36443 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36444 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
36445 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
36446 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
36447 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36448 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
36449 ENDIF
36450
36451 SQDQTS=ABS(DQTS)**2
36452 SQDQQS=ABS(DQQS)**2
36453 SQDQQT=ABS(DQQT)**2
36454 SQDQQU=ABS(DQQU)**2
36455 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
36456 REDLGS=DBLE(DQGS)
36457 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
36458 REDHGS=DBLE(DTGS)
36459 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
36460
36461 SQDGGS=ABS(DGGS)**2
36462 SQDGGT=ABS(DGGT)**2
36463 SQDGGU=ABS(DGGU)**2
36464 REDGGS=DBLE(DGGS)
36465 REDGGT=DBLE(DGGT)
36466 REDGGU=DBLE(DGGU)
36467 REDGTU=DBLE(DGGU*DCONJG(DGGT))
36468 REDGSU=DBLE(DGGU*DCONJG(DGGS))
36469 REDGST=DBLE(DGGS*DCONJG(DGGT))
36470 REDQST=DBLE(DQQS*DCONJG(DQQT))
36471 REDQTU=DBLE(DQQT*DCONJG(DQQU))
36472 ENDIF
36473 ENDIF
36474
36475
36476C...Differential cross section expressions.
36477
36478 IF(ISUB.LE.190) THEN
36479 IF(ISUB.EQ.149) THEN
36480C...g + g -> eta_tc
36481 KCTC=PYCOMP(KTECHN+331)
36482 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
36483 HS=SHR*WDTP(0)
36484 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
36485 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36486 HP=SH
36487 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
36488 HI=HP*WDTP(3)
36489 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36490 NCHN=NCHN+1
36491 ISIG(NCHN,1)=21
36492 ISIG(NCHN,2)=21
36493 ISIG(NCHN,3)=1
36494 SIGH(NCHN)=HI*FACBW*HF
36495 250 CONTINUE
36496
36497 ELSEIF(ISUB.EQ.165) THEN
36498C...q + qbar -> l+ + l- (including contact term for compositeness)
36499 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36500 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36501 KFF=IABS(KFPR(ISUB,1))
36502 EF=KCHG(KFF,1)/3D0
36503 AF=SIGN(1D0,EF+0.1D0)
36504 VF=AF-4D0*EF*XWV
36505 VALF=VF+AF
36506 VARF=VF-AF
36507 FCOF=1D0
36508 IF(KFF.LE.10) FCOF=3D0
36509 WID2=1D0
36510 IF(KFF.EQ.6) WID2=WIDS(6,1)
36511 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
36512 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36513 DO 260 I=MMINA,MMAXA
36514 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
36515 EI=KCHG(IABS(I),1)/3D0
36516 AI=SIGN(1D0,EI+0.1D0)
36517 VI=AI-4D0*EI*XWV
36518 VALI=VI+AI
36519 VARI=VI-AI
36520 FCOI=1D0
36521 IF(IABS(I).LE.10) FCOI=FACA/3D0
36522 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
36523 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
36524 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
36525 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36526 ELSE
36527 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
36528 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
36529 ENDIF
36530 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
36531 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
36532 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
36533 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
36534 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
36535 NCHN=NCHN+1
36536 ISIG(NCHN,1)=I
36537 ISIG(NCHN,2)=-I
36538 ISIG(NCHN,3)=1
36539 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
36540 260 CONTINUE
36541
36542 ELSEIF(ISUB.EQ.166) THEN
36543C...q + q'bar -> l + nu_l (including contact term for compositeness)
36544 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
36545 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
36546 KFF=IABS(KFPR(ISUB,1))
36547 FCOF=1D0
36548 IF(KFF.LE.10) FCOF=3D0
36549 DO 280 I=MMIN1,MMAX1
36550 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
36551 IA=IABS(I)
36552 DO 270 J=MMIN2,MMAX2
36553 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
36554 JA=IABS(J)
36555 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
36556 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36557 & GOTO 270
36558 FCOI=1D0
36559 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36560 WID2=1D0
36561 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
36562 & MOD(J,2).EQ.0)) THEN
36563 IF(KFF.EQ.5) WID2=WIDS(6,2)
36564 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
36565 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
36566 ELSE
36567 IF(KFF.EQ.5) WID2=WIDS(6,3)
36568 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
36569 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
36570 ENDIF
36571 NCHN=NCHN+1
36572 ISIG(NCHN,1)=I
36573 ISIG(NCHN,2)=J
36574 ISIG(NCHN,3)=1
36575 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
36576 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
36577 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
36578 270 CONTINUE
36579 280 CONTINUE
36580 ENDIF
36581
36582 ELSEIF(ISUB.LE.200) THEN
36583 IF(ISUB.EQ.191) THEN
36584C...q + qbar -> rho_tc0.
36585 KCTC=PYCOMP(KTECHN+113)
36586 SQMRHT=PMAS(KCTC,1)**2
36587 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36588 HS=SHR*WDTP(0)
36589 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36590 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36591 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36592 ALPRHT=2.16D0*(3D0/ITCM(1))
36593 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
36594 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
36595 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36596 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36597 DO 290 I=MMINA,MMAXA
36598 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
36599 IA=IABS(I)
36600 EI=KCHG(IABS(I),1)/3D0
36601 AI=SIGN(1D0,EI+0.1D0)
36602 VI=AI-4D0*EI*XWV
36603 VALI=0.5D0*(VI+AI)
36604 VARI=0.5D0*(VI-AI)
36605 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
36606 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
36607 IF(IA.LE.10) HI=HI*FACA/3D0
36608 NCHN=NCHN+1
36609 ISIG(NCHN,1)=I
36610 ISIG(NCHN,2)=-I
36611 ISIG(NCHN,3)=1
36612 SIGH(NCHN)=HI*FACBW*HF
36613 290 CONTINUE
36614
36615 ELSEIF(ISUB.EQ.192) THEN
36616C...q + qbar' -> rho_tc+/-.
36617 KCTC=PYCOMP(KTECHN+213)
36618 SQMRHT=PMAS(KCTC,1)**2
36619 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36620 HS=SHR*WDTP(0)
36621 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
36622 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36623 ALPRHT=2.16D0*(3D0/ITCM(1))
36624 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
36625 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
36626 DO 310 I=MMIN1,MMAX1
36627 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
36628 IA=IABS(I)
36629 DO 300 J=MMIN2,MMAX2
36630 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
36631 JA=IABS(J)
36632 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
36633 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36634 & GOTO 300
36635 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36636 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
36637 HI=HP
36638 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
36639 NCHN=NCHN+1
36640 ISIG(NCHN,1)=I
36641 ISIG(NCHN,2)=J
36642 ISIG(NCHN,3)=1
36643 SIGH(NCHN)=HI*FACBW*HF
36644 300 CONTINUE
36645 310 CONTINUE
36646
36647 ELSEIF(ISUB.EQ.193) THEN
36648C...q + qbar -> omega_tc0.
36649 KCTC=PYCOMP(KTECHN+223)
36650 SQMOMT=PMAS(KCTC,1)**2
36651 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36652 HS=SHR*WDTP(0)
36653 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
36654 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
36655 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
36656 ALPRHT=2.16D0*(3D0/ITCM(1))
36657 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
36658 & (2D0*RTCM(2)-1D0)**2
36659 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
36660 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
36661 DO 320 I=MMINA,MMAXA
36662 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
36663 IA=IABS(I)
36664 EI=KCHG(IABS(I),1)/3D0
36665 AI=SIGN(1D0,EI+0.1D0)
36666 VI=AI-4D0*EI*XWV
36667 VALI=0.5D0*(VI+AI)
36668 VARI=0.5D0*(VI-AI)
36669 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
36670 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
36671 IF(IA.LE.10) HI=HI*FACA/3D0
36672 NCHN=NCHN+1
36673 ISIG(NCHN,1)=I
36674 ISIG(NCHN,2)=-I
36675 ISIG(NCHN,3)=1
36676 SIGH(NCHN)=HI*FACBW*HF
36677 320 CONTINUE
36678
36679 ELSEIF(ISUB.EQ.194) THEN
36680C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
36681C...Default final state is e+e-
36682 KFA=KFPR(ISUBSV,1)
36683 ALPRHT=2.16D0*(3D0/ITCM(1))
36684 HP=AEM**2*COMFAC
36685
36686 SN2W=2D0*SQRT(XW*XW1)
36687C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
36688C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
36689
36690 QUPD=2D0*RTCM(2)-1D0
36691 FAR=SQRT(AEM/ALPRHT)
36692 FAO=FAR*QUPD
36693 FZR=FAR*CT2W
36694 FZO=-FAO*TANW
36695C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36696 FZX=-FAR/SN2W*RTCM(47)
36697 SFAR=FAR**2
36698 SFAO=FAO**2
36699 SFZR=FZR**2
36700 SFZO=FZO**2
36701 SFZX=FZX**2
36702 CALL PYWIDT(23,SH,WDTP,WDTE)
36703 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36704 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36705 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36706 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36707 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36708 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36709 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36710C...Propagator including a_T^0
36711 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36712 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36713C...Add in techni-a contribution
36714 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36715 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36716 $ SFZX*SSMR*SSMO)/DETD/SH
36717 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36718 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36719
36720 XWRHT=1D0/(4D0*XW*(1D0-XW))
36721 KFF=IABS(KFPR(ISUB,1))
36722 EF=KCHG(KFF,1)/3D0
36723 AF=SIGN(1D0,EF+0.1D0)
36724 VF=AF-4D0*EF*XWV
36725 VALF=0.5D0*(VF+AF)
36726 VARF=0.5D0*(VF-AF)
36727 FCOF=1D0
36728 IF(KFF.LE.10) FCOF=3D0
36729
36730 WID2=1D0
36731 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
36732 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
36733 DZZ=DZZ*DCMPLX(XWRHT,0D0)
36734 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
36735
36736 DO 330 I=MMINA,MMAXA
36737 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
36738 EI=KCHG(IABS(I),1)/3D0
36739 AI=SIGN(1D0,EI+0.1D0)
36740 VI=AI-4D0*EI*XWV
36741 VALI=0.5D0*(VI+AI)
36742 VARI=0.5D0*(VI-AI)
36743 FCOI=FCOF
36744 IF(IABS(I).LE.10) FCOI=FCOI/3D0
36745 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
36746 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
36747 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
36748 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
36749 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
36750 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
36751 NCHN=NCHN+1
36752 ISIG(NCHN,1)=I
36753 ISIG(NCHN,2)=-I
36754 ISIG(NCHN,3)=1
36755 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
36756 330 CONTINUE
36757
36758 ELSEIF(ISUB.EQ.195) THEN
36759C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
36760 KFA=KFPR(ISUBSV,1)
36761 KFB=KFA+1
36762 ALPRHT=2.16D0*(3D0/ITCM(1))
36763 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
36764
36765 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36766C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36767C
36768C...Propagator including a_T^+
36769 FWX=-FWR*RTCM(47)
36770 CALL PYWIDT(24,SH,WDTP,WDTE)
36771 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36772 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36773 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36774 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36775 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36776 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36777 & DCMPLX(FWX**2,0D0)*SSMR
36778 DWW=SSMR*SSMX/DETD/SH
36779 FCOF=1D0
36780 IF(KFA.LE.8) FCOF=3D0
36781 HP=FACTC*ABS(DWW)**2*FCOF
36782
36783 DO 350 I=MMIN1,MMAX1
36784 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
36785 IA=IABS(I)
36786 DO 340 J=MMIN2,MMAX2
36787 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
36788 JA=IABS(J)
36789 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
36790 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36791 & GOTO 340
36792 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36793 HI=HP
36794 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36795 NCHN=NCHN+1
36796 ISIG(NCHN,1)=I
36797 ISIG(NCHN,2)=J
36798 ISIG(NCHN,3)=1
36799 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
36800 340 CONTINUE
36801 350 CONTINUE
36802 ENDIF
36803
36804 ELSEIF(ISUB.LE.380) THEN
36805 ALPRHT=2.16D0*(3D0/ITCM(1))
36806 IF(ISUB.EQ.361) THEN
36807 FAR=SQRT(AEM/ALPRHT)
36808 FAO=FAR*QUPD
36809 FZR=FAR*CT2W
36810 FZO=-FAO*TANW
36811C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36812 FZX=-FAR/SN2W*RTCM(47)
36813 SFAR=FAR**2
36814 SFAO=FAO**2
36815 SFZR=FZR**2
36816 SFZO=FZO**2
36817 SFZX=FZX**2
36818 CALL PYWIDT(23,SH,WDTP,WDTE)
36819 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
36820 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
36821 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
36822 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
36823 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
36824 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
36825 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
36826 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
36827 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
36828C...Add in techni-a contribution
36829 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
36830 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
36831 $ SFZX*FAR*SSMO)/DETD/SH
36832 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
36833 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
36834 $ SFZX*FAO*SSMR)/DETD/SH
36835 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
36836 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
36837 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
36838 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
36839 $ SFZX*SSMR*SSMO)/DETD/SH
36840 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
36841 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
36842
36843C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
36844C...W+W-, W pi_tc, pi_T pi_T, etc.
36845 FACA=(SH**2*BE34**2-(TH-UH)**2)
36846 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36847 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36848 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36849 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
36850 DO 370 I=MMINA,MMAXA
36851 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
36852 IA=IABS(I)
36853 EI=KCHG(IABS(I),1)/3D0
36854 AI=SIGN(1D0,EI+0.1D0)
36855 VI=AI-4D0*EI*XWV
36856 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
36857 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
36858C...........Eqs. (5) and (6) in LSTC-rates.pdf
36859 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
36860 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
36861 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
36862 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
36863 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
36864 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
36865 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
36866 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
36867 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
36868 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
36869 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
36870C...........Eqs. (5) and (7) in LSTC-rates.pdf
36871 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
36872 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
36873 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
36874 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
36875 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
36876 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
36877 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
36878C
36879C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
36880C
36881c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36882c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36883c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
36884c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
36885 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36886 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
36887 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
36888 HI=HI+HJ+HK
36889 IF(IA.LE.10) HI=HI/3D0
36890 NCHN=NCHN+1
36891 ISIG(NCHN,1)=I
36892 ISIG(NCHN,2)=-I
36893 ISIG(NCHN,3)=1
36894 IF(KFA.EQ.KFB) THEN
36895 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
36896 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
36897 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
36898 NCHN=NCHN+1
36899 ISIG(NCHN,1)=I
36900 ISIG(NCHN,2)=-I
36901 ISIG(NCHN,3)=2
36902 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
36903 ELSE
36904 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
36905 ENDIF
36906 370 CONTINUE
36907
36908 ELSEIF(ISUB.EQ.370) THEN
36909C...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
36910C...f + fbar' -> gamma pi_tc, etc.
36911 FACA=(SH**2*BE34**2-(TH-UH)**2)
36912 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
36913 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
36914 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
36915 ALPRHT=2.16D0*(3D0/ITCM(1))
36916 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
36917 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
36918C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
36919 FWX=-FWR*RTCM(47)
36920 CALL PYWIDT(24,SH,WDTP,WDTE)
36921 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
36922 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
36923 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
36924 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
36925 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
36926 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
36927 & DCMPLX(FWX**2,0D0)*SSMR
36928 DWW=SSMR*SSMX/DETD/SH
36929 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
36930 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
36931 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
36932 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
36933C
36934C...........Eq. (25) in PRD67-115011 with DWW term dropped.
36935C
36936c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
36937 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
36938C...Add in W_L Z_T axial and vector contributions.
36939 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
36940 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
36941 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
36942 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
36943 DO 410 I=MMIN1,MMAX1
36944 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
36945 IA=IABS(I)
36946 DO 400 J=MMIN2,MMAX2
36947 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
36948 JA=IABS(J)
36949 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
36950 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
36951 & GOTO 400
36952 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
36953 HI=HP
36954 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
36955 NCHN=NCHN+1
36956 ISIG(NCHN,1)=I
36957 ISIG(NCHN,2)=J
36958 ISIG(NCHN,3)=1
36959 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
36960 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
36961 ELSE
36962 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
36963 & WIDS(PYCOMP(KFB),2)
36964 ENDIF
36965 400 CONTINUE
36966 410 CONTINUE
36967 ENDIF
36968
36969 ELSEIF(ISUB.LE.390) THEN
36970 IF(ISUB.EQ.381) THEN
36971C...f + f' -> f + f' (g exchange)
36972 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
36973 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
36974 & MSTP(34)*2D0/3D0*UH2*REDQST)
36975 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
36976 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
36977 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
36978 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
36979C...Modifications from contact interactions (compositeness)
36980 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
36981 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36982 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
36983 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
36984 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
36985 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
36986 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
36987 ELSEIF(ITCM(5).EQ.5) THEN
36988 FACCI1=FACQQ1
36989 FACCIB=FACQQB
36990 FACCI2=FACQQ2
36991 FACCI3=FACQQ1
36992CSM.......Check this change from
36993CSM RATCII=1D0
36994 RATCII=RATQQI
36995 ENDIF
36996 DO 430 I=MMIN1,MMAX1
36997 IA=IABS(I)
36998 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36999 DO 420 J=MMIN2,MMAX2
37000 JA=IABS(J)
37001 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37002 NCHN=NCHN+1
37003 ISIG(NCHN,1)=I
37004 ISIG(NCHN,2)=J
37005 ISIG(NCHN,3)=1
37006 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37007 & JA.GE.3))) THEN
37008 SIGH(NCHN)=FACQQ1
37009 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37010 ELSE
37011 SIGH(NCHN)=FACCI1
37012 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37013 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37014 ENDIF
37015 IF(I.EQ.J) THEN
37016 NCHN=NCHN+1
37017 ISIG(NCHN,1)=I
37018 ISIG(NCHN,2)=J
37019 ISIG(NCHN,3)=2
37020 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37021 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37022 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37023 ELSE
37024 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37025 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37026 ENDIF
37027 ENDIF
37028 420 CONTINUE
37029 430 CONTINUE
37030
37031 ELSEIF(ISUB.EQ.382) THEN
37032C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37033 CALL PYWIDT(21,SH,WDTP,WDTE)
37034 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37035 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37036 IF(ITCM(5).EQ.1) THEN
37037C...Modifications from contact interactions (compositeness)
37038 FACCIB=FACQQB
37039 DO 440 I=1,2
37040 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37041 & WDTE(I,2)+WDTE(I,4))
37042 440 CONTINUE
37043 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37044 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37045 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37046 ELSEIF(ITCM(5).EQ.5) THEN
37047 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37048 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37049 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37050 ENDIF
37051 DO 450 I=MMINA,MMAXA
37052 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37053 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37054 NCHN=NCHN+1
37055 ISIG(NCHN,1)=I
37056 ISIG(NCHN,2)=-I
37057 ISIG(NCHN,3)=1
37058 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37059 SIGH(NCHN)=FACQQB
37060 ELSEIF(ITCM(5).EQ.5) THEN
37061 SIGH(NCHN)=FACQQB
37062 NCHN=NCHN+1
37063 ISIG(NCHN,1)=I
37064 ISIG(NCHN,2)=-I
37065 ISIG(NCHN,3)=2
37066 SIGH(NCHN)=FACCIB
37067 ELSE
37068 SIGH(NCHN)=FACCIB
37069 ENDIF
37070 450 CONTINUE
37071
37072 ELSEIF(ISUB.EQ.383) THEN
37073C...f + fbar -> g + g (q + qbar -> g + g only)
37074 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37075 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37076 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37077 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37078 IF(ITCM(5).EQ.5) THEN
37079 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37080 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37081 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37082 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37083 ENDIF
37084 DO 460 I=MMINA,MMAXA
37085 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37086 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37087 NCHN=NCHN+1
37088 ISIG(NCHN,1)=I
37089 ISIG(NCHN,2)=-I
37090 ISIG(NCHN,3)=1
37091 SIGH(NCHN)=0.5D0*FACGG1
37092 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37093 NCHN=NCHN+1
37094 ISIG(NCHN,1)=I
37095 ISIG(NCHN,2)=-I
37096 ISIG(NCHN,3)=2
37097 SIGH(NCHN)=0.5D0*FACGG2
37098 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37099 460 CONTINUE
37100
37101 ELSEIF(ISUB.EQ.384) THEN
37102C...f + g -> f + g (q + g -> q + g only)
37103 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37104 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37105 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37106 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37107 DO 480 I=MMINA,MMAXA
37108 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37109 DO 470 ISDE=1,2
37110 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37111 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37112 NCHN=NCHN+1
37113 ISIG(NCHN,ISDE)=I
37114 ISIG(NCHN,3-ISDE)=21
37115 ISIG(NCHN,3)=1
37116 SIGH(NCHN)=FACQG1
37117 NCHN=NCHN+1
37118 ISIG(NCHN,ISDE)=I
37119 ISIG(NCHN,3-ISDE)=21
37120 ISIG(NCHN,3)=2
37121 SIGH(NCHN)=FACQG2
37122 470 CONTINUE
37123 480 CONTINUE
37124
37125 ELSEIF(ISUB.EQ.385) THEN
37126C...g + g -> f + fbar (g + g -> q + qbar only)
37127 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37128 IDC0=MDCY(21,2)-1
37129C...Begin by d, u, s flavours.
37130 FLAVWT=0D0
37131 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37132 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37133 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37134 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37135 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37136 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37137 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37138 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37139 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37140 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37141 NCHN=NCHN+1
37142 ISIG(NCHN,1)=21
37143 ISIG(NCHN,2)=21
37144 ISIG(NCHN,3)=1
37145 SIGH(NCHN)=FACQQ1
37146 NCHN=NCHN+1
37147 ISIG(NCHN,1)=21
37148 ISIG(NCHN,2)=21
37149 ISIG(NCHN,3)=2
37150 SIGH(NCHN)=FACQQ2
37151C...Next c and b flavours: modified that and uhat for fixed
37152C...cos(theta-hat).
37153 DO 490 IFL=4,5
37154 SQMAVG=PMAS(IFL,1)**2
37155 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37156 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37157 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37158 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37159 THUHQ=THQ*UHQ-SQMAVG*SH
37160 IF(MSTP(34).EQ.0) THEN
37161 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37162 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37163 ELSE
37164 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37165 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37166 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37167 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37168 ENDIF
37169 IF(ITCM(5).GE.5) THEN
37170 IF(IFL.EQ.4) THEN
37171 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37172 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37173 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37174 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37175 ELSE
37176 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37177 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37178 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37179 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37180 ENDIF
37181 ENDIF
37182 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37183 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37184 NCHN=NCHN+1
37185 ISIG(NCHN,1)=21
37186 ISIG(NCHN,2)=21
37187 ISIG(NCHN,3)=1+2*(IFL-3)
37188 SIGH(NCHN)=FACQQ1
37189 NCHN=NCHN+1
37190 ISIG(NCHN,1)=21
37191 ISIG(NCHN,2)=21
37192 ISIG(NCHN,3)=2+2*(IFL-3)
37193 SIGH(NCHN)=FACQQ2
37194 ENDIF
37195 490 CONTINUE
37196 500 CONTINUE
37197
37198 ELSEIF(ISUB.EQ.386) THEN
37199C...g + g -> g + g
37200 IF(ITCM(5).LE.4) THEN
37201 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37202 & 2D0*TH/SH+TH2/SH2)*FACA
37203 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37204 & 2D0*SH/UH+SH2/UH2)*FACA
37205 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37206 & 2D0*UH/TH+UH2/TH2)
37207 ELSE
37208 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37209 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37210 & 4D0*REDGST*(SH + 2D0*TH)*
37211 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37212 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37213 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37214 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37215 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37216 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37217 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37218 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37219 & 4D0*REDGSU*(SH + 2D0*UH)*
37220 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37221 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37222 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37223 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37224 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37225 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37226 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37227 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37228 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37229 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37230 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37231 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37232 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37233 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37234 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37235 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37236 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37237 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37238 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37239 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37240 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37241 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37242 ENDIF
37243 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37244 NCHN=NCHN+1
37245 ISIG(NCHN,1)=21
37246 ISIG(NCHN,2)=21
37247 ISIG(NCHN,3)=1
37248 SIGH(NCHN)=0.5D0*FACGG1
37249 NCHN=NCHN+1
37250 ISIG(NCHN,1)=21
37251 ISIG(NCHN,2)=21
37252 ISIG(NCHN,3)=2
37253 SIGH(NCHN)=0.5D0*FACGG2
37254 NCHN=NCHN+1
37255 ISIG(NCHN,1)=21
37256 ISIG(NCHN,2)=21
37257 ISIG(NCHN,3)=3
37258 SIGH(NCHN)=0.5D0*FACGG3
37259 510 CONTINUE
37260
37261 ELSEIF(ISUB.EQ.387) THEN
37262C...q + qbar -> Q + Qbar
37263 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37264 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37265 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37266 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37267 & 2D0*SQMAVG/SH)
37268 IF(ITCM(5).GE.5) THEN
37269 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37270 FACQQB=FACQQB*SH2*SQDQTS
37271 ELSE
37272 FACQQB=FACQQB*SH2*SQDQQS
37273 ENDIF
37274 ENDIF
37275 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37276 WID2=1D0
37277 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37278 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37279 FACQQB=FACQQB*WID2
37280 DO 520 I=MMINA,MMAXA
37281 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37282 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37283 NCHN=NCHN+1
37284 ISIG(NCHN,1)=I
37285 ISIG(NCHN,2)=-I
37286 ISIG(NCHN,3)=1
37287 SIGH(NCHN)=FACQQB
37288 520 CONTINUE
37289
37290 ELSEIF(ISUB.EQ.388) THEN
37291C...g + g -> Q + Qbar
37292 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37293 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37294 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37295 THUHQ=THQ*UHQ-SQMAVG*SH
37296 IF(MSTP(34).EQ.0) THEN
37297 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37298 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37299 ELSE
37300 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37301 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37302 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37303 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37304 ENDIF
37305 IF(ITCM(5).GE.5) THEN
37306 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37307 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37308 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37309 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37310 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37311 ELSE
37312 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37313 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37314 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37315 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37316 ENDIF
37317 ENDIF
37318 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37319 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37320 IF(MSTP(35).GE.1) THEN
37321 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37322 FACQQ1=FACQQ1*FATRE
37323 FACQQ2=FACQQ2*FATRE
37324 ENDIF
37325 WID2=1D0
37326 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37327 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37328 FACQQ1=FACQQ1*WID2
37329 FACQQ2=FACQQ2*WID2
37330 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37331 NCHN=NCHN+1
37332 ISIG(NCHN,1)=21
37333 ISIG(NCHN,2)=21
37334 ISIG(NCHN,3)=1
37335 SIGH(NCHN)=FACQQ1
37336 NCHN=NCHN+1
37337 ISIG(NCHN,1)=21
37338 ISIG(NCHN,2)=21
37339 ISIG(NCHN,3)=2
37340 SIGH(NCHN)=FACQQ2
37341 530 CONTINUE
37342 ENDIF
37343 ENDIF
37344
37345CMRENNA--
37346
37347 RETURN
37348 END
37349
37350C*********************************************************************
37351
37352C...PYSGEX
37353C...Subprocess cross sections for assorted exotic processes,
37354C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
37355C...Auxiliary to PYSIGH.
37356
37357 SUBROUTINE PYSGEX(NCHN,SIGS)
37358
37359C...Double precision and integer declarations
37360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
37361 IMPLICIT INTEGER(I-N)
37362 INTEGER PYK,PYCHGE,PYCOMP
37363C...Parameter statement to help give large particle numbers.
37364 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
37365 &KEXCIT=4000000,KDIMEN=5000000)
37366C...Commonblocks
37367 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
37368 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
37369 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
37370 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
37371 COMMON/PYINT1/MINT(400),VINT(400)
37372 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
37373 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
37374 COMMON/PYINT4/MWID(500),WIDS(500,5)
37375 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
37376 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
37377 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
37378 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
37379 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
37380 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
37381 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
37382C...Local arrays
37383 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
37384
37385C...Differential cross section expressions.
37386
37387 IF(ISUB.LE.160) THEN
37388 IF(ISUB.EQ.141) THEN
37389C...f + fbar -> gamma*/Z0/Z'0
37390 SQMZP=PMAS(32,1)**2
37391 MINT(61)=2
37392 CALL PYWIDT(32,SH,WDTP,WDTE)
37393 HP0=AEM/3D0*SH
37394 HP1=AEM/3D0*XWC*SH
37395 HP2=HP1
37396 HS=SHR*VINT(117)
37397 HSP=SHR*WDTP(0)
37398 FACZP=4D0*COMFAC*3D0
37399 DO 100 I=MMINA,MMAXA
37400 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
37401 EI=KCHG(IABS(I),1)/3D0
37402 AI=SIGN(1D0,EI)
37403 VI=AI-4D0*EI*XWV
37404 IA=IABS(I)
37405 IF(IA.LT.10) THEN
37406 IF(IA.LE.2) THEN
37407 VPI=PARU(123-2*MOD(IABS(I),2))
37408 API=PARU(124-2*MOD(IABS(I),2))
37409 ELSEIF(IA.LE.4) THEN
37410 VPI=PARJ(182-2*MOD(IABS(I),2))
37411 API=PARJ(183-2*MOD(IABS(I),2))
37412 ELSE
37413 VPI=PARJ(190-2*MOD(IABS(I),2))
37414 API=PARJ(191-2*MOD(IABS(I),2))
37415 ENDIF
37416 ELSE
37417 IF(IA.LE.12) THEN
37418 VPI=PARU(127-2*MOD(IABS(I),2))
37419 API=PARU(128-2*MOD(IABS(I),2))
37420 ELSEIF(IA.LE.14) THEN
37421 VPI=PARJ(186-2*MOD(IABS(I),2))
37422 API=PARJ(187-2*MOD(IABS(I),2))
37423 ELSE
37424 VPI=PARJ(194-2*MOD(IABS(I),2))
37425 API=PARJ(195-2*MOD(IABS(I),2))
37426 ENDIF
37427 ENDIF
37428 HI0=HP0
37429 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
37430 HI1=HP1
37431 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
37432 HI2=HP2
37433 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
37434 NCHN=NCHN+1
37435 ISIG(NCHN,1)=I
37436 ISIG(NCHN,2)=-I
37437 ISIG(NCHN,3)=1
37438C...Special case: if only branching ratios known then use them.
37439 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
37440 HI=0D0
37441 IF(IA.LT.10) THEN
37442 HI=SHR*WDTP(IA)*FACA/9D0
37443 ELSEIF(IA.LT.20) THEN
37444 HI=SHR*WDTP(IA-2)
37445 ENDIF
37446 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37447 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
37448 ELSE
37449C...Normal cross section.
37450 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
37451 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
37452 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
37453 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
37454 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
37455 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
37456 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
37457 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
37458 ENDIF
37459 100 CONTINUE
37460
37461 ELSEIF(ISUB.EQ.142) THEN
37462C...f + fbar' -> W'+/-
37463 SQMWP=PMAS(34,1)**2
37464 CALL PYWIDT(34,SH,WDTP,WDTE)
37465 HS=SHR*WDTP(0)
37466 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
37467 HP=AEM/(24D0*XW)*SH
37468 DO 120 I=MMIN1,MMAX1
37469 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
37470 IA=IABS(I)
37471 DO 110 J=MMIN2,MMAX2
37472 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
37473 JA=IABS(J)
37474 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
37475 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37476 & GOTO 110
37477 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37478C...Special case: if only branching ratios known then use them.
37479 IF(MWID(34).EQ.2) THEN
37480 HI=0D0
37481 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
37482 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
37483 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
37484 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
37485 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
37486 105 CONTINUE
37487 IF(IA.LT.10) HI=HI*FACA/9D0
37488 ELSE
37489C...Normal cross section.
37490 HI=HP*(PARU(133)**2+PARU(134)**2)
37491 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
37492 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37493 ENDIF
37494 NCHN=NCHN+1
37495 ISIG(NCHN,1)=I
37496 ISIG(NCHN,2)=J
37497 ISIG(NCHN,3)=1
37498 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
37499 SIGH(NCHN)=HI*FACBW*HF
37500 110 CONTINUE
37501 120 CONTINUE
37502
37503 ELSEIF(ISUB.EQ.144) THEN
37504C...f + fbar' -> R
37505 SQMR=PMAS(41,1)**2
37506 CALL PYWIDT(41,SH,WDTP,WDTE)
37507 HS=SHR*WDTP(0)
37508 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
37509 HP=AEM/(12D0*XW)*SH
37510 DO 140 I=MMIN1,MMAX1
37511 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
37512 IA=IABS(I)
37513 DO 130 J=MMIN2,MMAX2
37514 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
37515 JA=IABS(J)
37516 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
37517 HI=HP
37518 IF(IA.LE.10) HI=HI*FACA/3D0
37519 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
37520 NCHN=NCHN+1
37521 ISIG(NCHN,1)=I
37522 ISIG(NCHN,2)=J
37523 ISIG(NCHN,3)=1
37524 SIGH(NCHN)=HI*FACBW*HF
37525 130 CONTINUE
37526 140 CONTINUE
37527
37528 ELSEIF(ISUB.EQ.145) THEN
37529C...q + l -> LQ (leptoquark)
37530 SQMLQ=PMAS(42,1)**2
37531 CALL PYWIDT(42,SH,WDTP,WDTE)
37532 HS=SHR*WDTP(0)
37533 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
37534 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
37535 HP=AEM/4D0*SH
37536 KFLQQ=KFDP(MDCY(42,2),1)
37537 KFLQL=KFDP(MDCY(42,2),2)
37538 DO 160 I=MMIN1,MMAX1
37539 IF(KFAC(1,I).EQ.0) GOTO 160
37540 IA=IABS(I)
37541 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
37542 DO 150 J=MMIN2,MMAX2
37543 IF(KFAC(2,J).EQ.0) GOTO 150
37544 JA=IABS(J)
37545 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
37546 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
37547 IF(JA.EQ.IA) GOTO 150
37548 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
37549 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
37550 HI=HP*PARU(151)
37551 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
37552 NCHN=NCHN+1
37553 ISIG(NCHN,1)=I
37554 ISIG(NCHN,2)=J
37555 ISIG(NCHN,3)=1
37556 SIGH(NCHN)=HI*FACBW*HF
37557 150 CONTINUE
37558 160 CONTINUE
37559
37560 ELSEIF(ISUB.EQ.146) THEN
37561C...e + gamma* -> e* (excited lepton)
37562 KFQSTR=KFPR(ISUB,1)
37563 KCQSTR=PYCOMP(KFQSTR)
37564 KFQEXC=MOD(KFQSTR,KEXCIT)
37565 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37566 HS=SHR*WDTP(0)
37567 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37568 QF=-RTCM(43)/2D0-RTCM(44)/2D0
37569 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
37570 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37571 & FACBW=0D0
37572 HP=SH
37573 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
37574 DO 170 ISDE=1,2
37575 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
37576 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
37577 HI=HP
37578 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37579 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37580 NCHN=NCHN+1
37581 ISIG(NCHN,ISDE)=I
37582 ISIG(NCHN,3-ISDE)=22
37583 ISIG(NCHN,3)=1
37584 SIGH(NCHN)=HI*FACBW*HF
37585 170 CONTINUE
37586 180 CONTINUE
37587
37588 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
37589C...d + g -> d* and u + g -> u* (excited quarks)
37590 KFQSTR=KFPR(ISUB,1)
37591 KCQSTR=PYCOMP(KFQSTR)
37592 KFQEXC=MOD(KFQSTR,KEXCIT)
37593 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
37594 HS=SHR*WDTP(0)
37595 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
37596 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
37597 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
37598 & FACBW=0D0
37599 HP=SH
37600 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
37601 DO 190 ISDE=1,2
37602 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
37603 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
37604 HI=HP
37605 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37606 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
37607 NCHN=NCHN+1
37608 ISIG(NCHN,ISDE)=I
37609 ISIG(NCHN,3-ISDE)=21
37610 ISIG(NCHN,3)=1
37611 SIGH(NCHN)=HI*FACBW*HF
37612 190 CONTINUE
37613 200 CONTINUE
37614 ENDIF
37615
37616 ELSEIF(ISUB.LE.190) THEN
37617 IF(ISUB.EQ.162) THEN
37618C...q + g -> LQ + lbar; LQ=leptoquark
37619 SQMLQ=PMAS(42,1)**2
37620 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
37621 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
37622 KFLQQ=KFDP(MDCY(42,2),1)
37623 DO 220 I=MMINA,MMAXA
37624 IF(IABS(I).NE.KFLQQ) GOTO 220
37625 KCHLQ=ISIGN(1,I)
37626 DO 210 ISDE=1,2
37627 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
37628 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
37629 NCHN=NCHN+1
37630 ISIG(NCHN,ISDE)=I
37631 ISIG(NCHN,3-ISDE)=21
37632 ISIG(NCHN,3)=1
37633 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
37634 210 CONTINUE
37635 220 CONTINUE
37636
37637 ELSEIF(ISUB.EQ.163) THEN
37638C...g + g -> LQ + LQbar; LQ=leptoquark
37639 SQMLQ=PMAS(42,1)**2
37640 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
37641 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
37642 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
37643 & ((TH-SQMLQ)*(UH-SQMLQ)))
37644 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
37645 NCHN=NCHN+1
37646 ISIG(NCHN,1)=21
37647 ISIG(NCHN,2)=21
37648C...Since don't know proper colour flow, randomize between alternatives
37649 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
37650 SIGH(NCHN)=FACLQ
37651 230 CONTINUE
37652
37653 ELSEIF(ISUB.EQ.164) THEN
37654C...q + qbar -> LQ + LQbar; LQ=leptoquark
37655 DELTA=0.25D0*(SQM3-SQM4)**2/SH
37656 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
37657 TH=TH-DELTA
37658 UH=UH-DELTA
37659C SQMLQ=PMAS(42,1)**2
37660 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
37661 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
37662 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
37663 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
37664 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
37665 KFLQQ=KFDP(MDCY(42,2),1)
37666 DO 240 I=MMINA,MMAXA
37667 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37668 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
37669 NCHN=NCHN+1
37670 ISIG(NCHN,1)=I
37671 ISIG(NCHN,2)=-I
37672 ISIG(NCHN,3)=1
37673 SIGH(NCHN)=FACLQA
37674 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
37675 240 CONTINUE
37676
37677 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
37678C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
37679 KFQSTR=KFPR(ISUB,2)
37680 KCQSTR=PYCOMP(KFQSTR)
37681 KFQEXC=MOD(KFQSTR,KEXCIT)
37682 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
37683 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37684 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37685C...Propagators: as simulated in PYOFSH and as desired
37686 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37687 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37688 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37689 GMMQC=SQRT(SQM4)*WDTP(0)
37690 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37691 FACQSA=FACQSA*HBW4C/HBW4
37692 FACQSB=FACQSB*HBW4C/HBW4
37693C...Branching ratios.
37694 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37695 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37696 DO 260 I=MMIN1,MMAX1
37697 IA=IABS(I)
37698 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
37699 DO 250 J=MMIN2,MMAX2
37700 JA=IABS(J)
37701 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
37702 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
37703 NCHN=NCHN+1
37704 ISIG(NCHN,1)=I
37705 ISIG(NCHN,2)=J
37706 ISIG(NCHN,3)=1
37707 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37708 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37709 NCHN=NCHN+1
37710 ISIG(NCHN,1)=I
37711 ISIG(NCHN,2)=J
37712 ISIG(NCHN,3)=2
37713 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
37714 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
37715 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
37716 NCHN=NCHN+1
37717 ISIG(NCHN,1)=I
37718 ISIG(NCHN,2)=J
37719 ISIG(NCHN,3)=1
37720 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37721 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
37722 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
37723 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
37724 NCHN=NCHN+1
37725 ISIG(NCHN,1)=I
37726 ISIG(NCHN,2)=J
37727 ISIG(NCHN,3)=1
37728 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37729 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37730 NCHN=NCHN+1
37731 ISIG(NCHN,1)=I
37732 ISIG(NCHN,2)=J
37733 ISIG(NCHN,3)=2
37734 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
37735 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
37736 ELSEIF(I.EQ.-J) THEN
37737 NCHN=NCHN+1
37738 ISIG(NCHN,1)=I
37739 ISIG(NCHN,2)=J
37740 ISIG(NCHN,3)=1
37741 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37742 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37743 NCHN=NCHN+1
37744 ISIG(NCHN,1)=I
37745 ISIG(NCHN,2)=J
37746 ISIG(NCHN,3)=2
37747 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37748 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37749 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
37750 NCHN=NCHN+1
37751 ISIG(NCHN,1)=I
37752 ISIG(NCHN,2)=J
37753 ISIG(NCHN,3)=1
37754 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
37755 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
37756 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
37757 ENDIF
37758 250 CONTINUE
37759 260 CONTINUE
37760
37761 ELSEIF(ISUB.EQ.169) THEN
37762C...q + qbar -> e + e* (excited lepton)
37763 KFQSTR=KFPR(ISUB,2)
37764 KCQSTR=PYCOMP(KFQSTR)
37765 KFQEXC=MOD(KFQSTR,KEXCIT)
37766 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
37767 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
37768C...Propagators: as simulated in PYOFSH and as desired
37769 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
37770 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
37771 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
37772 GMMQC=SQRT(SQM4)*WDTP(0)
37773 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
37774 FACQSB=FACQSB*HBW4C/HBW4
37775C...Branching ratios.
37776 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
37777 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
37778 DO 270 I=MMIN1,MMAX1
37779 IA=IABS(I)
37780 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
37781 J=-I
37782 JA=IABS(J)
37783 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
37784 NCHN=NCHN+1
37785 ISIG(NCHN,1)=I
37786 ISIG(NCHN,2)=J
37787 ISIG(NCHN,3)=1
37788 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37789 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37790 NCHN=NCHN+1
37791 ISIG(NCHN,1)=I
37792 ISIG(NCHN,2)=J
37793 ISIG(NCHN,3)=2
37794 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
37795 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
37796 270 CONTINUE
37797 ENDIF
37798
37799 ELSEIF(ISUB.LE.360) THEN
37800 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
37801C...l + l -> H_L++/-- or H_R++/--.
37802 KFRES=KFPR(ISUB,1)
37803 KFREC=PYCOMP(KFRES)
37804 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37805 HS=SHR*WDTP(0)
37806 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
37807 DO 290 I=MMIN1,MMAX1
37808 IA=IABS(I)
37809 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
37810 & GOTO 290
37811 DO 280 J=MMIN2,MMAX2
37812 JA=IABS(J)
37813 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
37814 & GOTO 280
37815 IF(I*J.LT.0) GOTO 280
37816 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37817 NCHN=NCHN+1
37818 ISIG(NCHN,1)=I
37819 ISIG(NCHN,2)=J
37820 ISIG(NCHN,3)=1
37821 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
37822 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37823 SIGH(NCHN)=HI*FACBW*HF
37824 280 CONTINUE
37825 290 CONTINUE
37826
37827 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
37828C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
37829 KFRES=KFPR(ISUB,1)
37830 KFREC=PYCOMP(KFRES)
37831C...Propagators: as simulated in PYOFSH and as desired
37832 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
37833 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
37834 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37835 GMMC=SQRT(SQM3)*WDTP(0)
37836 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
37837 FHCC=COMFAC*AEM*HBW3C/HBW3
37838 DO 310 I=MMINA,MMAXA
37839 IA=IABS(I)
37840 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
37841 SQML=PMAS(IA,1)**2
37842 J=ISIGN(KFPR(ISUB,2),-I)
37843 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
37844 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
37845 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
37846 & (UH-SQM3)**2
37847 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
37848 & (TH-SQM4)*SH)/(TH-SQM4)**2
37849 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
37850 & SH)/(SH-SQML)**2
37851 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
37852 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
37853 & ((UH-SQM3)*(TH-SQM4))
37854 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
37855 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
37856 & ((UH-SQM3)*(SH-SQML))
37857 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
37858 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
37859 & ((SH-SQML)*(TH-SQM4))
37860 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
37861 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
37862 DO 300 ISDE=1,2
37863 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
37864 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
37865 NCHN=NCHN+1
37866 ISIG(NCHN,ISDE)=I
37867 ISIG(NCHN,3-ISDE)=22
37868 ISIG(NCHN,3)=0
37869 SIGH(NCHN)=FHCC*SMM*WIDSC
37870 300 CONTINUE
37871 310 CONTINUE
37872
37873 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
37874C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
37875 KFRES=KFPR(ISUB,1)
37876 KFREC=PYCOMP(KFRES)
37877 SQMH=PMAS(KFREC,1)**2
37878 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
37879C...Propagators: H++/-- as simulated in PYOFSH and as desired
37880 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
37881 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
37882 GMMH3=SQRT(SQM3)*WDTP(0)
37883 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
37884 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
37885 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
37886 GMMH4=SQRT(SQM4)*WDTP(0)
37887 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
37888C...Kinematical and coupling functions
37889 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
37890 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
37891C...Loop over allowed flavours
37892 DO 320 I=MMINA,MMAXA
37893 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37894 EI=KCHG(IABS(I),1)/3D0
37895 AI=SIGN(1D0,EI+0.1D0)
37896 VI=AI-4D0*EI*XWV
37897 FCOI=1D0
37898 IF(IABS(I).LE.10) FCOI=FACA/3D0
37899 IF(ISUB.EQ.349) THEN
37900 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
37901 IF(IABS(I).LT.10) THEN
37902 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37903 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37904 & (VI**2+AI**2)*XWHH**2*HBWZ)
37905 ELSE
37906 IAOFF=181+3*((IABS(I)-11)/2)
37907 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37908 & (4D0*PARU(1))
37909 DSIGHH=8D0*AEM**2*(EI**2/SH2+
37910 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
37911 & (VI**2+AI**2)*XWHH**2*HBWZ)+
37912 & 8D0*AEM*(EI*HSUM/(SH*TH)+
37913 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
37914 & 4D0*HSUM**2/TH2
37915 ENDIF
37916 ELSE
37917 IF(IABS(I).LT.10) THEN
37918 DSIGHH=8D0*AEM**2*EI**2/SH2
37919 ELSE
37920 IAOFF=181+3*((IABS(I)-11)/2)
37921 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
37922 & (4D0*PARU(1))
37923 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
37924 & 4D0*HSUM**2/TH2
37925 ENDIF
37926 ENDIF
37927 NCHN=NCHN+1
37928 ISIG(NCHN,1)=I
37929 ISIG(NCHN,2)=-I
37930 ISIG(NCHN,3)=1
37931 SIGH(NCHN)=FACHH*FCOI*DSIGHH
37932 320 CONTINUE
37933
37934 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
37935C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
37936 KFRES=KFPR(ISUB,1)
37937 KFREC=PYCOMP(KFRES)
37938 SQMH=PMAS(KFREC,1)**2
37939 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
37940 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
37941 & PMAS(PYCOMP(9900024),1)**2
37942 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
37943 FACPRT=1D0/((VINT(204)**2-VINT(215))*
37944 & (VINT(209)**2-VINT(216)))
37945 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
37946 & (VINT(209)**2+2D0*VINT(218)))
37947 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
37948 HS=SHR*WDTP(0)
37949 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
37950 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
37951 & FACBW=0D0
37952 DO 340 I=MMIN1,MMAX1
37953 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
37954 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
37955 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
37956 DO 330 J=MMIN2,MMAX2
37957 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
37958 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
37959 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
37960 KCHH=KCHWI+KCHWJ
37961 IF(IABS(KCHH).NE.2) GOTO 330
37962 FACLR=VINT(180+I)*VINT(180+J)
37963 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
37964 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
37965 FACPRP=0.5D0*(FACPRT+FACPRU)**2
37966 ELSE
37967 FACPRP=FACPRT**2
37968 ENDIF
37969 NCHN=NCHN+1
37970 ISIG(NCHN,1)=I
37971 ISIG(NCHN,2)=J
37972 ISIG(NCHN,3)=1
37973 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
37974 330 CONTINUE
37975 340 CONTINUE
37976
37977 ELSEIF(ISUB.EQ.353) THEN
37978C...f + fbar -> Z_R0
37979 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
37980 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
37981 HS=SHR*WDTP(0)
37982 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
37983 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37984 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
37985 DO 350 I=MMINA,MMAXA
37986 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
37987 IF(IABS(I).LE.8) THEN
37988 EI=KCHG(IABS(I),1)/3D0
37989 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
37990 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
37991 ELSE
37992 AI=-(1D0-2D0*XW)
37993 VI=-1D0+4D0*XW
37994 ENDIF
37995 HI=HP*(VI**2+AI**2)
37996 IF(IABS(I).LE.10) HI=HI*FACA/3D0
37997 NCHN=NCHN+1
37998 ISIG(NCHN,1)=I
37999 ISIG(NCHN,2)=-I
38000 ISIG(NCHN,3)=1
38001 SIGH(NCHN)=HI*FACBW*HF
38002 350 CONTINUE
38003
38004 ELSEIF(ISUB.EQ.354) THEN
38005C...f + fbar' -> W_R+/-
38006 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38007 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38008 HS=SHR*WDTP(0)
38009 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38010 HP=AEM/(24D0*XW)*SH
38011 DO 370 I=MMIN1,MMAX1
38012 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38013 IA=IABS(I)
38014 DO 360 J=MMIN2,MMAX2
38015 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38016 JA=IABS(J)
38017 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38018 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38019 & GOTO 360
38020 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38021 HI=HP*2D0
38022 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38023 NCHN=NCHN+1
38024 ISIG(NCHN,1)=I
38025 ISIG(NCHN,2)=J
38026 ISIG(NCHN,3)=1
38027 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38028 SIGH(NCHN)=HI*FACBW*HF
38029 360 CONTINUE
38030 370 CONTINUE
38031 ENDIF
38032
38033 ELSEIF(ISUB.LE.400) THEN
38034 IF(ISUB.EQ.391) THEN
38035C...f + fbar -> G*.
38036 KFGSTR=KFPR(ISUB,1)
38037 KCGSTR=PYCOMP(KFGSTR)
38038 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38039 HS=SHR*WDTP(0)
38040 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38041 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38042 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38043C...Modify cross section in wings of peak.
38044 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38045 DO 380 I=MMINA,MMAXA
38046 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38047 HI=1D0
38048 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38049 NCHN=NCHN+1
38050 ISIG(NCHN,1)=I
38051 ISIG(NCHN,2)=-I
38052 ISIG(NCHN,3)=1
38053 SIGH(NCHN)=FACG*HI
38054 380 CONTINUE
38055
38056 ELSEIF(ISUB.EQ.392) THEN
38057C...g + g -> G*.
38058 KFGSTR=KFPR(ISUB,1)
38059 KCGSTR=PYCOMP(KFGSTR)
38060 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38061 HS=SHR*WDTP(0)
38062 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38063 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38064 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38065C...Modify cross section in wings of peak.
38066 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38067 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38068 NCHN=NCHN+1
38069 ISIG(NCHN,1)=21
38070 ISIG(NCHN,2)=21
38071 ISIG(NCHN,3)=1
38072 SIGH(NCHN)=FACG
38073 390 CONTINUE
38074
38075 ELSEIF(ISUB.EQ.393) THEN
38076C...q + qbar -> g + G*.
38077 KFGSTR=KFPR(ISUB,2)
38078 KCGSTR=PYCOMP(KFGSTR)
38079 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38080 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38081 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38082 & 2D0*SH2/(TH*UH))
38083C...Propagators: as simulated in PYOFSH and as desired
38084 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38085 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38086 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38087 HS=SQRT(SQM4)*WDTP(0)
38088 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38089 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38090 FACG=FACG*HBW4C/HBW4
38091 DO 400 I=MMINA,MMAXA
38092 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38093 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38094 NCHN=NCHN+1
38095 ISIG(NCHN,1)=I
38096 ISIG(NCHN,2)=-I
38097 ISIG(NCHN,3)=1
38098 SIGH(NCHN)=FACG
38099 400 CONTINUE
38100
38101 ELSEIF(ISUB.EQ.394) THEN
38102C...q + g -> q + G*.
38103 KFGSTR=KFPR(ISUB,2)
38104 KCGSTR=PYCOMP(KFGSTR)
38105 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38106 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38107 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38108 & 2D0*TH2*TH/(UH*SH2))
38109C...Propagators: as simulated in PYOFSH and as desired
38110 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38111 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38112 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38113 HS=SQRT(SQM4)*WDTP(0)
38114 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38115 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38116 FACG=FACG*HBW4C/HBW4
38117 DO 420 I=MMINA,MMAXA
38118 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38119 DO 410 ISDE=1,2
38120 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38121 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38122 NCHN=NCHN+1
38123 ISIG(NCHN,ISDE)=I
38124 ISIG(NCHN,3-ISDE)=21
38125 ISIG(NCHN,3)=1
38126 SIGH(NCHN)=FACG
38127 410 CONTINUE
38128 420 CONTINUE
38129
38130 ELSEIF(ISUB.EQ.395) THEN
38131C...g + g -> g + G*.
38132 KFGSTR=KFPR(ISUB,2)
38133 KCGSTR=PYCOMP(KFGSTR)
38134 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38135 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38136 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38137C...Propagators: as simulated in PYOFSH and as desired
38138 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38139 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38140 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38141 HS=SQRT(SQM4)*WDTP(0)
38142 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38143 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38144 FACG=FACG*HBW4C/HBW4
38145 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38146 NCHN=NCHN+1
38147 ISIG(NCHN,1)=21
38148 ISIG(NCHN,2)=21
38149 ISIG(NCHN,3)=1
38150 SIGH(NCHN)=FACG
38151 ENDIF
38152 ENDIF
38153 ENDIF
38154
38155 RETURN
38156 END
38157
38158C*********************************************************************
38159
38160C...PYPDFU
38161C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38162C...parton distributions according to a few different parametrizations.
38163C...Note that what is coded is x times the probability distribution,
38164C...i.e. xq(x,Q2) etc.
38165
38166 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38167
38168C...Double precision and integer declarations.
38169 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38170 IMPLICIT INTEGER(I-N)
38171 INTEGER PYK,PYCHGE,PYCOMP
38172C...Commonblocks.
38173 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38174 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38175 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38176 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38177 COMMON/PYINT1/MINT(400),VINT(400)
38178 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38179 &XPDIR(-6:6)
38180 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38181 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38182 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38183 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38184 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38185 &/PYINT9/,/PYINTM/
38186C...Local arrays.
38187 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38188 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38189 SAVE PPAR
38190
38191C...Interface to PDFLIB.
38192 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38193 SAVE /W50513/
38194 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38195 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38196 CHARACTER*20 PARM(20)
38197 DATA VALUE/20*0D0/,PARM/20*' '/
38198
38199C...Data related to Schuler-Sjostrand photon distributions.
38200 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38201
38202C...Valence PDF momentum integral parametrizations PER PARTON!
38203 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38204 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38205 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38206 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38207
38208C...Reset parton distributions.
38209 MINT(92)=0
38210 DO 100 KFL=-25,25
38211 XPQ(KFL)=0D0
38212 100 CONTINUE
38213 DO 110 KFL=-6,6
38214 XPVAL(KFL)=0D0
38215 110 CONTINUE
38216
38217C...Check x and particle species.
38218 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38219 WRITE(MSTU(11),5000) X
38220 GOTO 9999
38221 ENDIF
38222 KFA=IABS(KF)
38223 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38224 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38225 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38226 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38227 &KFA.NE.310.AND.KFA.NE.130) THEN
38228 WRITE(MSTU(11),5100) KF
38229 GOTO 9999
38230 ENDIF
38231
38232C...Electron (or muon or tau) parton distribution call.
38233 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38234 CALL PYPDEL(KFA,X,Q2,XPEL)
38235 DO 120 KFL=-25,25
38236 XPQ(KFL)=XPEL(KFL)
38237 120 CONTINUE
38238
38239C...Photon parton distribution call (VDM+anomalous).
38240 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38241 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38242 CALL PYPDGA(X,Q2,XPGA)
38243 DO 130 KFL=-6,6
38244 XPQ(KFL)=XPGA(KFL)
38245 130 CONTINUE
38246 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38247 XPVAL(1)=XPVU/4D0
38248 XPVAL(2)=XPVU
38249 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38250 XPVAL(4)=MIN(XPQ(4),XPVU)
38251 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38252 XPVAL(-1)=XPVAL(1)
38253 XPVAL(-2)=XPVAL(2)
38254 XPVAL(-3)=XPVAL(3)
38255 XPVAL(-4)=XPVAL(4)
38256 XPVAL(-5)=XPVAL(5)
38257 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
38258 Q2MX=Q2
38259 P2MX=0.36D0
38260 IF(MSTP(55).GE.7) P2MX=4.0D0
38261 IF(MSTP(57).EQ.0) Q2MX=P2MX
38262 P2=0D0
38263 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38264 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38265 DO 140 KFL=-6,6
38266 XPQ(KFL)=XPGA(KFL)
38267 XPVAL(KFL)=VXPDGM(KFL)
38268 140 CONTINUE
38269 VINT(231)=P2MX
38270 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
38271 Q2MX=Q2
38272 P2MX=0.36D0
38273 IF(MSTP(55).GE.11) P2MX=4.0D0
38274 IF(MSTP(57).EQ.0) Q2MX=P2MX
38275 P2=0D0
38276 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38277 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38278 DO 150 KFL=-6,6
38279 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38280 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
38281 150 CONTINUE
38282 VINT(231)=P2MX
38283 ELSEIF(MSTP(56).EQ.2) THEN
38284C...Call PDFLIB parton distributions.
38285 PARM(1)='NPTYPE'
38286 VALUE(1)=3
38287 PARM(2)='NGROUP'
38288 VALUE(2)=MSTP(55)/1000
38289 PARM(3)='NSET'
38290 VALUE(3)=MOD(MSTP(55),1000)
38291 IF(MINT(93).NE.3000000+MSTP(55)) THEN
38292 CALL PDFSET_ALICE(PARM,VALUE)
38293 MINT(93)=3000000+MSTP(55)
38294 ENDIF
38295 XX=X
38296 QQ2=MAX(0D0,Q2MIN,Q2)
38297 IF(MSTP(57).EQ.0) QQ2=Q2MIN
38298 P2=0D0
38299 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38300 IP2=MSTP(60)
38301 IF(MSTP(55).EQ.5004) THEN
38302 IF(5D0*P2.LT.QQ2.AND.
38303 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
38304 & P2.GE.0D0.AND.P2.LT.10D0.AND.
38305 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
38306 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38307 & BOT,TOP,GLU)
38308 ELSE
38309 UPV=0D0
38310 DNV=0D0
38311 USEA=0D0
38312 DSEA=0D0
38313 STR=0D0
38314 CHM=0D0
38315 BOT=0D0
38316 TOP=0D0
38317 GLU=0D0
38318 ENDIF
38319 ELSE
38320 IF(P2.LT.QQ2) THEN
38321 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
38322 & BOT,TOP,GLU)
38323 ELSE
38324 UPV=0D0
38325 DNV=0D0
38326 USEA=0D0
38327 DSEA=0D0
38328 STR=0D0
38329 CHM=0D0
38330 BOT=0D0
38331 TOP=0D0
38332 GLU=0D0
38333 ENDIF
38334 ENDIF
38335 VINT(231)=Q2MIN
38336 XPQ(0)=GLU
38337 XPQ(1)=DNV
38338 XPQ(-1)=DNV
38339 XPQ(2)=UPV
38340 XPQ(-2)=UPV
38341 XPQ(3)=STR
38342 XPQ(-3)=STR
38343 XPQ(4)=CHM
38344 XPQ(-4)=CHM
38345 XPQ(5)=BOT
38346 XPQ(-5)=BOT
38347 XPQ(6)=TOP
38348 XPQ(-6)=TOP
38349 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
38350 XPVAL(1)=XPVU/4D0
38351 XPVAL(2)=XPVU
38352 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
38353 XPVAL(4)=MIN(XPQ(4),XPVU)
38354 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
38355 XPVAL(-1)=XPVAL(1)
38356 XPVAL(-2)=XPVAL(2)
38357 XPVAL(-3)=XPVAL(3)
38358 XPVAL(-4)=XPVAL(4)
38359 XPVAL(-5)=XPVAL(5)
38360 ELSE
38361 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
38362 ENDIF
38363
38364C...Pion/gammaVDM parton distribution call.
38365 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
38366 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38367 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
38368 & MSTP(55).LE.12) THEN
38369 ISET=1+MOD(MSTP(55)-1,4)
38370 Q2MX=Q2
38371 P2MX=0.36D0
38372 IF(ISET.GE.3) P2MX=4.0D0
38373 IF(MSTP(57).EQ.0) Q2MX=P2MX
38374 P2=0D0
38375 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38376 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
38377 DO 160 KFL=-6,6
38378 XPQ(KFL)=XPVMD(KFL)
38379 XPVAL(KFL)=VXPVMD(KFL)
38380 160 CONTINUE
38381 VINT(231)=P2MX
38382 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
38383 CALL PYPDPI(X,Q2,XPPI)
38384 DO 170 KFL=-6,6
38385 XPQ(KFL)=XPPI(KFL)
38386 170 CONTINUE
38387 XPVAL(2)=XPQ(2)-XPQ(-2)
38388 XPVAL(-1)=XPQ(-1)-XPQ(1)
38389 ELSEIF(MSTP(54).EQ.2) THEN
38390C...Call PDFLIB parton distributions.
38391 PARM(1)='NPTYPE'
38392 VALUE(1)=2
38393 PARM(2)='NGROUP'
38394 VALUE(2)=MSTP(53)/1000
38395 PARM(3)='NSET'
38396 VALUE(3)=MOD(MSTP(53),1000)
38397 IF(MINT(93).NE.2000000+MSTP(53)) THEN
38398 CALL PDFSET_ALICE(PARM,VALUE)
38399 MINT(93)=2000000+MSTP(53)
38400 ENDIF
38401 XX=X
38402 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38403 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38404 CALL STRUCTM_ALICE
38405 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38406 VINT(231)=Q2MIN
38407 XPQ(0)=GLU
38408 XPQ(1)=DSEA
38409 XPQ(-1)=UPV+DSEA
38410 XPQ(2)=UPV+USEA
38411 XPQ(-2)=USEA
38412 XPQ(3)=STR
38413 XPQ(-3)=STR
38414 XPQ(4)=CHM
38415 XPQ(-4)=CHM
38416 XPQ(5)=BOT
38417 XPQ(-5)=BOT
38418 XPQ(6)=TOP
38419 XPQ(-6)=TOP
38420 XPVAL(2)=UPV
38421 XPVAL(-1)=UPV
38422 ELSE
38423 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
38424 ENDIF
38425
38426C...Anomalous photon parton distribution call.
38427 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
38428 Q2MX=Q2
38429 P2MX=PARP(15)**2
38430 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
38431 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
38432 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
38433 IF(MSTP(57).EQ.0) Q2MX=P2MX
38434 P2=0D0
38435 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38436 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38437 DO 180 KFL=-6,6
38438 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
38439 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
38440 180 CONTINUE
38441 VINT(231)=P2MX
38442 ELSEIF(MSTP(56).EQ.1) THEN
38443 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
38444 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
38445 IF(MSTP(57).EQ.0) Q2MX=P2MX
38446 P2=0D0
38447 IF(VINT(120).LT.0D0) P2=VINT(120)**2
38448 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
38449 DO 190 KFL=-6,6
38450 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38451 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
38452 190 CONTINUE
38453 VINT(231)=P2MX
38454 ELSEIF(MSTP(56).EQ.2) THEN
38455 IF(MSTP(57).EQ.0) Q2MX=P2MX
38456 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
38457 DO 200 KFL=-6,6
38458 XPQ(KFL)=XPGA(KFL)
38459 XPVAL(KFL)=VXPGA(KFL)
38460 200 CONTINUE
38461 VINT(231)=P2MX
38462 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
38463 IF(MSTP(57).EQ.0) Q2MX=P2MX
38464 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38465 DO 210 KFL=-6,6
38466 XPQ(KFL)=XPGA(KFL)
38467 XPVAL(KFL)=VXPGA(KFL)
38468 210 CONTINUE
38469 VINT(231)=P2MX
38470 ELSE
38471 220 RKF=11D0*PYR(0)
38472 KFR=1
38473 IF(RKF.GT.1D0) KFR=2
38474 IF(RKF.GT.5D0) KFR=3
38475 IF(RKF.GT.6D0) KFR=4
38476 IF(RKF.GT.10D0) KFR=5
38477 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
38478 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
38479 IF(MSTP(57).EQ.0) Q2MX=P2MX
38480 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
38481 DO 230 KFL=-6,6
38482 XPQ(KFL)=XPGA(KFL)
38483 XPVAL(KFL)=VXPGA(KFL)
38484 230 CONTINUE
38485 VINT(231)=P2MX
38486 ENDIF
38487
38488C...Proton parton distribution call.
38489 ELSE
38490 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
38491 CALL PYPDPR(X,Q2,XPPR)
38492 DO 240 KFL=-6,6
38493 XPQ(KFL)=XPPR(KFL)
38494 240 CONTINUE
38495C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
38496 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
38497 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
38498 ELSEIF(MSTP(52).EQ.2) THEN
38499C...Call PDFLIB parton distributions.
38500 PARM(1)='NPTYPE'
38501 VALUE(1)=1
38502 PARM(2)='NGROUP'
38503 VALUE(2)=MSTP(51)/1000
38504 PARM(3)='NSET'
38505 VALUE(3)=MOD(MSTP(51),1000)
38506 IF(MINT(93).NE.1000000+MSTP(51)) THEN
38507 CALL PDFSET_ALICE(PARM,VALUE)
38508 MINT(93)=1000000+MSTP(51)
38509 ENDIF
38510 XX=X
38511 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
38512 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
38513 CALL STRUCTM_ALICE(
38514 & XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
38515 VINT(231)=Q2MIN
38516 XPQ(0)=GLU
38517 XPQ(1)=DNV+DSEA
38518 XPQ(-1)=DSEA
38519 XPQ(2)=UPV+USEA
38520 XPQ(-2)=USEA
38521 XPQ(3)=STR
38522 XPQ(-3)=STR
38523 XPQ(4)=CHM
38524 XPQ(-4)=CHM
38525 XPQ(5)=BOT
38526 XPQ(-5)=BOT
38527 XPQ(6)=TOP
38528 XPQ(-6)=TOP
38529 XPVAL(1)=DNV
38530 XPVAL(2)=UPV
38531 ELSE
38532 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
38533 ENDIF
38534 ENDIF
38535
38536C...Isospin average for pi0/gammaVDM.
38537 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
38538 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
38539 XPV=XPQ(2)-XPQ(1)
38540 XPQ(2)=XPQ(1)
38541 XPQ(-2)=XPQ(-1)
38542 ELSE
38543 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38544 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38545 XPQ(2)=XPS
38546 XPQ(-1)=XPS
38547 ENDIF
38548 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
38549 & XPVAL(3)+XPVAL(4)+XPVAL(5)
38550 DO 250 KFL=-6,6
38551 XPVAL(KFL)=0D0
38552 250 CONTINUE
38553 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
38554 XPQ(1)=XPQ(1)+0.2D0*XPV
38555 XPQ(2)=XPQ(2)+0.8D0*XPV
38556 XPVAL(1)=0.2D0*XPVL
38557 XPVAL(2)=0.8D0*XPVL
38558 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
38559 XPQ(3)=XPQ(3)+XPV
38560 XPVAL(3)=XPVL
38561 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
38562 XPQ(4)=XPQ(4)+XPV
38563 XPVAL(4)=XPVL
38564 IF(MSTP(55).GE.9) THEN
38565 DO 260 KFL=-6,6
38566 XPQ(KFL)=0D0
38567 260 CONTINUE
38568 ENDIF
38569 ELSE
38570 XPQ(1)=XPQ(1)+0.5D0*XPV
38571 XPQ(2)=XPQ(2)+0.5D0*XPV
38572 XPVAL(1)=0.5D0*XPVL
38573 XPVAL(2)=0.5D0*XPVL
38574 ENDIF
38575 DO 270 KFL=1,6
38576 XPQ(-KFL)=XPQ(KFL)
38577 XPVAL(-KFL)=XPVAL(KFL)
38578 270 CONTINUE
38579
38580C...Rescale for gammaVDM by effective gamma -> rho coupling.
38581C+++Do not rescale?
38582 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
38583 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
38584 DO 280 KFL=-6,6
38585 XPQ(KFL)=VINT(281)*XPQ(KFL)
38586 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
38587 280 CONTINUE
38588 VINT(232)=VINT(281)*XPV
38589 ENDIF
38590
38591C...Simple recipes for kaons.
38592 ELSEIF(KFA.EQ.321) THEN
38593 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
38594 XPQ(-1)=XPQ(1)
38595 XPVAL(-3)=XPVAL(-1)
38596 XPVAL(-1)=0D0
38597 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
38598 XPS=0.5D0*(XPQ(1)+XPQ(-2))
38599 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
38600 XPQ(2)=XPS
38601 XPQ(-1)=XPS
38602 XPQ(1)=XPQ(1)+0.5D0*XPV
38603 XPQ(-1)=XPQ(-1)+0.5D0*XPV
38604 XPQ(3)=XPQ(3)+0.5D0*XPV
38605 XPQ(-3)=XPQ(-3)+0.5D0*XPV
38606 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
38607 XPVAL(2)=0D0
38608 XPVAL(-1)=0D0
38609 XPVAL(1)=0.5D0*XPV
38610 XPVAL(-1)=0.5D0*XPV
38611 XPVAL(3)=0.5D0*XPV
38612 XPVAL(-3)=0.5D0*XPV
38613
38614C...Isospin conjugation for neutron.
38615 ELSEIF(KFA.EQ.2112) THEN
38616 XPSV=XPQ(1)
38617 XPQ(1)=XPQ(2)
38618 XPQ(2)=XPSV
38619 XPSV=XPQ(-1)
38620 XPQ(-1)=XPQ(-2)
38621 XPQ(-2)=XPSV
38622 XPSV=XPVAL(1)
38623 XPVAL(1)=XPVAL(2)
38624 XPVAL(2)=XPSV
38625
38626C...Simple recipes for hyperon (average valence parton distribution).
38627 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
38628 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
38629 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
38630 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
38631 XPQ(1)=XPS
38632 XPQ(2)=XPS
38633 XPQ(-1)=XPS
38634 XPQ(-2)=XPS
38635 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
38636 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
38637 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
38638 XPV=(XPVAL(1)+XPVAL(2))/3D0
38639 XPVAL(1)=0D0
38640 XPVAL(2)=0D0
38641 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
38642 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
38643 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
38644 ENDIF
38645
38646C...Charge conjugation for antiparticle.
38647 IF(KF.LT.0) THEN
38648 DO 290 KFL=1,25
38649 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
38650 XPSV=XPQ(KFL)
38651 XPQ(KFL)=XPQ(-KFL)
38652 XPQ(-KFL)=XPSV
38653 290 CONTINUE
38654 DO 300 KFL=1,6
38655 XPSV=XPVAL(KFL)
38656 XPVAL(KFL)=XPVAL(-KFL)
38657 XPVAL(-KFL)=XPSV
38658 300 CONTINUE
38659 ENDIF
38660
38661C...MULTIPLE INTERACTIONS - PDF RESHAPING.
38662C...Set side.
38663 JS=MINT(30)
38664C...Only reshape PDFs for the non-first interactions;
38665C...But need valence/sea separation already from first interaction.
38666 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
38667 KFVSEL=KFIVAL(JS,1)
38668C...If valence quark kicked out of pi0 or gamma then that decides
38669C...whether we should consider state as d dbar, u ubar, s sbar, etc.
38670 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
38671 XPVL=0D0
38672 DO 310 KFL=1,6
38673 XPVL=XPVL+XPVAL(KFL)
38674 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
38675 XPVAL(KFL)=0D0
38676 310 CONTINUE
38677 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
38678 XPVAL(IABS(KFVSEL))=XPVL
38679 DO 320 KFL=1,6
38680 XPQ(-KFL)=XPQ(KFL)
38681 XPVAL(-KFL)=XPVAL(KFL)
38682 320 CONTINUE
38683
38684C...If valence quark kicked out of K0S or K0S then that decides whether
38685C...we should consider state as d sbar or s dbar.
38686 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
38687 KFS=1
38688 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
38689 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38690 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38691 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38692 XPVAL(-KFS)=0D0
38693 KFS=-3*KFS
38694 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
38695 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
38696 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
38697 XPVAL(-KFS)=0D0
38698 ENDIF
38699
38700C...XPQ distributions are nominal for a (signed) beam particle
38701C...of KF type, with 1-Sum(x_prev) rescaled to 1.
38702 CMPFAC=1D0
38703 NRESC=0
38704 345 NRESC=NRESC+1
38705 PVCTOT(JS,-1)=0D0
38706 PVCTOT(JS, 0)=0D0
38707 PVCTOT(JS, 1)=0D0
38708 DO 350 IFL=-6,6
38709 IF(IFL.EQ.0) GOTO 350
38710
38711C...Count up number of original IFL valence quarks.
38712 IVORG=0
38713 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
38714 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
38715 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
38716C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
38717C...bookkeep as if d dbar (for total momentum sum in valence sector).
38718 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
38719C...Count down number of remaining IFL valence quarks. Skip current
38720C...interaction initiator.
38721 IVREM=IVORG
38722 DO 330 I1=1,NMI(JS)
38723 IF (I1.EQ.MINT(36)) GOTO 330
38724 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
38725 & IVREM=IVREM-1
38726 330 CONTINUE
38727
38728C...Separate out original VALENCE and SEA content.
38729 VAL=XPVAL(IFL)
38730 SEA=MAX(0D0,XPQ(IFL)-VAL)
38731 XPSVC(IFL,0)=VAL
38732 XPSVC(IFL,-1)=SEA
38733
38734C...Rescale valence content if changed.
38735 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
38736 & (VAL*IVREM)/IVORG
38737
38738C...Momentum integrals of original and removed valence quarks.
38739 IF(IVORG.NE.0) THEN
38740C...For p/n/pbar/nbar beams can split into d_val and u_val.
38741C...Isospin conjugation for neutrons
38742 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
38743 IAFLP=IABS(IFL)
38744 IF (KFA.EQ.2112) IAFLP=3-IAFLP
38745 VPAVG=PAVG(IAFLP,Q2)
38746C...For other baryons average d_val and u_val, like for PDFs.
38747 ELSEIF(KFA.GT.1000) THEN
38748 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
38749C...For mesons and photon average d_val and u_val and scale by 3/2.
38750C...Very crude, especially for photon.
38751 ELSE
38752 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
38753 ENDIF
38754 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
38755 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
38756 ENDIF
38757
38758C...Now add companions (at X with partner having been at Z=XASSOC).
38759C...NOTE: due to the assumed simple x scaling, the partner was at what
38760C...corresponds to a higher Z than XASSOC, if there were intermediate
38761C...scatterings. Nothing done about that for the moment.
38762 DO 340 IVC=1,NVC(JS,IFL)
38763C...Skip companions that have been kicked out
38764 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
38765 XPSVC(IFL,IVC)=0D0
38766 GOTO 340
38767 ELSE
38768C...Momentum fraction of the partner quark.
38769C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
38770 XS=XASSOC(JS,IFL,IVC)
38771 XREM=VINT(142+JS)
38772 YS=XS/(XREM+XS)
38773C...Momentum fraction of the companion quark.
38774C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
38775 Y=X*(1D0-YS)
38776 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
38777C...Add to momentum sum, with rescaling compensation factor.
38778 XCFAC=(XREM+XS)/XREM*CMPFAC
38779 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
38780 ENDIF
38781 340 CONTINUE
38782 350 CONTINUE
38783
38784C...Wait until all flavours treated, then rescale seas and gluon.
38785 XPSVC(0,-1)=XPQ(0)
38786 XPSVC(0,0)=0D0
38787 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
38788 IF (RSFAC.LE.0D0) THEN
38789C...First calculate factor needed to exactly restore pz cons.
38790 IF (NRESC.EQ.1) CMPFAC =
38791 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
38792C...Add a bit of headroom
38793 CMPFAC=0.99*CMPFAC
38794C...Try a few times if more headroom is needed, then print error message.
38795 IF (NRESC.LE.10) GOTO 345
38796 CALL PYERRM(15,
38797 & '(PYPDFU:) Negative reshaping factor persists!')
38798 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
38799 RSFAC=0D0
38800 ENDIF
38801 DO 370 IFL=-6,6
38802 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
38803C...Also store resulting distributions in XPQ
38804 XPQ(IFL)=0D0
38805 DO 360 ISVC=-1,NVC(JS,IFL)
38806 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
38807 360 CONTINUE
38808 370 CONTINUE
38809C...Save companion reweighting factor for PYPTIS.
38810 VINT(140)=CMPFAC
38811 ENDIF
38812
38813
38814C...Allow gluon also in position 21.
38815 XPQ(21)=XPQ(0)
38816
38817C...Check positivity and reset above maximum allowed flavour.
38818 DO 380 KFL=-25,25
38819 XPQ(KFL)=MAX(0D0,XPQ(KFL))
38820 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
38821 380 CONTINUE
38822
38823C...Formats for error printouts.
38824 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
38825 5100 FORMAT(' Error: illegal particle code for parton distribution;',
38826 &' KF =',I5)
38827 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
38828 &3I5)
38829 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
38830 & ' Removed valence momentum fraction : ',F6.3/
38831 & ' Added companion momentum fraction : ',F6.3/
38832 & ' Resulting rescale factor : ',F6.3)
38833
38834C...Reset side pointer and return
38835 9999 MINT(30)=0
38836
38837 RETURN
38838 END
38839
38840C*********************************************************************
38841
38842C...PYPDFL
38843C...Gives proton parton distribution at small x and/or Q^2 according to
38844C...correct limiting behaviour.
38845
38846 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
38847
38848C...Double precision and integer declarations.
38849 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38850 IMPLICIT INTEGER(I-N)
38851 INTEGER PYK,PYCHGE,PYCOMP
38852C...Commonblocks.
38853 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38854 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38855 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38856 COMMON/PYINT1/MINT(400),VINT(400)
38857 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
38858C...Local arrays.
38859 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
38860 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
38861
38862C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
38863 MINT(92)=0
38864 KFA=IABS(KF)
38865 IACC=0
38866 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
38867 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
38868 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
38869 IF(IACC.EQ.0) THEN
38870 CALL PYPDFU(KF,X,Q2,XPQ)
38871 RETURN
38872 ENDIF
38873
38874C...Reset. Check x.
38875 DO 100 KFL=-25,25
38876 XPQ(KFL)=0D0
38877 100 CONTINUE
38878 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38879 WRITE(MSTU(11),5000) X
38880 RETURN
38881 ENDIF
38882
38883C...Define valence content.
38884 KFC=KF
38885 NV1=2
38886 NV2=1
38887 IF(KF.EQ.2212) THEN
38888 KFV1=2
38889 KFV2=1
38890 ELSEIF(KF.EQ.-2212) THEN
38891 KFV1=-2
38892 KFV2=-1
38893 ELSEIF(KF.EQ.2112) THEN
38894 KFV1=1
38895 KFV2=2
38896 ELSEIF(KF.EQ.-2112) THEN
38897 KFV1=-1
38898 KFV2=-2
38899 ELSEIF(KF.EQ.211) THEN
38900 NV1=1
38901 KFV1=2
38902 KFV2=-1
38903 ELSEIF(KF.EQ.-211) THEN
38904 NV1=1
38905 KFV1=-2
38906 KFV2=1
38907 ELSEIF(MINT(105).LE.223) THEN
38908 KFV1=1
38909 WTV1=0.2D0
38910 KFV2=2
38911 WTV2=0.8D0
38912 ELSEIF(MINT(105).EQ.333) THEN
38913 KFV1=3
38914 WTV1=1.0D0
38915 KFV2=1
38916 WTV2=0.0D0
38917 ELSEIF(MINT(105).EQ.443) THEN
38918 KFV1=4
38919 WTV1=1.0D0
38920 KFV2=1
38921 WTV2=0.0D0
38922 ENDIF
38923
38924C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
38925 MINT30=MINT(30)
38926 CALL PYPDFU(KFC,X,Q2,XPA)
38927 Q2MN=MAX(3D0,VINT(231))
38928 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
38929 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
38930
38931C...Large Q2 and large x: naive call is enough.
38932 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
38933 DO 110 KFL=-25,25
38934 XPQ(KFL)=XPA(KFL)
38935 110 CONTINUE
38936 MINT(92)=1
38937
38938C...Small Q2 and large x: dampen boundary value.
38939 ELSEIF(X.GT.XMN) THEN
38940
38941C...Evaluate at boundary and define dampening factors.
38942 MINT(30)=MINT30
38943 CALL PYPDFU(KFC,X,Q2MN,XPA)
38944 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
38945 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
38946
38947C...Separate valence and sea parts of parton distribution.
38948 IF(KFA.NE.22) THEN
38949 XFV1=XPA(KFV1)-XPA(-KFV1)
38950 XPA(KFV1)=XPA(-KFV1)
38951 XFV2=XPA(KFV2)-XPA(-KFV2)
38952 XPA(KFV2)=XPA(-KFV2)
38953 ELSE
38954 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
38955 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
38956 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
38957 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
38958 ENDIF
38959
38960C...Dampen valence and sea separately. Put back together.
38961 DO 120 KFL=-25,25
38962 XPQ(KFL)=FS*XPA(KFL)
38963 120 CONTINUE
38964 IF(KFA.NE.22) THEN
38965 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
38966 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
38967 ELSE
38968 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
38969 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
38970 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
38971 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
38972 ENDIF
38973 MINT(92)=2
38974
38975C...Large Q2 and small x: interpolate behaviour.
38976 ELSEIF(Q2.GT.Q2MN) THEN
38977
38978C...Evaluate at extremes and define coefficients for interpolation.
38979 MINT(30)=MINT30
38980 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
38981 VI232A=VINT(232)
38982 MINT(30)=MINT30
38983 CALL PYPDFU(KFC,X,Q2B,XPB)
38984 VI232B=VINT(232)
38985 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
38986 FVA=(X/XMN)**0.45D0*FLA
38987 FSA=(X/XMN)**(-0.08D0)*FLA
38988 FB=1D0-FLA
38989
38990C...Separate valence and sea parts of parton distribution.
38991 IF(KFA.NE.22) THEN
38992 XFVA1=XPA(KFV1)-XPA(-KFV1)
38993 XPA(KFV1)=XPA(-KFV1)
38994 XFVA2=XPA(KFV2)-XPA(-KFV2)
38995 XPA(KFV2)=XPA(-KFV2)
38996 XFVB1=XPB(KFV1)-XPB(-KFV1)
38997 XPB(KFV1)=XPB(-KFV1)
38998 XFVB2=XPB(KFV2)-XPB(-KFV2)
38999 XPB(KFV2)=XPB(-KFV2)
39000 ELSE
39001 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39002 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39003 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39004 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39005 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39006 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39007 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39008 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39009 ENDIF
39010
39011C...Interpolate for valence and sea. Put back together.
39012 DO 130 KFL=-25,25
39013 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39014 130 CONTINUE
39015 IF(KFA.NE.22) THEN
39016 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39017 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39018 ELSE
39019 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39020 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39021 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39022 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39023 ENDIF
39024 MINT(92)=3
39025
39026C...Small Q2 and small x: dampen boundary value and add term.
39027 ELSE
39028
39029C...Evaluate at boundary and define dampening factors.
39030 MINT(30)=MINT30
39031 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39032 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39033 FA=1D0-FB
39034 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39035 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39036 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39037 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39038 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39039 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39040
39041C...Separate valence and sea parts of parton distribution.
39042 IF(KFA.NE.22) THEN
39043 XFV1=XPA(KFV1)-XPA(-KFV1)
39044 XPA(KFV1)=XPA(-KFV1)
39045 XFV2=XPA(KFV2)-XPA(-KFV2)
39046 XPA(KFV2)=XPA(-KFV2)
39047 ELSE
39048 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39049 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39050 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39051 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39052 ENDIF
39053
39054C...Dampen valence and sea separately. Add constant terms.
39055C...Put back together.
39056 DO 140 KFL=-25,25
39057 XPQ(KFL)=FSA*XPA(KFL)
39058 140 CONTINUE
39059 IF(KFA.NE.22) THEN
39060 DO 150 KFL=-3,3
39061 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39062 150 CONTINUE
39063 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39064 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39065 ELSE
39066 DO 160 KFL=-3,3
39067 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39068 160 CONTINUE
39069 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39070 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39071 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39072 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39073 ENDIF
39074 XPQ(21)=XPQ(0)
39075 MINT(92)=4
39076 ENDIF
39077
39078C...Format for error printout.
39079 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39080
39081 RETURN
39082 END
39083
39084C*********************************************************************
39085
39086C...PYPDEL
39087C...Gives electron (or muon, or tau) parton distribution.
39088
39089 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39090
39091C...Double precision and integer declarations.
39092 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39093 IMPLICIT INTEGER(I-N)
39094 INTEGER PYK,PYCHGE,PYCOMP
39095C...Commonblocks.
39096 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39097 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39098 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39099 COMMON/PYINT1/MINT(400),VINT(400)
39100 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39101C...Local arrays.
39102 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39103
39104C...Interface to PDFLIB.
39105 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39106 SAVE /W50513/
39107 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39108 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39109 CHARACTER*20 PARM(20)
39110 DATA VALUE/20*0D0/,PARM/20*' '/
39111
39112C...Some common constants.
39113 DO 100 KFL=-25,25
39114 XPEL(KFL)=0D0
39115 100 CONTINUE
39116 AEM=PARU(101)
39117 PME=PMAS(11,1)
39118 IF(KFA.EQ.13) PME=PMAS(13,1)
39119 IF(KFA.EQ.15) PME=PMAS(15,1)
39120 XL=LOG(MAX(1D-10,X))
39121 X1L=LOG(MAX(1D-10,1D0-X))
39122 HLE=LOG(MAX(3D0,Q2/PME**2))
39123 HBE2=(AEM/PARU(1))*(HLE-1D0)
39124
39125C...Electron inside electron, see R. Kleiss et al., in Z physics at
39126C...LEP 1, CERN 89-08, p. 34
39127 IF(MSTP(59).LE.1) THEN
39128 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39129 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39130 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39131 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39132 & 4D0*XL/(1D0-X)-5D0-X)
39133 ELSE
39134 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39135 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39136 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39137 ENDIF
39138C...Zero distribution for very large x and rescale it for intermediate.
39139 IF(X.GT.1D0-1D-10) THEN
39140 HEE=0D0
39141 ELSEIF(X.GT.1D0-1D-7) THEN
39142 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39143 ENDIF
39144 XPEL(KFA)=X*HEE
39145
39146C...Photon and (transverse) W- inside electron.
39147 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39148 IF(MSTP(13).LE.1) THEN
39149 HLG=HLE
39150 ELSE
39151 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39152 ENDIF
39153 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39154 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39155 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39156
39157C...Electron or positron inside photon inside electron.
39158 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39159 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39160 & 2D0*X*(1D0+X)*XL)
39161 XPEL(11)=XPEL(11)+XFSEA
39162 XPEL(-11)=XFSEA
39163
39164C...Initialize PDFLIB photon parton distributions.
39165 IF(MSTP(56).EQ.2) THEN
39166 PARM(1)='NPTYPE'
39167 VALUE(1)=3
39168 PARM(2)='NGROUP'
39169 VALUE(2)=MSTP(55)/1000
39170 PARM(3)='NSET'
39171 VALUE(3)=MOD(MSTP(55),1000)
39172 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39173 CALL PDFSET_ALICE(PARM,VALUE)
39174 MINT(93)=3000000+MSTP(55)
39175 ENDIF
39176 ENDIF
39177
39178C...Quarks and gluons inside photon inside electron:
39179C...numerical convolution required.
39180 DO 110 KFL=0,6
39181 SXP(KFL)=0D0
39182 110 CONTINUE
39183 SUMXPP=0D0
39184 ITER=-1
39185 120 ITER=ITER+1
39186 SUMXP=SUMXPP
39187 NSTP=2**(ITER-1)
39188 IF(ITER.EQ.0) NSTP=2
39189 DO 130 KFL=0,6
39190 SXP(KFL)=0.5D0*SXP(KFL)
39191 130 CONTINUE
39192 WTSTP=0.5D0/NSTP
39193 IF(ITER.EQ.0) WTSTP=0.5D0
39194C...Pick grid of x_{gamma} values logarithmically even.
39195 DO 150 ISTP=1,NSTP
39196 IF(ITER.EQ.0) THEN
39197 XLE=XL*(ISTP-1)
39198 ELSE
39199 XLE=XL*(ISTP-0.5D0)/NSTP
39200 ENDIF
39201 XE=MIN(1D0-1D-10,EXP(XLE))
39202 XG=MIN(1D0-1D-10,X/XE)
39203C...Evaluate photon inside electron parton distribution for convolution.
39204 XPGP=1D0+(1D0-XE)**2
39205 IF(MSTP(13).LE.1) THEN
39206 XPGP=XPGP*HLE
39207 ELSE
39208 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39209 ENDIF
39210C...Evaluate photon parton distributions for convolution.
39211 IF(MSTP(56).EQ.1) THEN
39212 IF(MSTP(55).EQ.1) THEN
39213 CALL PYPDGA(XG,Q2,XPGA)
39214 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39215 Q2MX=Q2
39216 P2MX=0.36D0
39217 IF(MSTP(55).GE.7) 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)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39222 VINT(231)=P2MX
39223 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39224 Q2MX=Q2
39225 P2MX=0.36D0
39226 IF(MSTP(55).GE.11) P2MX=4.0D0
39227 IF(MSTP(57).EQ.0) Q2MX=P2MX
39228 P2=0D0
39229 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39230 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39231 VINT(231)=P2MX
39232 ENDIF
39233 DO 140 KFL=0,5
39234 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39235 140 CONTINUE
39236 ELSEIF(MSTP(56).EQ.2) THEN
39237C...Call PDFLIB parton distributions.
39238 XX=XG
39239 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39240 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39241 CALL STRUCTM_ALICE
39242 & (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
39243 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39244 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39245 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39246 SXP(3)=SXP(3)+WTSTP*XPGP*STR
39247 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
39248 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
39249 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
39250 ENDIF
39251 150 CONTINUE
39252 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
39253 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
39254 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
39255
39256C...Put convolution into output arrays.
39257 FCONV=AEMP*(-XL)
39258 XPEL(0)=FCONV*SXP(0)
39259 DO 160 KFL=1,6
39260 XPEL(KFL)=FCONV*SXP(KFL)
39261 XPEL(-KFL)=XPEL(KFL)
39262 160 CONTINUE
39263 ENDIF
39264
39265 RETURN
39266 END
39267
39268C*********************************************************************
39269
39270C...PYPDGA
39271C...Gives photon parton distribution.
39272
39273 SUBROUTINE PYPDGA(X,Q2,XPGA)
39274
39275C...Double precision and integer declarations.
39276 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39277 IMPLICIT INTEGER(I-N)
39278 INTEGER PYK,PYCHGE,PYCOMP
39279C...Commonblocks.
39280 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39281 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39282 COMMON/PYINT1/MINT(400),VINT(400)
39283 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
39284C...Local arrays.
39285 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
39286 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
39287 &DGCS(4,3),DGDS(4,3),DGES(4,3)
39288
39289C...The following data lines are coefficients needed in the
39290C...Drees and Grassie photon parton distribution parametrization.
39291 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
39292 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
39293 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
39294 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
39295 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
39296 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
39297 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
39298 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
39299 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
39300 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
39301 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
39302 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
39303 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
39304 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
39305 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
39306 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
39307 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
39308 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
39309 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
39310 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
39311 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
39312 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
39313 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
39314 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
39315 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
39316 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
39317
39318C...Photon parton distribution from Drees and Grassie.
39319C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
39320 DO 100 KFL=-6,6
39321 XPGA(KFL)=0D0
39322 100 CONTINUE
39323 VINT(231)=1D0
39324 IF(MSTP(57).LE.0) THEN
39325 T=LOG(1D0/0.16D0)
39326 ELSE
39327 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
39328 ENDIF
39329 X1=1D0-X
39330 NF=3
39331 IF(Q2.GT.25D0) NF=4
39332 IF(Q2.GT.300D0) NF=5
39333 NFE=NF-2
39334 AEM=PARU(101)
39335
39336C...Evaluate gluon content.
39337 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
39338 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
39339 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
39340 XPGL=DGA*X**DGB*X1**DGC
39341
39342C...Evaluate up- and down-type quark content.
39343 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
39344 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
39345 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
39346 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
39347 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
39348 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39349 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
39350 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
39351 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
39352 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
39353 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
39354 DGF=9D0
39355 IF(NF.EQ.4) DGF=10D0
39356 IF(NF.EQ.5) DGF=55D0/6D0
39357 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
39358 IF(NF.LE.3) THEN
39359 XPQU=(XPQS+9D0*XPQN)/6D0
39360 XPQD=(XPQS-4.5D0*XPQN)/6D0
39361 ELSEIF(NF.EQ.4) THEN
39362 XPQU=(XPQS+6D0*XPQN)/8D0
39363 XPQD=(XPQS-6D0*XPQN)/8D0
39364 ELSE
39365 XPQU=(XPQS+7.5D0*XPQN)/10D0
39366 XPQD=(XPQS-5D0*XPQN)/10D0
39367 ENDIF
39368
39369C...Put into output arrays.
39370 XPGA(0)=AEM*XPGL
39371 XPGA(1)=AEM*XPQD
39372 XPGA(2)=AEM*XPQU
39373 XPGA(3)=AEM*XPQD
39374 IF(NF.GE.4) XPGA(4)=AEM*XPQU
39375 IF(NF.GE.5) XPGA(5)=AEM*XPQD
39376 DO 110 KFL=1,6
39377 XPGA(-KFL)=XPGA(KFL)
39378 110 CONTINUE
39379
39380 RETURN
39381 END
39382
39383C*********************************************************************
39384
39385C...PYGGAM
39386C...Constructs the F2 and parton distributions of the photon
39387C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
39388C...For F2, c and b are included by the Bethe-Heitler formula;
39389C...in the 'MSbar' scheme additionally a Cgamma term is added.
39390C...Contains the SaS sets 1D, 1M, 2D and 2M.
39391C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39392
39393 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
39394
39395C...Double precision and integer declarations.
39396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39397 IMPLICIT INTEGER(I-N)
39398 INTEGER PYK,PYCHGE,PYCOMP
39399C...Commonblocks.
39400 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
39401 &XPDIR(-6:6)
39402 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
39403 SAVE /PYINT8/,/PYINT9/
39404C...Local arrays.
39405 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
39406C...Charm and bottom masses (low to compensate for J/psi etc.).
39407 DATA PMC/1.3D0/, PMB/4.6D0/
39408C...alpha_em and alpha_em/(2*pi).
39409 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
39410C...Lambda value for 4 flavours.
39411 DATA ALAM/0.20D0/
39412C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
39413 DATA FRACU/0.8D0/
39414C...VMD couplings f_V**2/(4*pi).
39415 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
39416C...Masses for rho (=omega) and phi.
39417 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
39418C...Number of points in integration for IP2=1.
39419 DATA NSTEP/100/
39420
39421C...Reset output.
39422 F2GM=0D0
39423 DO 100 KFL=-6,6
39424 XPDFGM(KFL)=0D0
39425 XPVMD(KFL)=0D0
39426 XPANL(KFL)=0D0
39427 XPANH(KFL)=0D0
39428 XPBEH(KFL)=0D0
39429 XPDIR(KFL)=0D0
39430 VXPVMD(KFL)=0D0
39431 VXPANL(KFL)=0D0
39432 VXPANH(KFL)=0D0
39433 VXPDGM(KFL)=0D0
39434 100 CONTINUE
39435
39436C...Set Q0 cut-off parameter as function of set used.
39437 IF(ISET.LE.2) THEN
39438 Q0=0.6D0
39439 ELSE
39440 Q0=2D0
39441 ENDIF
39442 Q02=Q0**2
39443
39444C...Scale choice for off-shell photon; common factors.
39445 Q2A=Q2
39446 FACNOR=1D0
39447 IF(IP2.EQ.1) THEN
39448 P2MX=P2+Q02
39449 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39450 FACNOR=LOG(Q2/Q02)/NSTEP
39451 ELSEIF(IP2.EQ.2) THEN
39452 P2MX=MAX(P2,Q02)
39453 ELSEIF(IP2.EQ.3) THEN
39454 P2MX=P2+Q02
39455 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
39456 ELSEIF(IP2.EQ.4) THEN
39457 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39458 & ((Q2+P2)*(Q02+P2)))
39459 ELSEIF(IP2.EQ.5) THEN
39460 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39461 & ((Q2+P2)*(Q02+P2)))
39462 P2MX=Q0*SQRT(P2MXA)
39463 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
39464 ELSEIF(IP2.EQ.6) THEN
39465 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39466 & ((Q2+P2)*(Q02+P2)))
39467 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39468 ELSE
39469 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
39470 & ((Q2+P2)*(Q02+P2)))
39471 P2MX=Q0*SQRT(P2MXA)
39472 P2MXB=P2MX
39473 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
39474 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
39475 IF(ABS(Q2-Q02).GT.1D-6) THEN
39476 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
39477 ELSEIF(P2.LT.Q02) THEN
39478 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
39479 ELSE
39480 FACNOR=1D0
39481 ENDIF
39482 ENDIF
39483
39484C...Call VMD parametrization for d quark and use to give rho, omega,
39485C...phi. Note dipole dampening for off-shell photon.
39486 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39487 XFVAL=VXPGA(1)
39488 XPGA(1)=XPGA(2)
39489 XPGA(-1)=XPGA(-2)
39490 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
39491 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
39492 DO 110 KFL=-5,5
39493 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
39494 110 CONTINUE
39495 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
39496 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
39497 XPVMD(3)=XPVMD(3)+FACS*XFVAL
39498 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
39499 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
39500 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
39501 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
39502 VXPVMD(2)=FRACU*FACUD*XFVAL
39503 VXPVMD(3)=FACS*XFVAL
39504 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
39505 VXPVMD(-2)=FRACU*FACUD*XFVAL
39506 VXPVMD(-3)=FACS*XFVAL
39507
39508 IF(IP2.NE.1) THEN
39509C...Anomalous parametrizations for different strategies
39510C...for off-shell photons; except full integration.
39511
39512C...Call anomalous parametrization for d + u + s.
39513 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39514 DO 120 KFL=-5,5
39515 XPANL(KFL)=FACNOR*XPGA(KFL)
39516 VXPANL(KFL)=FACNOR*VXPGA(KFL)
39517 120 CONTINUE
39518
39519C...Call anomalous parametrization for c and b.
39520 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39521 DO 130 KFL=-5,5
39522 XPANH(KFL)=FACNOR*XPGA(KFL)
39523 VXPANH(KFL)=FACNOR*VXPGA(KFL)
39524 130 CONTINUE
39525 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
39526 DO 140 KFL=-5,5
39527 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
39528 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
39529 140 CONTINUE
39530
39531 ELSE
39532C...Special option: loop over flavours and integrate over k2.
39533 DO 170 KF=1,5
39534 DO 160 ISTEP=1,NSTEP
39535 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
39536 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
39537 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
39538 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
39539 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
39540 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
39541 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
39542 DO 150 KFL=-5,5
39543 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
39544 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
39545 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
39546 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
39547 150 CONTINUE
39548 160 CONTINUE
39549 170 CONTINUE
39550 ENDIF
39551
39552C...Call Bethe-Heitler term expression for charm and bottom.
39553 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
39554 XPBEH(4)=XPBH
39555 XPBEH(-4)=XPBH
39556 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
39557 XPBEH(5)=XPBH
39558 XPBEH(-5)=XPBH
39559
39560C...For MSbar subtraction call C^gamma term expression for d, u, s.
39561 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
39562 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
39563 DO 180 KFL=-5,5
39564 XPDIR(KFL)=XPGA(KFL)
39565 180 CONTINUE
39566 ENDIF
39567
39568C...Store result in output array.
39569 DO 190 KFL=-5,5
39570 CHSQ=1D0/9D0
39571 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
39572 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39573 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
39574 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
39575 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
39576 190 CONTINUE
39577
39578 RETURN
39579 END
39580
39581C*********************************************************************
39582
39583C...PYGVMD
39584C...Evaluates the VMD parton distributions of a photon,
39585C...evolved homogeneously from an initial scale P2 to Q2.
39586C...Does not include dipole suppression factor.
39587C...ISET is parton distribution set, see above;
39588C...additionally ISET=0 is used for the evolution of an anomalous photon
39589C...which branched at a scale P2 and then evolved homogeneously to Q2.
39590C...ALAM is the 4-flavour Lambda, which is automatically converted
39591C...to 3- and 5-flavour equivalents as needed.
39592C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39593
39594 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39595
39596C...Double precision and integer declarations.
39597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39598 IMPLICIT INTEGER(I-N)
39599 INTEGER PYK,PYCHGE,PYCOMP
39600C...Local arrays and data.
39601 DIMENSION XPGA(-6:6), VXPGA(-6:6)
39602 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39603
39604C...Reset output.
39605 DO 100 KFL=-6,6
39606 XPGA(KFL)=0D0
39607 VXPGA(KFL)=0D0
39608 100 CONTINUE
39609 KFA=IABS(KF)
39610
39611C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39612 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
39613 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
39614 P2EFF=MAX(P2,1.2D0*ALAM3**2)
39615 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39616 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39617 Q2EFF=MAX(Q2,P2EFF)
39618
39619C...Find number of flavours at lower and upper scale.
39620 NFP=4
39621 IF(P2EFF.LT.PMC**2) NFP=3
39622 IF(P2EFF.GT.PMB**2) NFP=5
39623 NFQ=4
39624 IF(Q2EFF.LT.PMC**2) NFQ=3
39625 IF(Q2EFF.GT.PMB**2) NFQ=5
39626
39627C...Find s as sum of 3-, 4- and 5-flavour parts.
39628 S=0D0
39629 IF(NFP.EQ.3) THEN
39630 Q2DIV=PMC**2
39631 IF(NFQ.EQ.3) Q2DIV=Q2EFF
39632 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
39633 ENDIF
39634 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
39635 P2DIV=P2EFF
39636 IF(NFP.EQ.3) P2DIV=PMC**2
39637 Q2DIV=Q2EFF
39638 IF(NFQ.EQ.5) Q2DIV=PMB**2
39639 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
39640 ENDIF
39641 IF(NFQ.EQ.5) THEN
39642 P2DIV=PMB**2
39643 IF(NFP.EQ.5) P2DIV=P2EFF
39644 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
39645 ENDIF
39646
39647C...Calculate frequent combinations of x and s.
39648 X1=1D0-X
39649 XL=-LOG(X)
39650 S2=S**2
39651 S3=S**3
39652 S4=S**4
39653
39654C...Evaluate homogeneous anomalous parton distributions below or
39655C...above threshold.
39656 IF(ISET.EQ.0) THEN
39657 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39658 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39659 XVAL = X * 1.5D0 * (X**2+X1**2)
39660 XGLU = 0D0
39661 XSEA = 0D0
39662 ELSE
39663 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
39664 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
39665 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
39666 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
39667 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
39668 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
39669 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
39670 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
39671 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
39672 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
39673 & (2D0*X-1D0)*X*XL**2)
39674 ENDIF
39675
39676C...Evaluate set 1D parton distributions below or above threshold.
39677 ELSEIF(ISET.EQ.1) THEN
39678 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39679 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39680 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
39681 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
39682 XSEA = 0.100D0 * X1**3.76D0
39683 ELSE
39684 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
39685 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
39686 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
39687 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
39688 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
39689 & X**0.40D0 * X1**(1.76D0+3D0*S)
39690 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
39691 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
39692 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
39693 XSEA0 = 0.100D0 * X1**3.76D0
39694 ENDIF
39695
39696C...Evaluate set 1M parton distributions below or above threshold.
39697 ELSEIF(ISET.EQ.2) THEN
39698 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39699 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39700 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
39701 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
39702 XSEA = 0D0
39703 ELSE
39704 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
39705 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
39706 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
39707 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
39708 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
39709 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
39710 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
39711 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
39712 & XL**(2.8D0*S)
39713 XSEA0 = 0D0
39714 ENDIF
39715
39716C...Evaluate set 2D parton distributions below or above threshold.
39717 ELSEIF(ISET.EQ.3) THEN
39718 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39719 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39720 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
39721 XGLU = 1.925D0 * X1**2
39722 XSEA = 0.242D0 * X1**4
39723 ELSE
39724 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
39725 & X**(0.46D0+0.25D0*S) *
39726 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
39727 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
39728 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
39729 & EXP(-18.67D0*S) *
39730 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
39731 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
39732 & XL**(9.3D0*S/(1D0+1.7D0*S))
39733 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
39734 & (1D0-0.607D0*S+21.95D0*S2) *
39735 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
39736 XSEA0 = 0.242D0 * X1**4
39737 ENDIF
39738
39739C...Evaluate set 2M parton distributions below or above threshold.
39740 ELSEIF(ISET.EQ.4) THEN
39741 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
39742 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
39743 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
39744 XGLU = 1.808D0 * X1**2
39745 XSEA = 0.209D0 * X1**4
39746 ELSE
39747 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
39748 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
39749 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
39750 & XL**(5.15D0*S/(1D0+2D0*S)) +
39751 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
39752 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
39753 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
39754 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
39755 & XL**(10.9D0*S/(1D0+2.5D0*S))
39756 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
39757 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
39758 & X1**(4D0+S) * XL**(0.45D0*S)
39759 XSEA0 = 0.209D0 * X1**4
39760 ENDIF
39761 ENDIF
39762
39763C...Threshold factors for c and b sea.
39764 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39765 XCHM=0D0
39766 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39767 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39768 IF(ISET.EQ.0) THEN
39769 XCHM=XSEA*(1D0-(SCH/SLL)**2)
39770 ELSE
39771 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
39772 ENDIF
39773 ENDIF
39774 XBOT=0D0
39775 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39776 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39777 IF(ISET.EQ.0) THEN
39778 XBOT=XSEA*(1D0-(SBT/SLL)**2)
39779 ELSE
39780 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
39781 ENDIF
39782 ENDIF
39783
39784C...Fill parton distributions.
39785 XPGA(0)=XGLU
39786 XPGA(1)=XSEA
39787 XPGA(2)=XSEA
39788 XPGA(3)=XSEA
39789 XPGA(4)=XCHM
39790 XPGA(5)=XBOT
39791 XPGA(KFA)=XPGA(KFA)+XVAL
39792 DO 110 KFL=1,5
39793 XPGA(-KFL)=XPGA(KFL)
39794 110 CONTINUE
39795 VXPGA(KFA)=XVAL
39796 VXPGA(-KFA)=XVAL
39797
39798 RETURN
39799 END
39800
39801C*********************************************************************
39802
39803C...PYGANO
39804C...Evaluates the parton distributions of the anomalous photon,
39805C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
39806C...KF=0 gives the sum over (up to) 5 flavours,
39807C...KF<0 limits to flavours up to abs(KF),
39808C...KF>0 is for flavour KF only.
39809C...ALAM is the 4-flavour Lambda, which is automatically converted
39810C...to 3- and 5-flavour equivalents as needed.
39811C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39812
39813 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
39814
39815C...Double precision and integer declarations.
39816 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39817 IMPLICIT INTEGER(I-N)
39818 INTEGER PYK,PYCHGE,PYCOMP
39819C...Local arrays and data.
39820 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
39821 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
39822
39823C...Reset output.
39824 DO 100 KFL=-6,6
39825 XPGA(KFL)=0D0
39826 VXPGA(KFL)=0D0
39827 100 CONTINUE
39828 IF(Q2.LE.P2) RETURN
39829 KFA=IABS(KF)
39830
39831C...Calculate Lambda; protect against unphysical Q2 and P2 input.
39832 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
39833 ALAMSQ(4)=ALAM**2
39834 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
39835 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
39836 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
39837 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
39838 Q2EFF=MAX(Q2,P2EFF)
39839 XL=-LOG(X)
39840
39841C...Find number of flavours at lower and upper scale.
39842 NFP=4
39843 IF(P2EFF.LT.PMC**2) NFP=3
39844 IF(P2EFF.GT.PMB**2) NFP=5
39845 NFQ=4
39846 IF(Q2EFF.LT.PMC**2) NFQ=3
39847 IF(Q2EFF.GT.PMB**2) NFQ=5
39848
39849C...Define range of flavour loop.
39850 IF(KF.EQ.0) THEN
39851 KFLMN=1
39852 KFLMX=5
39853 ELSEIF(KF.LT.0) THEN
39854 KFLMN=1
39855 KFLMX=KFA
39856 ELSE
39857 KFLMN=KFA
39858 KFLMX=KFA
39859 ENDIF
39860
39861C...Loop over flavours the photon can branch into.
39862 DO 110 KFL=KFLMN,KFLMX
39863
39864C...Light flavours: calculate t range and (approximate) s range.
39865 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
39866 TDIFF=LOG(Q2EFF/P2EFF)
39867 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39868 & LOG(P2EFF/ALAMSQ(NFQ)))
39869 IF(NFQ.GT.NFP) THEN
39870 Q2DIV=PMB**2
39871 IF(NFQ.EQ.4) Q2DIV=PMC**2
39872 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39873 & LOG(P2EFF/ALAMSQ(NFQ)))
39874 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39875 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39876 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39877 ENDIF
39878 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
39879 Q2DIV=PMC**2
39880 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
39881 & LOG(P2EFF/ALAMSQ(4)))
39882 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
39883 & LOG(P2EFF/ALAMSQ(3)))
39884 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
39885 ENDIF
39886
39887C...u and s quark do not need a separate treatment when d has been done.
39888 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
39889
39890C...Charm: as above, but only include range above c threshold.
39891 ELSEIF(KFL.EQ.4) THEN
39892 IF(Q2.LE.PMC**2) GOTO 110
39893 P2EFF=MAX(P2EFF,PMC**2)
39894 Q2EFF=MAX(Q2EFF,P2EFF)
39895 TDIFF=LOG(Q2EFF/P2EFF)
39896 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39897 & LOG(P2EFF/ALAMSQ(NFQ)))
39898 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
39899 Q2DIV=PMB**2
39900 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
39901 & LOG(P2EFF/ALAMSQ(NFQ)))
39902 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
39903 & LOG(P2EFF/ALAMSQ(NFQ-1)))
39904 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
39905 ENDIF
39906
39907C...Bottom: as above, but only include range above b threshold.
39908 ELSEIF(KFL.EQ.5) THEN
39909 IF(Q2.LE.PMB**2) GOTO 110
39910 P2EFF=MAX(P2EFF,PMB**2)
39911 Q2EFF=MAX(Q2,P2EFF)
39912 TDIFF=LOG(Q2EFF/P2EFF)
39913 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
39914 & LOG(P2EFF/ALAMSQ(NFQ)))
39915 ENDIF
39916
39917C...Evaluate flavour-dependent prefactor (charge^2 etc.).
39918 CHSQ=1D0/9D0
39919 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
39920 FAC=AEM2PI*2D0*CHSQ*TDIFF
39921
39922C...Evaluate parton distributions (normalized to unit momentum sum).
39923 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
39924 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
39925 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
39926 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
39927 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
39928 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
39929 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
39930 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
39931 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
39932 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
39933 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
39934 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
39935
39936C...Threshold factors for c and b sea.
39937 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
39938 XCHM=0D0
39939 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39940 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39941 XCHM=XSEA*(1D0-(SCH/SLL)**3)
39942 ENDIF
39943 XBOT=0D0
39944 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
39945 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
39946 XBOT=XSEA*(1D0-(SBT/SLL)**3)
39947 ENDIF
39948 ENDIF
39949
39950C...Add contribution of each valence flavour.
39951 XPGA(0)=XPGA(0)+FAC*XGLU
39952 XPGA(1)=XPGA(1)+FAC*XSEA
39953 XPGA(2)=XPGA(2)+FAC*XSEA
39954 XPGA(3)=XPGA(3)+FAC*XSEA
39955 XPGA(4)=XPGA(4)+FAC*XCHM
39956 XPGA(5)=XPGA(5)+FAC*XBOT
39957 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
39958 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
39959 110 CONTINUE
39960 DO 120 KFL=1,5
39961 XPGA(-KFL)=XPGA(KFL)
39962 VXPGA(-KFL)=VXPGA(KFL)
39963 120 CONTINUE
39964
39965 RETURN
39966 END
39967
39968
39969C*********************************************************************
39970
39971C...PYGBEH
39972C...Evaluates the Bethe-Heitler cross section for heavy flavour
39973C...production.
39974C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
39975
39976 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
39977
39978C...Double precision and integer declarations.
39979 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39980 IMPLICIT INTEGER(I-N)
39981 INTEGER PYK,PYCHGE,PYCOMP
39982
39983C...Local data.
39984 DATA AEM2PI/0.0011614D0/
39985
39986C...Reset output.
39987 XPBH=0D0
39988 SIGBH=0D0
39989
39990C...Check kinematics limits.
39991 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
39992 W2=Q2*(1D0-X)/X-P2
39993 BETA2=1D0-4D0*PM2/W2
39994 IF(BETA2.LT.1D-10) RETURN
39995 BETA=SQRT(BETA2)
39996 RMQ=4D0*PM2/Q2
39997
39998C...Simple case: P2 = 0.
39999 IF(P2.LT.1D-4) THEN
40000 IF(BETA.LT.0.99D0) THEN
40001 XBL=LOG((1D0+BETA)/(1D0-BETA))
40002 ELSE
40003 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40004 ENDIF
40005 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40006 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40007
40008C...Complicated case: P2 > 0, based on approximation of
40009C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40010 ELSE
40011 RPQ=1D0-4D0*X**2*P2/Q2
40012 IF(RPQ.GT.1D-10) THEN
40013 RPBE=SQRT(RPQ*BETA2)
40014 IF(RPBE.LT.0.99D0) THEN
40015 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40016 XBI=2D0*RPBE/(1D0-RPBE**2)
40017 ELSE
40018 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40019 XBL=LOG((1D0+RPBE)**2/RPBESN)
40020 XBI=2D0*RPBE/RPBESN
40021 ENDIF
40022 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40023 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40024 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40025 ENDIF
40026 ENDIF
40027
40028C...Multiply by charge-squared etc. to get parton distribution.
40029 CHSQ=1D0/9D0
40030 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40031 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40032
40033 RETURN
40034 END
40035
40036C*********************************************************************
40037
40038C...PYGDIR
40039C...Evaluates the direct contribution, i.e. the C^gamma term,
40040C...as needed in MSbar parametrizations.
40041C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40042
40043 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40044
40045C...Double precision and integer declarations.
40046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40047 IMPLICIT INTEGER(I-N)
40048 INTEGER PYK,PYCHGE,PYCOMP
40049C...Local array and data.
40050 DIMENSION XPGA(-6:6)
40051 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40052
40053C...Reset output.
40054 DO 100 KFL=-6,6
40055 XPGA(KFL)=0D0
40056 100 CONTINUE
40057
40058C...Evaluate common x-dependent expression.
40059 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40060 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40061
40062C...d, u, s part by simple charge factor.
40063 XPGA(1)=(1D0/9D0)*CGAM
40064 XPGA(2)=(4D0/9D0)*CGAM
40065 XPGA(3)=(1D0/9D0)*CGAM
40066
40067C...Also fill for antiquarks.
40068 DO 110 KF=1,5
40069 XPGA(-KF)=XPGA(KF)
40070 110 CONTINUE
40071
40072 RETURN
40073 END
40074
40075C*********************************************************************
40076
40077C...PYPDPI
40078C...Gives pi+ parton distribution according to two different
40079C...parametrizations.
40080
40081 SUBROUTINE PYPDPI(X,Q2,XPPI)
40082
40083C...Double precision and integer declarations.
40084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40085 IMPLICIT INTEGER(I-N)
40086 INTEGER PYK,PYCHGE,PYCOMP
40087C...Commonblocks.
40088 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40090 COMMON/PYINT1/MINT(400),VINT(400)
40091 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40092C...Local arrays.
40093 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40094
40095C...The following data lines are coefficients needed in the
40096C...Owens pion parton distribution parametrizations, see below.
40097C...Expansion coefficients for up and down valence quark distributions.
40098 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40099 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40100 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40101 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40102 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40103 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40104 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40105 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40106C...Expansion coefficients for gluon distribution.
40107 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40108 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40109 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40110 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40111 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40112 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40113 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40114 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40115C...Expansion coefficients for (up+down+strange) quark sea distribution.
40116 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40117 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40118 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40119 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40120 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40121 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40122 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40123 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40124C...Expansion coefficients for charm quark sea distribution.
40125 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40126 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40127 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40128 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40129 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40130 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40131 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40132 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40133
40134C...Euler's beta function, requires ordinary Gamma function
40135 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40136
40137C...Reset output array.
40138 DO 100 KFL=-6,6
40139 XPPI(KFL)=0D0
40140 100 CONTINUE
40141
40142 IF(MSTP(53).LE.2) THEN
40143C...Pion parton distributions from Owens.
40144C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40145
40146C...Determine set, Lambda and s expansion variable.
40147 NSET=MSTP(53)
40148 IF(NSET.EQ.1) ALAM=0.2D0
40149 IF(NSET.EQ.2) ALAM=0.4D0
40150 VINT(231)=4D0
40151 IF(MSTP(57).LE.0) THEN
40152 SD=0D0
40153 ELSE
40154 Q2IN=MIN(2D3,MAX(4D0,Q2))
40155 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40156 ENDIF
40157
40158C...Calculate parton distributions.
40159 DO 120 KFL=1,4
40160 DO 110 IS=1,5
40161 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40162 & COW(3,IS,KFL,NSET)*SD**2
40163 110 CONTINUE
40164 IF(KFL.EQ.1) THEN
40165 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40166 ELSE
40167 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40168 & TS(5)*X**2)
40169 ENDIF
40170 120 CONTINUE
40171
40172C...Put into output array.
40173 XPPI(0)=XQ(2)
40174 XPPI(1)=XQ(3)/6D0
40175 XPPI(2)=XQ(1)+XQ(3)/6D0
40176 XPPI(3)=XQ(3)/6D0
40177 XPPI(4)=XQ(4)
40178 XPPI(-1)=XQ(1)+XQ(3)/6D0
40179 XPPI(-2)=XQ(3)/6D0
40180 XPPI(-3)=XQ(3)/6D0
40181 XPPI(-4)=XQ(4)
40182
40183C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40184C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40185C...10^-5 < x < 1.
40186 ELSE
40187
40188C...Determine s expansion variable and some x expressions.
40189 VINT(231)=0.25D0
40190 IF(MSTP(57).LE.0) THEN
40191 SD=0D0
40192 ELSE
40193 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40194 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40195 ENDIF
40196 SD2=SD**2
40197 XL=-LOG(X)
40198 XS=SQRT(X)
40199
40200C...Evaluate valence, gluon and sea distributions.
40201 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40202 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40203 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40204 & SD-0.175D0*SD2)+
40205 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40206 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40207 & XL)))*
40208 & (1D0-X)**(0.390D0+1.053D0*SD)
40209 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40210 & X)**3.359D0*
40211 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40212 & XL))/
40213 & XL**(2.538D0-0.763D0*SD)
40214 IF(SD.LE.0.888D0) THEN
40215 XFCHM=0D0
40216 ELSE
40217 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40218 & 0.771D0*SD)*
40219 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40220 & XL))
40221 ENDIF
40222 IF(SD.LE.1.351D0) THEN
40223 XFBOT=0D0
40224 ELSE
40225 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40226 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40227 & XL))
40228 ENDIF
40229
40230C...Put into output array.
40231 XPPI(0)=XFGLU
40232 XPPI(1)=XFSEA
40233 XPPI(2)=XFSEA
40234 XPPI(3)=XFSEA
40235 XPPI(4)=XFCHM
40236 XPPI(5)=XFBOT
40237 DO 130 KFL=1,5
40238 XPPI(-KFL)=XPPI(KFL)
40239 130 CONTINUE
40240 XPPI(2)=XPPI(2)+XFVAL
40241 XPPI(-1)=XPPI(-1)+XFVAL
40242 ENDIF
40243
40244 RETURN
40245 END
40246
40247C*********************************************************************
40248
40249C...PYPDPR
40250C...Gives proton parton distributions according to a few different
40251C...parametrizations.
40252
40253 SUBROUTINE PYPDPR(X,Q2,XPPR)
40254
40255C...Double precision and integer declarations.
40256 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40257 IMPLICIT INTEGER(I-N)
40258 INTEGER PYK,PYCHGE,PYCOMP
40259C...Commonblocks.
40260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40261 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
40262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40263 COMMON/PYINT1/MINT(400),VINT(400)
40264 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
40265C...Arrays and data.
40266 DIMENSION XPPR(-6:6),Q2MIN(16)
40267 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
40268 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
40269
40270C...Reset output array.
40271 DO 100 KFL=-6,6
40272 XPPR(KFL)=0D0
40273 100 CONTINUE
40274
40275C...Common preliminaries.
40276 NSET=MAX(1,MIN(16,MSTP(51)))
40277 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
40278 VINT(231)=Q2MIN(NSET)
40279 IF(MSTP(57).EQ.0) THEN
40280 Q2L=Q2MIN(NSET)
40281 ELSE
40282 Q2L=MAX(Q2MIN(NSET),Q2)
40283 ENDIF
40284
40285 IF(NSET.GE.1.AND.NSET.LE.3) THEN
40286C...Interface to the CTEQ 3 parton distributions.
40287 QRT=SQRT(MAX(1D0,Q2L))
40288
40289C...Loop over flavours.
40290 DO 110 I=-6,6
40291 IF(I.LE.0) THEN
40292 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
40293 ELSEIF(I.LE.2) THEN
40294 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
40295 ELSE
40296 XPPR(I)=XPPR(-I)
40297 ENDIF
40298 110 CONTINUE
40299
40300 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
40301C...Interface to the GRV 94 distributions.
40302 IF(NSET.EQ.4) THEN
40303 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40304 ELSEIF(NSET.EQ.5) THEN
40305 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40306 ELSE
40307 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40308 ENDIF
40309
40310C...Put into output array.
40311 XPPR(0)=GL
40312 XPPR(-1)=0.5D0*(UDB+DEL)
40313 XPPR(-2)=0.5D0*(UDB-DEL)
40314 XPPR(-3)=SB
40315 XPPR(-4)=CHM
40316 XPPR(-5)=BOT
40317 XPPR(1)=DV+XPPR(-1)
40318 XPPR(2)=UV+XPPR(-2)
40319 XPPR(3)=SB
40320 XPPR(4)=CHM
40321 XPPR(5)=BOT
40322
40323 ELSEIF(NSET.EQ.7) THEN
40324C...Interface to the CTEQ 5L parton distributions.
40325C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
40326C...freezing x*f(x,Q2) at borders.
40327 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40328 XIN=MAX(1D-6,MIN(1D0,X))
40329
40330C...Loop over flavours (with u <-> d notation mismatch).
40331 SUMUDB=PYCT5L(-1,XIN,QRT)
40332 RATUDB=PYCT5L(-2,XIN,QRT)
40333 DO 120 I=-5,2
40334 IF(I.EQ.1) THEN
40335 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
40336 ELSEIF(I.EQ.2) THEN
40337 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
40338 ELSEIF(I.EQ.-1) THEN
40339 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40340 ELSEIF(I.EQ.-2) THEN
40341 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40342 ELSE
40343 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
40344 IF(I.LT.0) XPPR(-I)=XPPR(I)
40345 ENDIF
40346 120 CONTINUE
40347
40348 ELSEIF(NSET.EQ.8) THEN
40349C...Interface to the CTEQ 5M1 parton distributions.
40350 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
40351 XIN=MAX(1D-6,MIN(1D0,X))
40352
40353C...Loop over flavours (with u <-> d notation mismatch).
40354 SUMUDB=PYCT5M(-1,XIN,QRT)
40355 RATUDB=PYCT5M(-2,XIN,QRT)
40356 DO 130 I=-5,2
40357 IF(I.EQ.1) THEN
40358 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
40359 ELSEIF(I.EQ.2) THEN
40360 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
40361 ELSEIF(I.EQ.-1) THEN
40362 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
40363 ELSEIF(I.EQ.-2) THEN
40364 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
40365 ELSE
40366 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
40367 IF(I.LT.0) XPPR(-I)=XPPR(I)
40368 ENDIF
40369 130 CONTINUE
40370
40371 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
40372C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
40373C...obsolete but offers backwards compatibility.
40374 CALL PYPDPO(X,Q2L,XPPR)
40375
40376C...Symmetric choice for debugging only
40377 ELSEIF(NSET.EQ.16) THEN
40378 XPPR(0)=.5D0/X
40379 XPPR(1)=.05D0/X
40380 XPPR(2)=.05D0/X
40381 XPPR(3)=.05D0/X
40382 XPPR(4)=.05D0/X
40383 XPPR(5)=.05D0/X
40384 XPPR(-1)=.05D0/X
40385 XPPR(-2)=.05D0/X
40386 XPPR(-3)=.05D0/X
40387 XPPR(-4)=.05D0/X
40388 XPPR(-5)=.05D0/X
40389
40390 ENDIF
40391
40392 RETURN
40393 END
40394
40395C*********************************************************************
40396
40397C...PYCTEQ
40398C...Gives the CTEQ 3 parton distribution function sets in
40399C...parametrized form, of October 24, 1994.
40400C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
40401C...J. Qiu, W.K. Tung and H. Weerts.
40402
40403 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
40404
40405C...Double precision declaration.
40406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40407 IMPLICIT INTEGER(I-N)
40408
40409C...Data on Lambda values of fits, minimum Q and quark masses.
40410 DIMENSION ALM(3), QMS(4:6)
40411 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
40412 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
40413
40414C....Check flavour thresholds. Set up QI for SB.
40415 IP = IABS(IPRT)
40416 IF(IP .GE. 4) THEN
40417 IF(Q .LE. QMS(IP)) THEN
40418 PYCTEQ = 0D0
40419 RETURN
40420 ENDIF
40421 QI = QMS(IP)
40422 ELSE
40423 QI = QMN
40424 ENDIF
40425
40426C...Use "standard lambda" of parametrization program for expansion.
40427 ALAM = ALM (ISET)
40428 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
40429 SB = LOG (SBL)
40430 SB2 = SB*SB
40431 SB3 = SB2*SB
40432
40433C...Expansion for CTEQ3L.
40434 IF(ISET .EQ. 1) THEN
40435 IF(IPRT .EQ. 2) THEN
40436 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
40437 & 0.3171D+00*SB3)
40438 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
40439 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
40440 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
40441 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
40442 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
40443 ELSEIF(IPRT .EQ. 1) THEN
40444 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
40445 & 0.7728D+00*SB3)
40446 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
40447 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
40448 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
40449 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
40450 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
40451 ELSEIF(IPRT .EQ. 0) THEN
40452 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
40453 & 0.5343D+00*SB3)
40454 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
40455 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
40456 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
40457 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
40458 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
40459 ELSEIF(IPRT .EQ. -1) THEN
40460 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
40461 & 0.2031D+01*SB3)
40462 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
40463 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
40464 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
40465 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
40466 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
40467 ELSEIF(IPRT .EQ. -2) THEN
40468 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
40469 & 0.9872D-01*SB3)
40470 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
40471 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
40472 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
40473 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
40474 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
40475 ELSEIF(IPRT .EQ. -3) THEN
40476 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
40477 & 0.8390D+00*SB3)
40478 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
40479 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
40480 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
40481 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
40482 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
40483 ELSEIF(IPRT .EQ. -4) THEN
40484 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
40485 & 0.1651D-01*SB2)
40486 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
40487 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
40488 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
40489 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
40490 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
40491 ELSEIF(IPRT .EQ. -5) THEN
40492 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
40493 & 0.3702D+01*SB2)
40494 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
40495 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
40496 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
40497 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
40498 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
40499 ELSEIF(IPRT .EQ. -6) THEN
40500 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
40501 & 0.6943D+00*SB2)
40502 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
40503 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
40504 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
40505 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
40506 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
40507 ENDIF
40508
40509C...Expansion for CTEQ3M.
40510 ELSEIF(ISET .EQ. 2) THEN
40511 IF(IPRT .EQ. 2) THEN
40512 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
40513 & 0.2935D+00*SB3)
40514 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
40515 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
40516 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
40517 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
40518 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
40519 ELSEIF(IPRT .EQ. 1) THEN
40520 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
40521 & 0.4305D-01*SB3)
40522 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
40523 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
40524 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
40525 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
40526 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
40527 ELSEIF(IPRT .EQ. 0) THEN
40528 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
40529 & 0.1037D-01*SB3)
40530 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
40531 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
40532 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
40533 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
40534 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
40535 ELSEIF(IPRT .EQ. -1) THEN
40536 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
40537 & 0.1602D+01*SB3)
40538 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
40539 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
40540 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
40541 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
40542 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
40543 ELSEIF(IPRT .EQ. -2) THEN
40544 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
40545 & 0.2496D+00*SB3)
40546 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
40547 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
40548 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
40549 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
40550 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
40551 ELSEIF(IPRT .EQ. -3) THEN
40552 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
40553 & 0.1936D+01*SB3)
40554 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
40555 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
40556 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
40557 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
40558 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
40559 ELSEIF(IPRT .EQ. -4) THEN
40560 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
40561 & 0.5348D+00*SB2)
40562 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
40563 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
40564 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
40565 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
40566 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
40567 ELSEIF(IPRT .EQ. -5) THEN
40568 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
40569 & 0.1569D+01*SB2)
40570 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
40571 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
40572 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
40573 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
40574 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
40575 ELSEIF(IPRT .EQ. -6) THEN
40576 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
40577 & 0.8838D+01*SB2)
40578 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
40579 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
40580 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
40581 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
40582 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
40583 ENDIF
40584
40585C...Expansion for CTEQ3D.
40586 ELSEIF(ISET .EQ. 3) THEN
40587 IF(IPRT .EQ. 2) THEN
40588 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
40589 & 0.2902D+00*SB3)
40590 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
40591 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
40592 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
40593 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
40594 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
40595 ELSEIF(IPRT .EQ. 1) THEN
40596 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
40597 & 0.7257D+00*SB3)
40598 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
40599 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
40600 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
40601 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
40602 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
40603 ELSEIF(IPRT .EQ. 0) THEN
40604 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
40605 & 0.2734D-04*SB3)
40606 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
40607 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
40608 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
40609 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
40610 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
40611 ELSEIF(IPRT .EQ. -1) THEN
40612 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
40613 & 0.1671D+01*SB3)
40614 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
40615 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
40616 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
40617 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
40618 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
40619 ELSEIF(IPRT .EQ. -2) THEN
40620 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
40621 & 0.2223D+00*SB3)
40622 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
40623 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
40624 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
40625 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
40626 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
40627 ELSEIF(IPRT .EQ. -3) THEN
40628 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
40629 & 0.1937D+01*SB3)
40630 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
40631 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
40632 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
40633 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
40634 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
40635 ELSEIF(IPRT .EQ. -4) THEN
40636 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
40637 & 0.5137D+00*SB2)
40638 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
40639 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
40640 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
40641 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
40642 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
40643 ELSEIF(IPRT .EQ. -5) THEN
40644 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
40645 & 0.2143D+01*SB2)
40646 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
40647 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
40648 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
40649 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
40650 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
40651 ELSEIF(IPRT .EQ. -6) THEN
40652 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
40653 & 0.9998D+01*SB2)
40654 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
40655 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
40656 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
40657 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
40658 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
40659 ENDIF
40660 ENDIF
40661
40662C...Calculation of x * f(x, Q).
40663 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
40664 & *(LOG(1D0+1D0/X))**A5 )
40665
40666 RETURN
40667 END
40668
40669C*********************************************************************
40670
40671C...PYGRVL
40672C...Gives the GRV 94 L (leading order) parton distribution function set
40673C...in parametrized form.
40674C...Authors: M. Glueck, E. Reya and A. Vogt.
40675
40676 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40677
40678C...Double precision declaration.
40679 IMPLICIT DOUBLE PRECISION (A - Z)
40680
40681C...Common expressions.
40682 MU2 = 0.23D0
40683 LAM2 = 0.2322D0 * 0.2322D0
40684 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40685 DS = SQRT (S)
40686 S2 = S * S
40687 S3 = S2 * S
40688
40689C...uv :
40690 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
40691 AKU = 0.590D0 - 0.024D0 * S
40692 BKU = 0.131D0 + 0.063D0 * S
40693 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
40694 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
40695 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
40696 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
40697 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40698
40699C...dv :
40700 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
40701 AKD = 0.376D0
40702 BKD = 0.486D0 + 0.062D0 * S
40703 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
40704 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
40705 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
40706 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
40707 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40708
40709C...del :
40710 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
40711 AKE = 0.409D0 - 0.005D0 * S
40712 BKE = 0.799D0 + 0.071D0 * S
40713 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
40714 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
40715 CE = 0.0D0
40716 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
40717 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40718
40719C...udb :
40720 ALX = 1.451D0
40721 BEX = 0.271D0
40722 AKX = 0.410D0 - 0.232D0 * S
40723 BKX = 0.534D0 - 0.457D0 * S
40724 AGX = 0.890D0 - 0.140D0 * S
40725 BGX = -0.981D0
40726 CX = 0.320D0 + 0.683D0 * S
40727 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
40728 EX = 4.119D0 + 1.713D0 * S
40729 ESX = 0.682D0 + 2.978D0 * S
40730 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40731 & DX, EX, ESX)
40732
40733C...sb :
40734 STS = 0D0
40735 ALS = 0.914D0
40736 BES = 0.577D0
40737 AKS = 1.798D0 - 0.596D0 * S
40738 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
40739 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
40740 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
40741 EST = 3.981D0 + 1.638D0 * S
40742 ESS = 6.402D0
40743 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40744
40745C...cb :
40746 STC = 0.888D0
40747 ALC = 1.01D0
40748 BEC = 0.37D0
40749 AKC = 0D0
40750 AC = 0D0
40751 BC = 4.24D0 - 0.804D0 * S
40752 DCT = 3.46D0 - 1.076D0 * S
40753 ECT = 4.61D0 + 1.49D0 * S
40754 ESC = 2.555D0 + 1.961D0 * S
40755 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40756
40757C...bb :
40758 STB = 1.351D0
40759 ALB = 1.00D0
40760 BEB = 0.51D0
40761 AKB = 0D0
40762 AB = 0D0
40763 BB = 1.848D0
40764 DBT = 2.929D0 + 1.396D0 * S
40765 EBT = 4.71D0 + 1.514D0 * S
40766 ESB = 4.02D0 + 1.239D0 * S
40767 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40768
40769C...gl :
40770 ALG = 0.524D0
40771 BEG = 1.088D0
40772 AKG = 1.742D0 - 0.930D0 * S
40773 BKG = - 0.399D0 * S2
40774 AG = 7.486D0 - 2.185D0 * S
40775 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
40776 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
40777 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
40778 EG = 0.807D0 + 2.005D0 * S
40779 ESG = 3.841D0 + 0.316D0 * S
40780 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
40781 & DG, EG, ESG)
40782
40783 RETURN
40784 END
40785
40786C*********************************************************************
40787
40788C...PYGRVM
40789C...Gives the GRV 94 M (MSbar) parton distribution function set
40790C...in parametrized form.
40791C...Authors: M. Glueck, E. Reya and A. Vogt.
40792
40793 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40794
40795C...Double precision declaration.
40796 IMPLICIT DOUBLE PRECISION (A - Z)
40797
40798C...Common expressions.
40799 MU2 = 0.34D0
40800 LAM2 = 0.248D0 * 0.248D0
40801 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40802 DS = SQRT (S)
40803 S2 = S * S
40804 S3 = S2 * S
40805
40806C...uv :
40807 NU = 1.304D0 + 0.863D0 * S
40808 AKU = 0.558D0 - 0.020D0 * S
40809 BKU = 0.183D0 * S
40810 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
40811 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
40812 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
40813 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
40814 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40815
40816C...dv :
40817 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
40818 AKD = 0.270D0 - 0.019D0 * S
40819 BKD = 0.260D0
40820 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
40821 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
40822 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
40823 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
40824 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40825
40826C...del :
40827 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
40828 AKE = 0.409D0 - 0.007D0 * S
40829 BKE = 0.782D0 + 0.082D0 * S
40830 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
40831 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
40832 CE = 0.0D0
40833 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
40834 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40835
40836C...udb :
40837 ALX = 0.877D0
40838 BEX = 0.561D0
40839 AKX = 0.275D0
40840 BKX = 0.0D0
40841 AGX = 0.997D0
40842 BGX = 3.210D0 - 1.866D0 * S
40843 CX = 7.300D0
40844 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
40845 EX = 3.077D0 + 1.446D0 * S
40846 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
40847 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40848 & DX, EX, ESX)
40849
40850C...sb :
40851 STS = 0D0
40852 ALS = 0.756D0
40853 BES = 0.216D0
40854 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
40855 AS = -4.329D0 + 1.131D0 * S
40856 BS = 9.568D0 - 1.744D0 * S
40857 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
40858 EST = 3.031D0 + 1.639D0 * S
40859 ESS = 5.837D0 + 0.815D0 * S
40860 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40861
40862C...cb :
40863 STC = 0.820D0
40864 ALC = 0.98D0
40865 BEC = 0D0
40866 AKC = -0.625D0 - 0.523D0 * S
40867 AC = 0D0
40868 BC = 1.896D0 + 1.616D0 * S
40869 DCT = 4.12D0 + 0.683D0 * S
40870 ECT = 4.36D0 + 1.328D0 * S
40871 ESC = 0.677D0 + 0.679D0 * S
40872 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40873
40874C...bb :
40875 STB = 1.297D0
40876 ALB = 0.99D0
40877 BEB = 0D0
40878 AKB = - 0.193D0 * S
40879 AB = 0D0
40880 BB = 0D0
40881 DBT = 3.447D0 + 0.927D0 * S
40882 EBT = 4.68D0 + 1.259D0 * S
40883 ESB = 1.892D0 + 2.199D0 * S
40884 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
40885
40886C...gl :
40887 ALG = 1.014D0
40888 BEG = 1.738D0
40889 AKG = 1.724D0 + 0.157D0 * S
40890 BKG = 0.800D0 + 1.016D0 * S
40891 AG = 7.517D0 - 2.547D0 * S
40892 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
40893 CG = 4.039D0 + 1.491D0 * S
40894 DG = 3.404D0 + 0.830D0 * S
40895 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
40896 ESG = 3.256D0 - 0.436D0 * S
40897 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
40898
40899 RETURN
40900 END
40901
40902C*********************************************************************
40903
40904C...PYGRVD
40905C...Gives the GRV 94 D (DIS) parton distribution function set
40906C...in parametrized form.
40907C...Authors: M. Glueck, E. Reya and A. Vogt.
40908
40909 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
40910
40911C...Double precision declaration.
40912 IMPLICIT DOUBLE PRECISION (A - Z)
40913
40914C...Common expressions.
40915 MU2 = 0.34D0
40916 LAM2 = 0.248D0 * 0.248D0
40917 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
40918 DS = SQRT (S)
40919 S2 = S * S
40920 S3 = S2 * S
40921
40922C...uv :
40923 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
40924 AKU = 0.563D0 - 0.025D0 * S
40925 BKU = 0.054D0 + 0.154D0 * S
40926 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
40927 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
40928 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
40929 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
40930 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
40931
40932C...dv :
40933 ND = 0.156D0 - 0.017D0 * S
40934 AKD = 0.299D0 - 0.022D0 * S
40935 BKD = 0.259D0 - 0.015D0 * S
40936 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
40937 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
40938 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
40939 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
40940 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
40941
40942C...del :
40943 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
40944 AKE = 0.419D0 - 0.013D0 * S
40945 BKE = 1.064D0 - 0.038D0 * S
40946 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
40947 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
40948 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
40949 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
40950 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
40951
40952C...udb :
40953 ALX = 1.215D0
40954 BEX = 0.466D0
40955 AKX = 0.326D0 + 0.150D0 * S
40956 BKX = 0.956D0 + 0.405D0 * S
40957 AGX = 0.272D0
40958 BGX = 3.794D0 - 2.359D0 * DS
40959 CX = 2.014D0
40960 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
40961 EX = 3.049D0 + 1.597D0 * S
40962 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
40963 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
40964 & DX, EX, ESX)
40965
40966C...sb :
40967 STS = 0D0
40968 ALS = 0.175D0
40969 BES = 0.344D0
40970 AKS = 1.415D0 - 0.641D0 * DS
40971 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
40972 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
40973 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
40974 EST = 4.546D0 + 0.372D0 * S2
40975 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
40976 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
40977
40978C...cb :
40979 STC = 0.820D0
40980 ALC = 0.98D0
40981 BEC = 0D0
40982 AKC = -0.625D0 - 0.523D0 * S
40983 AC = 0D0
40984 BC = 1.896D0 + 1.616D0 * S
40985 DCT = 4.12D0 + 0.683D0 * S
40986 ECT = 4.36D0 + 1.328D0 * S
40987 ESC = 0.677D0 + 0.679D0 * S
40988 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
40989
40990C...bb :
40991 STB = 1.297D0
40992 ALB = 0.99D0
40993 BEB = 0D0
40994 AKB = - 0.193D0 * S
40995 AB = 0D0
40996 BB = 0D0
40997 DBT = 3.447D0 + 0.927D0 * S
40998 EBT = 4.68D0 + 1.259D0 * S
40999 ESB = 1.892D0 + 2.199D0 * S
41000 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41001
41002C...gl :
41003 ALG = 1.258D0
41004 BEG = 1.846D0
41005 AKG = 2.423D0
41006 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41007 AG = 25.09D0 - 7.935D0 * S
41008 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41009 CG = 590.3D0 - 173.8D0 * S
41010 DG = 5.196D0 + 1.857D0 * S
41011 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41012 ESG = 3.232D0 - 0.542D0 * S
41013 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41014
41015 RETURN
41016 END
41017
41018C*********************************************************************
41019
41020C...PYGRVV
41021C...Auxiliary for the GRV 94 parton distribution functions
41022C...for u and d valence and d-u sea.
41023C...Authors: M. Glueck, E. Reya and A. Vogt.
41024
41025 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41026
41027C...Double precision declaration.
41028 IMPLICIT DOUBLE PRECISION (A - Z)
41029
41030C...Evaluation.
41031 DX = SQRT (X)
41032 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41033 & (1D0- X)**D
41034
41035 RETURN
41036 END
41037
41038C*********************************************************************
41039
41040C...PYGRVW
41041C...Auxiliary for the GRV 94 parton distribution functions
41042C...for d+u sea and gluon.
41043C...Authors: M. Glueck, E. Reya and A. Vogt.
41044
41045 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41046
41047C...Double precision declaration.
41048 IMPLICIT DOUBLE PRECISION (A - Z)
41049
41050C...Evaluation.
41051 LX = LOG (1D0/X)
41052 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41053 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41054
41055 RETURN
41056 END
41057
41058C*********************************************************************
41059
41060C...PYGRVS
41061C...Auxiliary for the GRV 94 parton distribution functions
41062C...for s, c and b sea.
41063C...Authors: M. Glueck, E. Reya and A. Vogt.
41064
41065 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41066
41067C...Double precision declaration.
41068 IMPLICIT DOUBLE PRECISION (A - Z)
41069
41070C...Evaluation.
41071 IF(S.LE.STH) THEN
41072 PYGRVS = 0D0
41073 ELSE
41074 DX = SQRT (X)
41075 LX = LOG (1D0/X)
41076 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41077 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41078 ENDIF
41079
41080 RETURN
41081 END
41082
41083C*********************************************************************
41084
41085C...PYCT5L
41086C...Auxiliary function for parametrization of CTEQ5L.
41087C...Author: J. Pumplin 9/99.
41088
41089C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41090C...in Parametrized Form
41091C... September 15, 1999
41092C
41093C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41094C... CTEQ5 PPARTON DISTRIBUTIONS"
41095C...hep-ph/9903282
41096
41097C...The CTEQ5M1 set given here is an updated version of the original
41098C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41099C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41100C...almost all applications.
41101C...The improvement is in the QCD evolution which is now more
41102C...accurate, and which agrees completely with the benchmark work
41103C...of the HERA 96/97 Workshop.
41104C...The differences between the parametrized and the corresponding
41105C...table versions (on which it is based) are of similar order as
41106C...between the two version.
41107
41108C...!! Because accurate parametrizations over a wide range of (x,Q)
41109C...is hard to obtain, only the most widely used sets CTEQ5M and
41110C...CTEQ5L are available in parametrized form for now.
41111
41112C...These parametrizations were obtained by Jon Pumplin.
41113
41114C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41115C -------------------------------------------------------------------
41116C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41117C 3 CTEQ5L Leading Order 0.127 192 146
41118C -------------------------------------------------------------------
41119C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41120C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41121C...calibration.
41122
41123C...The two Iset value are adopted to agree with the standard table
41124C...versions.
41125
41126C...Range of validity:
41127C...The range of (x, Q) covered by this parametrization of the QCD
41128C...evolved parton distributions is 1E-6 < x < 1 ;
41129C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41130C...data only in a subset of that region; and the assumed DGLAP
41131C...evolution is unlikely to be valid for all of it either.
41132
41133C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41134C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41135C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41136C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41137
41138 FUNCTION PYCT5L(IFL,X,Q)
41139
41140C...Double precision declaration.
41141 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41142 IMPLICIT INTEGER(I-N)
41143
41144 PARAMETER (NEX=8, NLF=2)
41145 DIMENSION AM(0:NEX,0:NLF,-5:2)
41146 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41147 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41148 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41149 DIMENSION AF(0:NEX)
41150
41151 DATA MEXVEC( 2) / 8 /
41152 DATA MLFVEC( 2) / 2 /
41153 DATA UT1VEC( 2) / 0.4971265E+01 /
41154 DATA UT2VEC( 2) / -0.1105128E+01 /
41155 DATA ALFVEC( 2) / 0.2987216E+00 /
41156 DATA QMAVEC( 2) / 0.0000000E+00 /
41157 DATA (AM( 0,K, 2),K=0, 2)
41158 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41159 DATA (AM( 1,K, 2),K=0, 2)
41160 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41161 DATA (AM( 2,K, 2),K=0, 2)
41162 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41163 DATA (AM( 3,K, 2),K=0, 2)
41164 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41165 DATA (AM( 4,K, 2),K=0, 2)
41166 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41167 DATA (AM( 5,K, 2),K=0, 2)
41168 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41169 DATA (AM( 6,K, 2),K=0, 2)
41170 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41171 DATA (AM( 7,K, 2),K=0, 2)
41172 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41173 DATA (AM( 8,K, 2),K=0, 2)
41174 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41175
41176 DATA MEXVEC( 1) / 8 /
41177 DATA MLFVEC( 1) / 2 /
41178 DATA UT1VEC( 1) / 0.2612618E+01 /
41179 DATA UT2VEC( 1) / -0.1258304E+06 /
41180 DATA ALFVEC( 1) / 0.3407552E+00 /
41181 DATA QMAVEC( 1) / 0.0000000E+00 /
41182 DATA (AM( 0,K, 1),K=0, 2)
41183 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41184 DATA (AM( 1,K, 1),K=0, 2)
41185 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41186 DATA (AM( 2,K, 1),K=0, 2)
41187 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41188 DATA (AM( 3,K, 1),K=0, 2)
41189 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41190 DATA (AM( 4,K, 1),K=0, 2)
41191 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41192 DATA (AM( 5,K, 1),K=0, 2)
41193 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41194 DATA (AM( 6,K, 1),K=0, 2)
41195 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41196 DATA (AM( 7,K, 1),K=0, 2)
41197 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41198 DATA (AM( 8,K, 1),K=0, 2)
41199 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41200
41201 DATA MEXVEC( 0) / 8 /
41202 DATA MLFVEC( 0) / 2 /
41203 DATA UT1VEC( 0) / -0.4656819E+00 /
41204 DATA UT2VEC( 0) / -0.2742390E+03 /
41205 DATA ALFVEC( 0) / 0.4491863E+00 /
41206 DATA QMAVEC( 0) / 0.0000000E+00 /
41207 DATA (AM( 0,K, 0),K=0, 2)
41208 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41209 DATA (AM( 1,K, 0),K=0, 2)
41210 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41211 DATA (AM( 2,K, 0),K=0, 2)
41212 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41213 DATA (AM( 3,K, 0),K=0, 2)
41214 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41215 DATA (AM( 4,K, 0),K=0, 2)
41216 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41217 DATA (AM( 5,K, 0),K=0, 2)
41218 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41219 DATA (AM( 6,K, 0),K=0, 2)
41220 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41221 DATA (AM( 7,K, 0),K=0, 2)
41222 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41223 DATA (AM( 8,K, 0),K=0, 2)
41224 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41225
41226 DATA MEXVEC(-1) / 8 /
41227 DATA MLFVEC(-1) / 2 /
41228 DATA UT1VEC(-1) / 0.3862583E+01 /
41229 DATA UT2VEC(-1) / -0.1265969E+01 /
41230 DATA ALFVEC(-1) / 0.2457668E+00 /
41231 DATA QMAVEC(-1) / 0.0000000E+00 /
41232 DATA (AM( 0,K,-1),K=0, 2)
41233 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41234 DATA (AM( 1,K,-1),K=0, 2)
41235 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41236 DATA (AM( 2,K,-1),K=0, 2)
41237 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41238 DATA (AM( 3,K,-1),K=0, 2)
41239 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41240 DATA (AM( 4,K,-1),K=0, 2)
41241 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41242 DATA (AM( 5,K,-1),K=0, 2)
41243 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41244 DATA (AM( 6,K,-1),K=0, 2)
41245 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41246 DATA (AM( 7,K,-1),K=0, 2)
41247 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
41248 DATA (AM( 8,K,-1),K=0, 2)
41249 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
41250
41251 DATA MEXVEC(-2) / 7 /
41252 DATA MLFVEC(-2) / 2 /
41253 DATA UT1VEC(-2) / 0.1895615E+00 /
41254 DATA UT2VEC(-2) / -0.3069097E+01 /
41255 DATA ALFVEC(-2) / 0.5293999E+00 /
41256 DATA QMAVEC(-2) / 0.0000000E+00 /
41257 DATA (AM( 0,K,-2),K=0, 2)
41258 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
41259 DATA (AM( 1,K,-2),K=0, 2)
41260 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
41261 DATA (AM( 2,K,-2),K=0, 2)
41262 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
41263 DATA (AM( 3,K,-2),K=0, 2)
41264 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
41265 DATA (AM( 4,K,-2),K=0, 2)
41266 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
41267 DATA (AM( 5,K,-2),K=0, 2)
41268 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
41269 DATA (AM( 6,K,-2),K=0, 2)
41270 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
41271 DATA (AM( 7,K,-2),K=0, 2)
41272 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
41273
41274 DATA MEXVEC(-3) / 7 /
41275 DATA MLFVEC(-3) / 2 /
41276 DATA UT1VEC(-3) / 0.3753257E+01 /
41277 DATA UT2VEC(-3) / -0.1113085E+01 /
41278 DATA ALFVEC(-3) / 0.3713141E+00 /
41279 DATA QMAVEC(-3) / 0.0000000E+00 /
41280 DATA (AM( 0,K,-3),K=0, 2)
41281 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
41282 DATA (AM( 1,K,-3),K=0, 2)
41283 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
41284 DATA (AM( 2,K,-3),K=0, 2)
41285 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
41286 DATA (AM( 3,K,-3),K=0, 2)
41287 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
41288 DATA (AM( 4,K,-3),K=0, 2)
41289 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
41290 DATA (AM( 5,K,-3),K=0, 2)
41291 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
41292 DATA (AM( 6,K,-3),K=0, 2)
41293 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
41294 DATA (AM( 7,K,-3),K=0, 2)
41295 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
41296
41297 DATA MEXVEC(-4) / 7 /
41298 DATA MLFVEC(-4) / 2 /
41299 DATA UT1VEC(-4) / 0.4400772E+01 /
41300 DATA UT2VEC(-4) / -0.1356116E+01 /
41301 DATA ALFVEC(-4) / 0.3712017E-01 /
41302 DATA QMAVEC(-4) / 0.1300000E+01 /
41303 DATA (AM( 0,K,-4),K=0, 2)
41304 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
41305 DATA (AM( 1,K,-4),K=0, 2)
41306 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
41307 DATA (AM( 2,K,-4),K=0, 2)
41308 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
41309 DATA (AM( 3,K,-4),K=0, 2)
41310 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
41311 DATA (AM( 4,K,-4),K=0, 2)
41312 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
41313 DATA (AM( 5,K,-4),K=0, 2)
41314 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
41315 DATA (AM( 6,K,-4),K=0, 2)
41316 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
41317 DATA (AM( 7,K,-4),K=0, 2)
41318 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
41319
41320 DATA MEXVEC(-5) / 6 /
41321 DATA MLFVEC(-5) / 2 /
41322 DATA UT1VEC(-5) / 0.5562568E+01 /
41323 DATA UT2VEC(-5) / -0.1801317E+01 /
41324 DATA ALFVEC(-5) / 0.4952010E-02 /
41325 DATA QMAVEC(-5) / 0.4500000E+01 /
41326 DATA (AM( 0,K,-5),K=0, 2)
41327 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
41328 DATA (AM( 1,K,-5),K=0, 2)
41329 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
41330 DATA (AM( 2,K,-5),K=0, 2)
41331 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
41332 DATA (AM( 3,K,-5),K=0, 2)
41333 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
41334 DATA (AM( 4,K,-5),K=0, 2)
41335 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
41336 DATA (AM( 5,K,-5),K=0, 2)
41337 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
41338 DATA (AM( 6,K,-5),K=0, 2)
41339 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
41340
41341 IF(Q .LE. QMAVEC(IFL)) THEN
41342 PYCT5L = 0.D0
41343 RETURN
41344 ENDIF
41345
41346 IF(X .GE. 1.D0) THEN
41347 PYCT5L = 0.D0
41348 RETURN
41349 ENDIF
41350
41351 TMP = LOG(Q/ALFVEC(IFL))
41352 IF(TMP .LE. 0.D0) THEN
41353 PYCT5L = 0.D0
41354 RETURN
41355 ENDIF
41356
41357 SB = LOG(TMP)
41358 SB1 = SB - 1.2D0
41359 SB2 = SB1*SB1
41360
41361 DO 110 I = 0, NEX
41362 AF(I) = 0.D0
41363 SBX = 1.D0
41364 DO 100 K = 0, MLFVEC(IFL)
41365 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41366 SBX = SB1*SBX
41367 100 CONTINUE
41368 110 CONTINUE
41369
41370 Y = -LOG(X)
41371 U = LOG(X/0.00001D0)
41372
41373 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41374 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41375 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41376 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41377 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41378
41379 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41380
41381C...Include threshold factor.
41382 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
41383
41384 RETURN
41385 END
41386
41387C*********************************************************************
41388
41389C...PYCT5M
41390C...Auxiliary function for parametrization of CTEQ5M1.
41391C...Author: J. Pumplin 9/99.
41392
41393 FUNCTION PYCT5M(IFL,X,Q)
41394
41395C...Double precision declaration.
41396 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41397 IMPLICIT INTEGER(I-N)
41398
41399 PARAMETER (NEX=8, NLF=2)
41400 DIMENSION AM(0:NEX,0:NLF,-5:2)
41401 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41402 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41403 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41404 DIMENSION AF(0:NEX)
41405
41406 DATA MEXVEC( 2) / 8 /
41407 DATA MLFVEC( 2) / 2 /
41408 DATA UT1VEC( 2) / 0.5141718E+01 /
41409 DATA UT2VEC( 2) / -0.1346944E+01 /
41410 DATA ALFVEC( 2) / 0.5260555E+00 /
41411 DATA QMAVEC( 2) / 0.0000000E+00 /
41412 DATA (AM( 0,K, 2),K=0, 2)
41413 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
41414 DATA (AM( 1,K, 2),K=0, 2)
41415 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
41416 DATA (AM( 2,K, 2),K=0, 2)
41417 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
41418 DATA (AM( 3,K, 2),K=0, 2)
41419 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
41420 DATA (AM( 4,K, 2),K=0, 2)
41421 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
41422 DATA (AM( 5,K, 2),K=0, 2)
41423 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
41424 DATA (AM( 6,K, 2),K=0, 2)
41425 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
41426 DATA (AM( 7,K, 2),K=0, 2)
41427 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
41428 DATA (AM( 8,K, 2),K=0, 2)
41429 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
41430
41431 DATA MEXVEC( 1) / 8 /
41432 DATA MLFVEC( 1) / 2 /
41433 DATA UT1VEC( 1) / 0.4138426E+01 /
41434 DATA UT2VEC( 1) / -0.3221374E+01 /
41435 DATA ALFVEC( 1) / 0.4960962E+00 /
41436 DATA QMAVEC( 1) / 0.0000000E+00 /
41437 DATA (AM( 0,K, 1),K=0, 2)
41438 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
41439 DATA (AM( 1,K, 1),K=0, 2)
41440 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
41441 DATA (AM( 2,K, 1),K=0, 2)
41442 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
41443 DATA (AM( 3,K, 1),K=0, 2)
41444 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
41445 DATA (AM( 4,K, 1),K=0, 2)
41446 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
41447 DATA (AM( 5,K, 1),K=0, 2)
41448 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
41449 DATA (AM( 6,K, 1),K=0, 2)
41450 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
41451 DATA (AM( 7,K, 1),K=0, 2)
41452 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
41453 DATA (AM( 8,K, 1),K=0, 2)
41454 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
41455
41456 DATA MEXVEC( 0) / 8 /
41457 DATA MLFVEC( 0) / 2 /
41458 DATA UT1VEC( 0) / -0.1026789E+01 /
41459 DATA UT2VEC( 0) / -0.9051707E+01 /
41460 DATA ALFVEC( 0) / 0.9462977E+00 /
41461 DATA QMAVEC( 0) / 0.0000000E+00 /
41462 DATA (AM( 0,K, 0),K=0, 2)
41463 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
41464 DATA (AM( 1,K, 0),K=0, 2)
41465 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
41466 DATA (AM( 2,K, 0),K=0, 2)
41467 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
41468 DATA (AM( 3,K, 0),K=0, 2)
41469 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
41470 DATA (AM( 4,K, 0),K=0, 2)
41471 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
41472 DATA (AM( 5,K, 0),K=0, 2)
41473 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
41474 DATA (AM( 6,K, 0),K=0, 2)
41475 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
41476 DATA (AM( 7,K, 0),K=0, 2)
41477 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
41478 DATA (AM( 8,K, 0),K=0, 2)
41479 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
41480
41481 DATA MEXVEC(-1) / 8 /
41482 DATA MLFVEC(-1) / 2 /
41483 DATA UT1VEC(-1) / 0.5243571E+01 /
41484 DATA UT2VEC(-1) / -0.2870513E+01 /
41485 DATA ALFVEC(-1) / 0.6701448E+00 /
41486 DATA QMAVEC(-1) / 0.0000000E+00 /
41487 DATA (AM( 0,K,-1),K=0, 2)
41488 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
41489 DATA (AM( 1,K,-1),K=0, 2)
41490 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
41491 DATA (AM( 2,K,-1),K=0, 2)
41492 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
41493 DATA (AM( 3,K,-1),K=0, 2)
41494 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
41495 DATA (AM( 4,K,-1),K=0, 2)
41496 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
41497 DATA (AM( 5,K,-1),K=0, 2)
41498 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
41499 DATA (AM( 6,K,-1),K=0, 2)
41500 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
41501 DATA (AM( 7,K,-1),K=0, 2)
41502 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
41503 DATA (AM( 8,K,-1),K=0, 2)
41504 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
41505
41506 DATA MEXVEC(-2) / 7 /
41507 DATA MLFVEC(-2) / 2 /
41508 DATA UT1VEC(-2) / 0.4782210E+01 /
41509 DATA UT2VEC(-2) / -0.1976856E+02 /
41510 DATA ALFVEC(-2) / 0.7558374E+00 /
41511 DATA QMAVEC(-2) / 0.0000000E+00 /
41512 DATA (AM( 0,K,-2),K=0, 2)
41513 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
41514 DATA (AM( 1,K,-2),K=0, 2)
41515 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
41516 DATA (AM( 2,K,-2),K=0, 2)
41517 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
41518 DATA (AM( 3,K,-2),K=0, 2)
41519 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
41520 DATA (AM( 4,K,-2),K=0, 2)
41521 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
41522 DATA (AM( 5,K,-2),K=0, 2)
41523 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
41524 DATA (AM( 6,K,-2),K=0, 2)
41525 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
41526 DATA (AM( 7,K,-2),K=0, 2)
41527 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
41528
41529 DATA MEXVEC(-3) / 7 /
41530 DATA MLFVEC(-3) / 2 /
41531 DATA UT1VEC(-3) / 0.4518239E+01 /
41532 DATA UT2VEC(-3) / -0.2690590E+01 /
41533 DATA ALFVEC(-3) / 0.6124079E+00 /
41534 DATA QMAVEC(-3) / 0.0000000E+00 /
41535 DATA (AM( 0,K,-3),K=0, 2)
41536 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
41537 DATA (AM( 1,K,-3),K=0, 2)
41538 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
41539 DATA (AM( 2,K,-3),K=0, 2)
41540 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
41541 DATA (AM( 3,K,-3),K=0, 2)
41542 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
41543 DATA (AM( 4,K,-3),K=0, 2)
41544 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
41545 DATA (AM( 5,K,-3),K=0, 2)
41546 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
41547 DATA (AM( 6,K,-3),K=0, 2)
41548 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
41549 DATA (AM( 7,K,-3),K=0, 2)
41550 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
41551
41552 DATA MEXVEC(-4) / 7 /
41553 DATA MLFVEC(-4) / 2 /
41554 DATA UT1VEC(-4) / 0.2783230E+01 /
41555 DATA UT2VEC(-4) / -0.1746328E+01 /
41556 DATA ALFVEC(-4) / 0.1115653E+01 /
41557 DATA QMAVEC(-4) / 0.1300000E+01 /
41558 DATA (AM( 0,K,-4),K=0, 2)
41559 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
41560 DATA (AM( 1,K,-4),K=0, 2)
41561 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
41562 DATA (AM( 2,K,-4),K=0, 2)
41563 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
41564 DATA (AM( 3,K,-4),K=0, 2)
41565 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
41566 DATA (AM( 4,K,-4),K=0, 2)
41567 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
41568 DATA (AM( 5,K,-4),K=0, 2)
41569 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
41570 DATA (AM( 6,K,-4),K=0, 2)
41571 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
41572 DATA (AM( 7,K,-4),K=0, 2)
41573 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
41574
41575 DATA MEXVEC(-5) / 6 /
41576 DATA MLFVEC(-5) / 2 /
41577 DATA UT1VEC(-5) / 0.1619654E+02 /
41578 DATA UT2VEC(-5) / -0.3367346E+01 /
41579 DATA ALFVEC(-5) / 0.5109891E-02 /
41580 DATA QMAVEC(-5) / 0.4500000E+01 /
41581 DATA (AM( 0,K,-5),K=0, 2)
41582 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
41583 DATA (AM( 1,K,-5),K=0, 2)
41584 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
41585 DATA (AM( 2,K,-5),K=0, 2)
41586 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
41587 DATA (AM( 3,K,-5),K=0, 2)
41588 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
41589 DATA (AM( 4,K,-5),K=0, 2)
41590 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
41591 DATA (AM( 5,K,-5),K=0, 2)
41592 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
41593 DATA (AM( 6,K,-5),K=0, 2)
41594 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
41595
41596 IF(Q .LE. QMAVEC(IFL)) THEN
41597 PYCT5M = 0.D0
41598 RETURN
41599 ENDIF
41600
41601 IF(X .GE. 1.D0) THEN
41602 PYCT5M = 0.D0
41603 RETURN
41604 ENDIF
41605
41606 TMP = LOG(Q/ALFVEC(IFL))
41607 IF(TMP .LE. 0.D0) THEN
41608 PYCT5M = 0.D0
41609 RETURN
41610 ENDIF
41611
41612 SB = LOG(TMP)
41613 SB1 = SB - 1.2D0
41614 SB2 = SB1*SB1
41615
41616 DO 110 I = 0, NEX
41617 AF(I) = 0.D0
41618 SBX = 1.D0
41619 DO 100 K = 0, MLFVEC(IFL)
41620 AF(I) = AF(I) + SBX*AM(I,K,IFL)
41621 SBX = SB1*SBX
41622 100 CONTINUE
41623 110 CONTINUE
41624
41625 Y = -LOG(X)
41626 U = LOG(X/0.00001D0)
41627
41628 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
41629 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
41630 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
41631 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
41632 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
41633
41634 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
41635
41636C...Include threshold factor.
41637 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
41638
41639 RETURN
41640 END
41641
41642C*********************************************************************
41643
41644C...PYPDPO
41645C...Auxiliary to PYPDPR. Gives proton parton distributions according to
41646C...a few older parametrizations, now obsolete but convenient for
41647C...backwards checks.
41648
41649 SUBROUTINE PYPDPO(X,Q2,XPPR)
41650
41651C...Double precision and integer declarations.
41652 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41653 IMPLICIT INTEGER(I-N)
41654 INTEGER PYK,PYCHGE,PYCOMP
41655C...Commonblocks.
41656 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41657 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41658 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41659 COMMON/PYINT1/MINT(400),VINT(400)
41660 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41661 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
41662 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
41663
41664
41665C...The following data lines are coefficients needed in the
41666C...Eichten, Hinchliffe, Lane, Quigg proton structure function
41667C...parametrizations, see below.
41668C...Powers of 1-x in different cases.
41669 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
41670C...Expansion coefficients for up valence quark distribution.
41671 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
41672 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
41673 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
41674 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
41675 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
41676 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
41677 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
41678 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
41679 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
41680 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
41681 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
41682 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
41683 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
41684 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
41685 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
41686 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
41687 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
41688 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
41689 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
41690 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
41691 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
41692 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
41693 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
41694 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
41695 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
41696 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
41697C...Expansion coefficients for down valence quark distribution.
41698 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
41699 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
41700 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
41701 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
41702 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
41703 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
41704 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
41705 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
41706 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
41707 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
41708 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
41709 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
41710 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
41711 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
41712 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
41713 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
41714 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
41715 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
41716 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
41717 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
41718 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
41719 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
41720 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
41721 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
41722 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
41723 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
41724C...Expansion coefficients for up and down sea quark distributions.
41725 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
41726 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
41727 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
41728 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
41729 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
41730 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
41731 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
41732 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
41733 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
41734 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
41735 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
41736 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
41737 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
41738 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
41739 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
41740 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
41741 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
41742 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
41743 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
41744 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
41745 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
41746 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
41747 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
41748 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
41749 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
41750 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
41751C...Expansion coefficients for gluon distribution.
41752 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
41753 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
41754 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
41755 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
41756 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
41757 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
41758 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
41759 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
41760 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
41761 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
41762 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
41763 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
41764 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
41765 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
41766 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
41767 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
41768 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
41769 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
41770 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
41771 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
41772 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
41773 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
41774 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
41775 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
41776 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
41777 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
41778C...Expansion coefficients for strange sea quark distribution.
41779 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
41780 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
41781 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
41782 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
41783 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
41784 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
41785 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
41786 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
41787 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
41788 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
41789 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
41790 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
41791 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
41792 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
41793 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
41794 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
41795 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
41796 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
41797 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
41798 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
41799 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
41800 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
41801 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
41802 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
41803 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
41804 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
41805C...Expansion coefficients for charm sea quark distribution.
41806 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
41807 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
41808 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
41809 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
41810 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
41811 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
41812 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
41813 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
41814 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
41815 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
41816 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
41817 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
41818 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
41819 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
41820 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
41821 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
41822 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
41823 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
41824 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
41825 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
41826 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
41827 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
41828 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
41829 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
41830 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
41831 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
41832C...Expansion coefficients for bottom sea quark distribution.
41833 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
41834 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
41835 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
41836 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
41837 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
41838 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
41839 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
41840 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
41841 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
41842 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
41843 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
41844 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
41845 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
41846 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
41847 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
41848 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
41849 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
41850 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
41851 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
41852 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
41853 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
41854 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
41855 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
41856 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
41857 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
41858 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
41859C...Expansion coefficients for top sea quark distribution.
41860 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
41861 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
41862 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
41863 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
41864 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41865 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
41866 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41867 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
41868 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
41869 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
41870 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
41871 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
41872 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
41873 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
41874 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
41875 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
41876 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
41877 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
41878 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
41879 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
41880 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
41881 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
41882 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
41883 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
41884 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
41885 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
41886
41887C...The following data lines are coefficients needed in the
41888C...Duke, Owens proton structure function parametrizations, see below.
41889C...Expansion coefficients for (up+down) valence quark distribution.
41890 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
41891 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41892 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41893 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41894 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
41895 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41896 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41897 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
41898C...Expansion coefficients for down valence quark distribution.
41899 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
41900 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41901 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41902 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41903 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
41904 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41905 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
41906 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
41907C...Expansion coefficients for (up+down+strange) sea quark distribution.
41908 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
41909 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41910 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
41911 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
41912 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
41913 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41914 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
41915 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
41916C...Expansion coefficients for charm sea quark distribution.
41917 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
41918 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41919 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
41920 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
41921 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
41922 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
41923 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
41924 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
41925C...Expansion coefficients for gluon distribution.
41926 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
41927 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41928 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
41929 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
41930 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
41931 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
41932 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
41933 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
41934
41935C...Euler's beta function, requires ordinary Gamma function
41936 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
41937
41938C...Leading order proton parton distributions from Glueck, Reya and
41939C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
41940C...10^-5 < x < 1.
41941 IF(MSTP(51).EQ.11) THEN
41942
41943C...Determine s expansion variable and some x expressions.
41944 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
41945 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
41946 SD2=SD**2
41947 XL=-LOG(X)
41948 XS=SQRT(X)
41949
41950C...Evaluate valence, gluon and sea distributions.
41951 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
41952 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
41953 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
41954 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
41955 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
41956 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
41957 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
41958 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
41959 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
41960 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
41961 & SQRT(4.066D0*SD**1.218D0*XL)))*
41962 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
41963 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
41964 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
41965 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
41966 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
41967 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
41968 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
41969 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
41970 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
41971 IF(SD.LE.0.888D0) THEN
41972 XFCHM=0D0
41973 ELSE
41974 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
41975 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
41976 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
41977 ENDIF
41978 IF(SD.LE.1.351D0) THEN
41979 XFBOT=0D0
41980 ELSE
41981 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
41982 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
41983 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
41984 ENDIF
41985
41986C...Put into output array.
41987 XPPR(0)=XFGLU
41988 XPPR(1)=XFVDD+XFSEA
41989 XPPR(2)=XFVUD-XFVDD+XFSEA
41990 XPPR(3)=XFSTR
41991 XPPR(4)=XFCHM
41992 XPPR(5)=XFBOT
41993 XPPR(-1)=XFSEA
41994 XPPR(-2)=XFSEA
41995 XPPR(-3)=XFSTR
41996 XPPR(-4)=XFCHM
41997 XPPR(-5)=XFBOT
41998
41999C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42000C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42001 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42002
42003C...Determine set, Lambda and x and t expansion variables.
42004 NSET=MSTP(51)-11
42005 IF(NSET.EQ.1) ALAM=0.2D0
42006 IF(NSET.EQ.2) ALAM=0.29D0
42007 TMIN=LOG(5D0/ALAM**2)
42008 TMAX=LOG(1D8/ALAM**2)
42009 T=LOG(MAX(1D0,Q2/ALAM**2))
42010 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42011 NX=1
42012 IF(X.LE.0.1D0) NX=2
42013 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42014 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42015
42016C...Chebyshev polynomials for x and t expansion.
42017 TX(1)=1D0
42018 TX(2)=VX
42019 TX(3)=2D0*VX**2-1D0
42020 TX(4)=4D0*VX**3-3D0*VX
42021 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42022 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42023 TT(1)=1D0
42024 TT(2)=VT
42025 TT(3)=2D0*VT**2-1D0
42026 TT(4)=4D0*VT**3-3D0*VT
42027 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42028 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42029
42030C...Calculate structure functions.
42031 DO 120 KFL=1,6
42032 XQSUM=0D0
42033 DO 110 IT=1,6
42034 DO 100 IX=1,6
42035 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42036 100 CONTINUE
42037 110 CONTINUE
42038 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42039 120 CONTINUE
42040
42041C...Put into output array.
42042 XPPR(0)=XQ(4)
42043 XPPR(1)=XQ(2)+XQ(3)
42044 XPPR(2)=XQ(1)+XQ(3)
42045 XPPR(3)=XQ(5)
42046 XPPR(4)=XQ(6)
42047 XPPR(-1)=XQ(3)
42048 XPPR(-2)=XQ(3)
42049 XPPR(-3)=XQ(5)
42050 XPPR(-4)=XQ(6)
42051
42052C...Special expansion for bottom (threshold effects).
42053 IF(MSTP(58).GE.5) THEN
42054 IF(NSET.EQ.1) TMIN=8.1905D0
42055 IF(NSET.EQ.2) TMIN=7.4474D0
42056 IF(T.GT.TMIN) THEN
42057 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42058 TT(1)=1D0
42059 TT(2)=VT
42060 TT(3)=2D0*VT**2-1D0
42061 TT(4)=4D0*VT**3-3D0*VT
42062 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42063 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42064 XQSUM=0D0
42065 DO 140 IT=1,6
42066 DO 130 IX=1,6
42067 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42068 130 CONTINUE
42069 140 CONTINUE
42070 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42071 XPPR(-5)=XPPR(5)
42072 ENDIF
42073 ENDIF
42074
42075C...Special expansion for top (threshold effects).
42076 IF(MSTP(58).GE.6) THEN
42077 IF(NSET.EQ.1) TMIN=11.5528D0
42078 IF(NSET.EQ.2) TMIN=10.8097D0
42079 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42080 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42081 IF(T.GT.TMIN) THEN
42082 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42083 TT(1)=1D0
42084 TT(2)=VT
42085 TT(3)=2D0*VT**2-1D0
42086 TT(4)=4D0*VT**3-3D0*VT
42087 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42088 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42089 XQSUM=0D0
42090 DO 160 IT=1,6
42091 DO 150 IX=1,6
42092 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42093 150 CONTINUE
42094 160 CONTINUE
42095 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42096 XPPR(-6)=XPPR(6)
42097 ENDIF
42098 ENDIF
42099
42100C...Proton parton distributions from Duke, Owens.
42101C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42102 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42103
42104C...Determine set, Lambda and s expansion parameter.
42105 NSET=MSTP(51)-13
42106 IF(NSET.EQ.1) ALAM=0.2D0
42107 IF(NSET.EQ.2) ALAM=0.4D0
42108 Q2IN=MIN(1D6,MAX(4D0,Q2))
42109 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42110
42111C...Calculate structure functions.
42112 DO 180 KFL=1,5
42113 DO 170 IS=1,6
42114 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42115 & CDO(3,IS,KFL,NSET)*SD**2
42116 170 CONTINUE
42117 IF(KFL.LE.2) THEN
42118 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42119 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42120 ELSE
42121 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42122 & TS(5)*X**2+TS(6)*X**3)
42123 ENDIF
42124 180 CONTINUE
42125
42126C...Put into output arrays.
42127 XPPR(0)=XQ(5)
42128 XPPR(1)=XQ(2)+XQ(3)/6D0
42129 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42130 XPPR(3)=XQ(3)/6D0
42131 XPPR(4)=XQ(4)
42132 XPPR(-1)=XQ(3)/6D0
42133 XPPR(-2)=XQ(3)/6D0
42134 XPPR(-3)=XQ(3)/6D0
42135 XPPR(-4)=XQ(4)
42136
42137 ENDIF
42138
42139 RETURN
42140 END
42141
42142C*********************************************************************
42143
42144C...PYHFTH
42145C...Gives threshold attractive/repulsive factor for heavy flavour
42146C...production.
42147
42148 FUNCTION PYHFTH(SH,SQM,FRATT)
42149
42150C...Double precision and integer declarations.
42151 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42152 IMPLICIT INTEGER(I-N)
42153 INTEGER PYK,PYCHGE,PYCOMP
42154C...Commonblocks.
42155 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42156 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42157 COMMON/PYINT1/MINT(400),VINT(400)
42158 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42159
42160C...Value for alpha_strong.
42161 IF(MSTP(35).LE.1) THEN
42162 ALSSG=PARP(35)
42163 ELSE
42164 MST115=MSTU(115)
42165 MSTU(115)=MSTP(36)
42166 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42167 & PARP(36)**2)))
42168 ALSSG=PYALPS(Q2BN)
42169 MSTU(115)=MST115
42170 ENDIF
42171
42172C...Evaluate attractive and repulsive factors.
42173 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42174 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42175 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42176 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42177 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42178 VINT(138)=PYHFTH
42179
42180 RETURN
42181 END
42182
42183C*********************************************************************
42184
42185C...PYSPLI
42186C...Splits a hadron remnant into two (partons or hadron + parton)
42187C...in case it is more complicated than just a quark or a diquark.
42188
42189 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42190
42191C...Double precision and integer declarations.
42192 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42193 IMPLICIT INTEGER(I-N)
42194 INTEGER PYK,PYCHGE,PYCOMP
42195C...Commonblocks. PYDAT1 temporary
42196 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42197 COMMON/PYINT1/MINT(400),VINT(400)
42198 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42199 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42200C...Local array.
42201 DIMENSION KFL(3)
42202
42203C...Preliminaries. Parton composition.
42204 KFA=IABS(KF)
42205 KFS=ISIGN(1,KF)
42206 KFL(1)=MOD(KFA/1000,10)
42207 KFL(2)=MOD(KFA/100,10)
42208 KFL(3)=MOD(KFA/10,10)
42209 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42210 KFL(2)=INT(1.5D0+PYR(0))
42211 IF(MINT(105).EQ.333) KFL(2)=3
42212 IF(MINT(105).EQ.443) KFL(2)=4
42213 KFL(3)=KFL(2)
42214 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42215 KFL(2)=2
42216 KFL(3)=2
42217 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42218 KFL(2)=1
42219 KFL(3)=1
42220 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42221 KFL(2)=MOD(KFA/10,10)
42222 KFL(3)=MOD(KFA/100,10)
42223 ENDIF
42224 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42225 KFLR=KFLIN*KFS
42226 ELSE
42227 KFLR=KFLIN
42228 ENDIF
42229 KFLCH=0
42230
42231C...Subdivide lepton.
42232 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42233 IF(KFLR.EQ.KFA) THEN
42234 KFLSP=KFS*22
42235 ELSEIF(KFLR.EQ.22) THEN
42236 KFLSP=KFA
42237 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42238 KFLSP=KFA+1
42239 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42240 KFLSP=KFA-1
42241 ELSEIF(KFLR.EQ.21) THEN
42242 KFLSP=KFA
42243 KFLCH=KFS*21
42244 ELSE
42245 KFLSP=KFA
42246 KFLCH=-KFLR
42247 ENDIF
42248
42249C...Subdivide photon.
42250 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
42251 IF(KFLR.NE.21) THEN
42252 KFLSP=-KFLR
42253 ELSE
42254 RAGR=0.75D0*PYR(0)
42255 KFLSP=1
42256 IF(RAGR.GT.0.125D0) KFLSP=2
42257 IF(RAGR.GT.0.625D0) KFLSP=3
42258 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
42259 KFLCH=-KFLSP
42260 ENDIF
42261
42262C...Subdivide Reggeon or Pomeron.
42263 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
42264 IF(KFLIN.EQ.21) THEN
42265 KFLSP=KFS*21
42266 ELSE
42267 KFLSP=-KFLIN
42268 ENDIF
42269
42270C...Subdivide meson.
42271 ELSEIF(KFL(1).EQ.0) THEN
42272 KFL(2)=KFL(2)*(-1)**KFL(2)
42273 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
42274 IF(KFLR.EQ.KFL(2)) THEN
42275 KFLSP=KFL(3)
42276 ELSEIF(KFLR.EQ.KFL(3)) THEN
42277 KFLSP=KFL(2)
42278 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
42279 KFLSP=KFL(2)
42280 KFLCH=KFL(3)
42281 ELSEIF(KFLR.EQ.21) THEN
42282 KFLSP=KFL(3)
42283 KFLCH=KFL(2)
42284 ELSEIF(KFLR*KFL(2).GT.0) THEN
42285 NTRY=0
42286 100 NTRY=NTRY+1
42287 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
42288 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42289 GOTO 100
42290 ELSEIF(KFLCH.EQ.0) THEN
42291 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42292 MINT(51)=1
42293 RETURN
42294 ENDIF
42295 KFLSP=KFL(3)
42296 ELSE
42297 NTRY=0
42298 110 NTRY=NTRY+1
42299 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
42300 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42301 GOTO 110
42302 ELSEIF(KFLCH.EQ.0) THEN
42303 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42304 MINT(51)=1
42305 RETURN
42306 ENDIF
42307 KFLSP=KFL(2)
42308 ENDIF
42309
42310C...Special case for extracting photon from baryon without splitting
42311C...the latter. (Currently only used by external programs.)
42312 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
42313 KFLSP=KFA
42314 KFLCH=0
42315
42316C...Subdivide baryon.
42317 ELSE
42318 NAGR=0
42319 DO 120 J=1,3
42320 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
42321 120 CONTINUE
42322 IF(NAGR.GE.1) THEN
42323 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
42324 IAGR=0
42325 DO 130 J=1,3
42326 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
42327 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
42328 130 CONTINUE
42329 ELSE
42330 IAGR=1.00001D0+2.99998D0*PYR(0)
42331 ENDIF
42332 ID1=1
42333 IF(IAGR.EQ.1) ID1=2
42334 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
42335 ID2=6-IAGR-ID1
42336 KSP=3
42337 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
42338 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
42339 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
42340 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
42341 ELSEIF(MOD(KFA,10).EQ.2) THEN
42342 IF(IAGR.EQ.1) KSP=1
42343 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
42344 ENDIF
42345 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
42346 IF(KFLR.EQ.21) THEN
42347 KFLCH=KFL(IAGR)
42348 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
42349 NTRY=0
42350 140 NTRY=NTRY+1
42351 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
42352 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42353 GOTO 140
42354 ELSEIF(KFLCH.EQ.0) THEN
42355 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42356 MINT(51)=1
42357 RETURN
42358 ENDIF
42359 ELSEIF(NAGR.EQ.0) THEN
42360 NTRY=0
42361 150 NTRY=NTRY+1
42362 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
42363 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
42364 GOTO 150
42365 ELSEIF(KFLCH.EQ.0) THEN
42366 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
42367 MINT(51)=1
42368 RETURN
42369 ENDIF
42370 KFLSP=KFL(IAGR)
42371 ENDIF
42372 ENDIF
42373
42374C...Add on correct sign for result.
42375 KFLCH=KFLCH*KFS
42376 KFLSP=KFLSP*KFS
42377
42378 RETURN
42379 END
42380
42381C*********************************************************************
42382
42383C...PYGAMM
42384C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
42385C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
42386C...(Dover, 1965) 6.1.36.
42387
42388 FUNCTION PYGAMM(X)
42389
42390C...Double precision and integer declarations.
42391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42392 IMPLICIT INTEGER(I-N)
42393 INTEGER PYK,PYCHGE,PYCOMP
42394C...Local array and data.
42395 DIMENSION B(8)
42396 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
42397 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
42398
42399 NX=INT(X)
42400 DX=X-NX
42401
42402 PYGAMM=1D0
42403 DXP=1D0
42404 DO 100 I=1,8
42405 DXP=DXP*DX
42406 PYGAMM=PYGAMM+B(I)*DXP
42407 100 CONTINUE
42408 IF(X.LT.1D0) THEN
42409 PYGAMM=PYGAMM/X
42410 ELSE
42411 DO 110 IX=1,NX-1
42412 PYGAMM=(X-IX)*PYGAMM
42413 110 CONTINUE
42414 ENDIF
42415
42416 RETURN
42417 END
42418
42419C***********************************************************************
42420
42421C...PYWAUX
42422C...Calculates real and imaginary parts of the auxiliary functions W1
42423C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
42424C...der Bij, Nucl. Phys. B297 (1988) 221.
42425
42426 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
42427
42428C...Double precision and integer declarations.
42429 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42430 IMPLICIT INTEGER(I-N)
42431 INTEGER PYK,PYCHGE,PYCOMP
42432C...Commonblocks.
42433 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42434 SAVE /PYDAT1/
42435
42436 ASINH(X)=LOG(X+SQRT(X**2+1D0))
42437 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
42438
42439 IF(EPS.LT.0D0) THEN
42440 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
42441 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
42442 WIM=0D0
42443 ELSEIF(EPS.LT.1D0) THEN
42444 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
42445 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
42446 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
42447 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
42448 ELSE
42449 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
42450 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
42451 WIM=0D0
42452 ENDIF
42453
42454 RETURN
42455 END
42456
42457C***********************************************************************
42458
42459C...PYI3AU
42460C...Calculates real and imaginary parts of the auxiliary function I3;
42461C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
42462C...Nucl. Phys. B297 (1988) 221.
42463
42464 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
42465
42466C...Double precision and integer declarations.
42467 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42468 IMPLICIT INTEGER(I-N)
42469 INTEGER PYK,PYCHGE,PYCOMP
42470C...Commonblocks.
42471 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42472 SAVE /PYDAT1/
42473
42474 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
42475 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
42476
42477 IF(EPS.LT.0D0) THEN
42478 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42479 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42480 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42481 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
42482 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
42483 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
42484 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
42485 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
42486 & EPS))
42487 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42488 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42489 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42490 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
42491 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
42492 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
42493 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
42494 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
42495 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42496 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42497 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42498 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
42499 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
42500 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
42501 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
42502 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
42503 ELSE
42504 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42505 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
42506 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
42507 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
42508 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
42509 ENDIF
42510 F3IM=0D0
42511 ELSEIF(EPS.LT.1D0) THEN
42512 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42513 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
42514 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
42515 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
42516 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
42517 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42518 & (0.25D0*(RAT+1D0)*EPS))
42519 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
42520 & (0.25D0*(RAT+1D0)*EPS))
42521 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
42522 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
42523 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
42524 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
42525 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
42526 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
42527 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42528 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
42529 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
42530 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
42531 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
42532 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
42533 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
42534 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
42535 & (1D0+0.25D0*RAT*EPS-GA))
42536 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
42537 & (1D0+0.25D0*RAT*EPS-GA))
42538 ELSE
42539 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
42540 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
42541 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
42542 & LOG((GA+BE-1D0)/(BE-GA))
42543 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
42544 ENDIF
42545 ELSE
42546 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
42547 RCTHE=RSQ*(1D0-2D0*BE/EPS)
42548 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
42549 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
42550 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
42551 R=SQRT(RSQ)
42552 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
42553 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
42554 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
42555 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
42556 & (PHI-THE)*(PHI+THE-PARU(1))
42557 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
42558 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
42559 ENDIF
42560
42561 Y3RE=2D0/(2D0*BE-1D0)*F3RE
42562 Y3IM=2D0/(2D0*BE-1D0)*F3IM
42563
42564 RETURN
42565 END
42566
42567C***********************************************************************
42568
42569C...PYSPEN
42570C...Calculates real and imaginary part of Spence function; see
42571C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
42572
42573 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
42574
42575C...Double precision and integer declarations.
42576 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42577 IMPLICIT INTEGER(I-N)
42578 INTEGER PYK,PYCHGE,PYCOMP
42579C...Commonblocks.
42580 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42581 SAVE /PYDAT1/
42582C...Local array and data.
42583 DIMENSION B(0:14)
42584 DATA B/
42585 &1.000000D+00, -5.000000D-01, 1.666667D-01,
42586 &0.000000D+00, -3.333333D-02, 0.000000D+00,
42587 &2.380952D-02, 0.000000D+00, -3.333333D-02,
42588 &0.000000D+00, 7.575757D-02, 0.000000D+00,
42589 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
42590
42591 XRE=XREIN
42592 XIM=XIMIN
42593 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
42594 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
42595 IF(IREIM.EQ.2) PYSPEN=0D0
42596 RETURN
42597 ENDIF
42598
42599 XMOD=SQRT(XRE**2+XIM**2)
42600 IF(XMOD.LT.1D-6) THEN
42601 IF(IREIM.EQ.1) PYSPEN=0D0
42602 IF(IREIM.EQ.2) PYSPEN=0D0
42603 RETURN
42604 ENDIF
42605
42606 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42607 SP0RE=0D0
42608 SP0IM=0D0
42609 SGN=1D0
42610 IF(XMOD.GT.1D0) THEN
42611 ALGXRE=LOG(XMOD)
42612 ALGXIM=XARG-SIGN(PARU(1),XARG)
42613 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
42614 SP0IM=-ALGXRE*ALGXIM
42615 SGN=-1D0
42616 XMOD=1D0/XMOD
42617 XARG=-XARG
42618 XRE=XMOD*COS(XARG)
42619 XIM=XMOD*SIN(XARG)
42620 ENDIF
42621 IF(XRE.GT.0.5D0) THEN
42622 ALGXRE=LOG(XMOD)
42623 ALGXIM=XARG
42624 XRE=1D0-XRE
42625 XIM=-XIM
42626 XMOD=SQRT(XRE**2+XIM**2)
42627 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42628 ALGYRE=LOG(XMOD)
42629 ALGYIM=XARG
42630 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
42631 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
42632 SGN=-SGN
42633 ENDIF
42634
42635 XRE=1D0-XRE
42636 XIM=-XIM
42637 XMOD=SQRT(XRE**2+XIM**2)
42638 XARG=SIGN(ACOS(XRE/XMOD),XIM)
42639 ZRE=-LOG(XMOD)
42640 ZIM=-XARG
42641
42642 SPRE=0D0
42643 SPIM=0D0
42644 SAVERE=1D0
42645 SAVEIM=0D0
42646 DO 100 I=0,14
42647 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
42648 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
42649 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
42650 SAVERE=TERMRE
42651 SAVEIM=TERMIM
42652 SPRE=SPRE+B(I)*TERMRE
42653 SPIM=SPIM+B(I)*TERMIM
42654 100 CONTINUE
42655
42656 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
42657 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
42658
42659 RETURN
42660 END
42661
42662C***********************************************************************
42663
42664C...PYQQBH
42665C...Calculates the matrix element for the processes
42666C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
42667C...REDUCE output and part of the rest courtesy Z. Kunszt, see
42668C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
42669
42670 SUBROUTINE PYQQBH(WTQQBH)
42671
42672C...Double precision and integer declarations.
42673 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42674 IMPLICIT INTEGER(I-N)
42675 INTEGER PYK,PYCHGE,PYCOMP
42676C...Commonblocks.
42677 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42678 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42679 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42680 COMMON/PYINT1/MINT(400),VINT(400)
42681 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
42682 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
42683C...Local arrays and function.
42684 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
42685 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
42686 &PP(I,3)*PP(J,3)
42687
42688C...Mass parameters.
42689 WTQQBH=0D0
42690 ISUB=MINT(1)
42691 SHPR=SQRT(VINT(26))*VINT(1)
42692 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
42693 PH=SQRT(VINT(21))*VINT(1)
42694 SPQ=PQ**2
42695 SPH=PH**2
42696
42697C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
42698 DO 100 I=1,2
42699 PT=SQRT(MAX(0D0,VINT(197+5*I)))
42700 PP(I,1)=PT*COS(VINT(198+5*I))
42701 PP(I,2)=PT*SIN(VINT(198+5*I))
42702 100 CONTINUE
42703 PP(3,1)=-PP(1,1)-PP(2,1)
42704 PP(3,2)=-PP(1,2)-PP(2,2)
42705 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
42706 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
42707 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
42708 PMT3=SQRT(PMS3)
42709 PP(3,3)=PMT3*SINH(VINT(211))
42710 PP(3,4)=PMT3*COSH(VINT(211))
42711 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
42712 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
42713 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
42714 PP(2,3)=-PP(1,3)-PP(3,3)
42715 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
42716 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
42717
42718C...Set up incoming kinematics and derived momentum combinations.
42719 DO 110 I=4,5
42720 PP(I,1)=0D0
42721 PP(I,2)=0D0
42722 PP(I,3)=-0.5D0*SHPR*(-1)**I
42723 PP(I,4)=-0.5D0*SHPR
42724 110 CONTINUE
42725 DO 120 J=1,4
42726 PP(6,J)=PP(1,J)+PP(2,J)
42727 PP(7,J)=PP(1,J)+PP(3,J)
42728 PP(8,J)=PP(1,J)+PP(4,J)
42729 PP(9,J)=PP(1,J)+PP(5,J)
42730 PP(10,J)=-PP(2,J)-PP(3,J)
42731 PP(11,J)=-PP(2,J)-PP(4,J)
42732 PP(12,J)=-PP(2,J)-PP(5,J)
42733 PP(13,J)=-PP(4,J)-PP(5,J)
42734 120 CONTINUE
42735
42736C...Derived kinematics invariants.
42737 X1=DOT(1,2)
42738 X2=DOT(1,3)
42739 X3=DOT(1,4)
42740 X4=DOT(1,5)
42741 X5=DOT(2,3)
42742 X6=DOT(2,4)
42743 X7=DOT(2,5)
42744 X8=DOT(3,4)
42745 X9=DOT(3,5)
42746 X10=DOT(4,5)
42747
42748C...Propagators.
42749 SS1=DOT(7,7)-SPQ
42750 SS2=DOT(8,8)-SPQ
42751 SS3=DOT(9,9)-SPQ
42752 SS4=DOT(10,10)-SPQ
42753 SS5=DOT(11,11)-SPQ
42754 SS6=DOT(12,12)-SPQ
42755 SS7=DOT(13,13)
42756 DX(1)=SS1*SS6
42757 DX(2)=SS2*SS6
42758 DX(3)=SS2*SS4
42759 DX(4)=SS1*SS5
42760 DX(5)=SS3*SS5
42761 DX(6)=SS3*SS4
42762 DX(7)=SS7*SS1
42763 DX(8)=SS7*SS4
42764
42765C...Define colour coefficients for g + g -> Q + Qbar + H.
42766 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
42767 DO 140 I=1,3
42768 DO 130 J=1,3
42769 CLR(I,J)=16D0/3D0
42770 CLR(I+3,J+3)=16D0/3D0
42771 CLR(I,J+3)=-2D0/3D0
42772 CLR(I+3,J)=-2D0/3D0
42773 130 CONTINUE
42774 140 CONTINUE
42775 DO 160 L=1,2
42776 DO 150 I=1,3
42777 CLR(I,6+L)=-6D0
42778 CLR(I+3,6+L)=6D0
42779 CLR(6+L,I)=-6D0
42780 CLR(6+L,I+3)=6D0
42781 150 CONTINUE
42782 160 CONTINUE
42783 DO 180 K1=1,2
42784 DO 170 K2=1,2
42785 CLR(6+K1,6+K2)=12D0
42786 170 CONTINUE
42787 180 CONTINUE
42788
42789C...Evaluate matrix elements for g + g -> Q + Qbar + H.
42790 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
42791 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
42792 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
42793 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
42794 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
42795 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
42796 & X10)
42797 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
42798 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
42799 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42800 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
42801 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
42802 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
42803 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
42804 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
42805 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
42806 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
42807 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
42808 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
42809 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42810 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
42811 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
42812 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
42813 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
42814 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
42815 & X4*X6*X5)
42816 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
42817 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
42818 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
42819 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
42820 & +X4*X9*X5+X4*X5**2)
42821 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
42822 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
42823 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
42824 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
42825 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
42826 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
42827 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
42828 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
42829 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
42830 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
42831 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
42832 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
42833 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
42834 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
42835 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
42836 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
42837 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
42838 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
42839 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
42840 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
42841 & X6)
42842 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
42843 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
42844 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
42845 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
42846 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
42847 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
42848 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
42849 & X5+X4*X6*X5)
42850 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
42851 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
42852 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
42853 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
42854 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
42855 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
42856 & X6**2)
42857 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
42858 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
42859 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
42860 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
42861 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
42862 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
42863 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
42864 & X4*X6*X5)
42865 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42866 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42867 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
42868 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
42869 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
42870 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42871 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
42872 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
42873 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
42874 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
42875 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
42876 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
42877 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
42878 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
42879 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
42880 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
42881 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
42882 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
42883 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
42884 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
42885 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
42886 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
42887 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
42888 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
42889 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
42890 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
42891 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
42892 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
42893 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
42894 & +X3*X8*X5+X3*X5**2)
42895 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
42896 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
42897 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
42898 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
42899 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
42900 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
42901 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
42902 & X5+X4*X6*X5)
42903 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
42904 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
42905 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
42906 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
42907 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
42908 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
42909 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
42910 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
42911 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
42912 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
42913 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
42914 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
42915 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
42916 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
42917 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
42918 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
42919 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
42920 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
42921 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
42922 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
42923 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
42924 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
42925 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
42926 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
42927 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
42928 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
42929 & X10)
42930 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
42931 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
42932 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
42933 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
42934 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
42935 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
42936 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
42937 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
42938 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
42939 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
42940 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
42941 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
42942 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
42943 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
42944 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
42945 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
42946 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
42947 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
42948 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
42949 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
42950 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
42951 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
42952 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
42953 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
42954 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
42955 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
42956 & X7)
42957 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42958 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42959 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
42960 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
42961 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
42962 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
42963 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
42964 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
42965 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
42966 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
42967 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
42968 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
42969 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
42970 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
42971 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
42972 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
42973 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
42974 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
42975 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
42976 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
42977 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
42978 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
42979 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
42980 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
42981 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
42982 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
42983 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
42984 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
42985 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
42986 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
42987 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
42988 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
42989 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
42990 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
42991 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
42992 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
42993 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
42994 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
42995 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
42996 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
42997 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
42998 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
42999 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43000 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43001 & *X6)
43002 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43003 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43004 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43005 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43006 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43007 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43008 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43009 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43010 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43011 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43012 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43013 & X8)
43014 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43015 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43016 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43017 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43018 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43019 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43020 & X9*X5)
43021 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43022 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43023 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43024 & X8*X5)
43025 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43026 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43027 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43028 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43029
43030C...Repackage matrix elements.
43031 DO 200 I=1,8
43032 DO 190 J=I,8
43033 RM(I,J)=FM(I,J)
43034 190 CONTINUE
43035 200 CONTINUE
43036 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43037 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43038 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43039
43040C...Produce final result: matrix elements * colours * propagators.
43041 DO 220 I=1,8
43042 DO 210 J=I,8
43043 FAC=8D0
43044 IF(I.EQ.J)FAC=4D0
43045 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43046 210 CONTINUE
43047 220 CONTINUE
43048 WTQQBH=-WTQQBH/256D0
43049
43050 ELSE
43051C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43052 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43053 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43054 & *X6+X8*X7)
43055 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43056 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43057 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43058 & X5)
43059 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43060 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43061 & *X9+X4*X8)
43062
43063C...Produce final result: matrix elements * propagators.
43064 A11=A11/DX(7)**2
43065 A12=A12/(DX(7)*DX(8))
43066 A22=A22/DX(8)**2
43067 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43068 ENDIF
43069
43070 RETURN
43071 END
43072
43073C*********************************************************************
43074
43075C...PYSTBH (and auxiliaries)
43076C.. Evaluates the matrix elements for t + b + H production.
43077
43078 SUBROUTINE PYSTBH(WTTBH)
43079
43080C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43082 IMPLICIT INTEGER(I-N)
43083 INTEGER PYK,PYCHGE,PYCOMP
43084
43085C...COMMONBLOCKS
43086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43089 COMMON/PYINT1/MINT(400),VINT(400)
43090 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43091 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43092 COMMON/PYINT4/MWID(500),WIDS(500,5)
43093 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43094 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43095 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43096 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43097 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43098 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43099 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43100 DOUBLE PRECISION MW2
43101 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43102 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43103
43104C...LOCAL ARRAYS AND COMPLEX VARIABLES
43105 DIMENSION QQ(4,2),PP(4,3)
43106 DATA QQ/8*0D0/
43107
43108 WTTBH=0D0
43109
43110C...KINEMATIC PARAMETERS.
43111 SHPR=SQRT(VINT(26))*VINT(1)
43112 PH=SQRT(VINT(21))*VINT(1)
43113 SPH=PH**2
43114
43115C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43116 DO 100 I=1,2
43117 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43118 PP(1,I)=PT*COS(VINT(198+5*I))
43119 PP(2,I)=PT*SIN(VINT(198+5*I))
43120 100 CONTINUE
43121 PP(1,3)=-PP(1,1)-PP(1,2)
43122 PP(2,3)=-PP(2,1)-PP(2,2)
43123 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43124 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43125 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43126 PMT3=SQRT(PMS3)
43127 PP(3,3)=PMT3*SINH(VINT(211))
43128 PP(4,3)=PMT3*COSH(VINT(211))
43129 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43130 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43131 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43132 PP(3,2)=-PP(3,1)-PP(3,3)
43133 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43134 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43135
43136C...CM SYSTEM, INGOING QUARKS/GLUONS
43137 QQ(3,1) = SHPR/2.D0
43138 QQ(4,1) = QQ(3,1)
43139 QQ(3,2) = -QQ(3,1)
43140 QQ(4,2) = QQ(4,1)
43141
43142C...PARAMETERS FOR AMPLITUDE METHOD
43143 ALPHA = AEM
43144 ALPHAS = AS
43145 SW2 = PARU(102)
43146 MW2 = PMAS(24,1)**2
43147 TANB = PARU(141)
43148 VTB = VCKM(3,3)
43149 RMB=PYMRUN(5,VINT(52))
43150
43151 ISUB=MINT(1)
43152
43153 IF (ISUB.EQ.401) THEN
43154 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43155 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43156 ELSE IF (ISUB.EQ.402) THEN
43157 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43158 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43159 END IF
43160
43161 RETURN
43162 END
43163C------------------------------------------------------------------
43164 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43165C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43166 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43167 IMPLICIT INTEGER(I-N)
43168 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43169 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43170 SAVE /PYCTBH/
43171
43172C TOP WIDTH CALCULATION
43173C VTB = 0.99
43174 MW=DSQRT(MW2)
43175 XB=(MB/MT)**2
43176 XW=(MW/MT)**2
43177 XH =(MHP/MT)**2
43178 GAMTBH = 0D0
43179 IF (MT .LT. (MHP+MB)) THEN
43180C T ->B W ONLY
43181 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43182 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43183 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43184 GAMT = GAMTBW
43185 ELSE
43186C T ->BW +T ->B H^+
43187 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43188 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43189 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43190C
43191 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43192 & -4.D0*(MHP*MB/MT**2)**2 )
43193 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43194 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43195 GAMT = GAMTBW+GAMTBH
43196 ENDIF
43197C THUS BR IS
43198 BR=GAMTBH/GAMT
43199 RETURN
43200 END
43201
43202C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43203C GG->TBH^+, QQBAR->TBH^+
43204C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43205C (FOR INSTANCE WITH PYTHIA)
43206C------------------------------------------------------------
43207C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43208C PHYS REV. D 60 (1999) 115011
43209C (THESE FILES PREPARED BY J.-L. KNEUR)
43210C------------------------------------------------------------
43211C 1) GG->TBH^+
43212 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43213C
43214C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43215C
43216C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43217C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43218C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43219C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43220C "PHYSICAL PARAMETERS" INPUT:
43221C MT,MB TOP AND BOTTOM MASSES;
43222C MHP CHARGED HIGGS MASS
43223C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43224C
43225C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43226C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43227C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43228C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43229C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43230C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43231C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43232C
43233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43234 IMPLICIT INTEGER(I-N)
43235 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43236 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43238 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43239 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43240
43241 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43242 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43243C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43244C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43245C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43246C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
43247C (TAN BETA) VALUES
43248C
43249C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
43250C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
43251
43252 PI = 4*DATAN(1.D0)
43253 MW = DSQRT(MW2)
43254C
43255C COLLECTING THE RELEVANT OVERALL FACTORS:
43256C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
43257 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
43258C COUPLING CONSTANT (OVERALL NORMALIZATION)
43259 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
43260C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
43261C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
43262C ALPHAS IS ALPHA_STRONG;
43263C SW2 IS SIN(THETA_W)**2.
43264C
43265C VTB=.998D0
43266C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
43267C
43268 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
43269 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
43270C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
43271C
43272C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
43273C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
43274 DO 100 KK=1,4
43275 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
43276 100 CONTINUE
43277C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
43278 S = 2*PYTBHS(Q1,Q2)
43279 P1Q1=PYTBHS(Q1,P1)
43280 P1Q2=PYTBHS(P1,Q2)
43281 P2Q1=PYTBHS(P2,Q1)
43282 P2Q2=PYTBHS(P2,Q2)
43283 P1P2=PYTBHS(P1,P2)
43284C
43285C TOP WIDTH CALCULATION
43286 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
43287C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
43288C THEN DEFINE TOP (RESONANT) PROPAGATOR:
43289 A1INV= S -2*P1Q1 -2*P1Q2
43290 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
43291C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
43292C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
43293C THE TOP WIDTH
43294 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
43295 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
43296C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
43297C NOW COMES THE AMP**2:
43298C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
43299C THE EXPRESSIONS BELOW
43300 V18=0.D0
43301 A18=0.D0
43302 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
43303 &512*A1*A2*MB*MT/3-
43304 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43305 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
43306 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
43307 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43308 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
43309 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
43310 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
43311 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
43312 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43313 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43314 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
43315 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
43316 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43317 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43318 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
43319 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
43320 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
43321 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
43322 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43323 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
43324 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
43325 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43326 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43327 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43328 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
43329 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43330 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43331 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43332 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43333 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43334 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
43335 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43336 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43337 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
43338 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
43339 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43340 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
43341 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43342 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43343 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
43344 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
43345 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43346 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
43347 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43348 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43349 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43350 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43351 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
43352 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
43353 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43354 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
43355 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43356 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43357 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
43358 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43359 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43360 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
43361 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
43362 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
43363 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43364 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43365 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43366 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43367 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43368 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
43369 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43370 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43371 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43372 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
43373 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43374 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
43375 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43376 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43377 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
43378 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43379 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43380 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43381 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
43382 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43383 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43384 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43385 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43386 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43387 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43388 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
43389 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43390 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43391 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
43392 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43393 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43394 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43395 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43396 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43397 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43398 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
43399 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43400 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43401 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43402 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
43403 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
43404 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
43405 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
43406 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
43407 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
43408 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
43409 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
43410 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
43411 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
43412 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
43413 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
43414 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
43415 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
43416 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
43417 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
43418 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
43419 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
43420 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
43421 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
43422 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
43423 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
43424 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
43425 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
43426 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
43427 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
43428 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
43429 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
43430 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
43431 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
43432 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
43433 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
43434 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
43435 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
43436 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
43437 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
43438 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
43439 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
43440 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
43441 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
43442 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
43443 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
43444 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
43445 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
43446 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
43447 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
43448 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43449 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
43450 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
43451 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43452 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
43453 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
43454 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
43455 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
43456 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43457 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43458 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
43459 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
43460 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
43461 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
43462 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43463 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
43464 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
43465 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
43466 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
43467 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
43468 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43469 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
43470 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
43471 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
43472 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
43473 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
43474 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
43475 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
43476 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
43477 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
43478 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43479 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
43480 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
43481 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43482 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
43483 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
43484 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
43485 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
43486 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
43487 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
43488 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43489 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43490 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
43491 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
43492 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
43493 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
43494 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
43495 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
43496 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
43497 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
43498 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
43499 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
43500 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
43501 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
43502 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
43503 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
43504 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
43505 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
43506 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43507 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
43508 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
43509 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
43510 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
43511 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
43512 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
43513 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43514 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43515 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
43516 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
43517 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
43518 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
43519 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
43520 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
43521 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
43522 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
43523 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
43524 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
43525 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
43526 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
43527 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
43528 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
43529 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
43530 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
43531 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
43532 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
43533 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
43534 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
43535 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
43536 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
43537 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
43538 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
43539 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
43540 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
43541 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
43542 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
43543 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
43544 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
43545 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
43546 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
43547 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43548 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43549 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
43550 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
43551 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
43552 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
43553 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
43554 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
43555 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
43556 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
43557 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
43558 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
43559 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
43560 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
43561 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43562 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43563 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
43564 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
43565 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
43566 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
43567 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
43568 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
43569 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
43570 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
43571 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
43572 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
43573 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
43574 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
43575 &384*A12*MB*MT*P1Q1**2/S**2+
43576 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
43577 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
43578 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
43579 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
43580 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
43581 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
43582 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
43583 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
43584 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
43585 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
43586 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
43587 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
43588 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
43589 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
43590 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
43591 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
43592 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
43593 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
43594 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
43595 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
43596 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
43597 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
43598 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
43599 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
43600 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
43601 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
43602 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
43603 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
43604 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
43605 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
43606 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
43607 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
43608 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
43609 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
43610 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
43611 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
43612 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
43613 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
43614 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
43615 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
43616 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
43617 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
43618 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
43619 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
43620 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
43621 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
43622 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
43623 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
43624 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
43625 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
43626 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
43627 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
43628 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
43629 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
43630 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43631 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
43632 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
43633 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43634 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
43635 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
43636 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
43637 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
43638 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
43639 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
43640 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
43641 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
43642 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
43643 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
43644 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
43645 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
43646 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
43647 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
43648 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
43649 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
43650 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
43651 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
43652 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43653 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
43654 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
43655 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
43656 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
43657 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
43658 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
43659 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
43660 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
43661 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
43662 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
43663 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
43664 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
43665 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
43666 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
43667 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
43668 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
43669 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
43670 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
43671 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
43672 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
43673 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
43674 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43675 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
43676 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
43677 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
43678 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
43679 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
43680 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
43681 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
43682 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
43683 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
43684 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
43685 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
43686 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43687 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
43688 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
43689 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43690 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
43691 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
43692 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
43693 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43694 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
43695 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
43696 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
43697 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43698 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43699 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43700 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43701 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
43702 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
43703 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
43704 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
43705 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
43706 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
43707 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
43708 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
43709 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43710 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
43711 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
43712 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
43713 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
43714 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
43715 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
43716 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
43717 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
43718 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
43719 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
43720 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
43721 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
43722 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
43723 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
43724 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
43725 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
43726 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
43727 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
43728 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
43729 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
43730 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
43731 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
43732 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
43733 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
43734 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43735 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
43736 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
43737 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
43738 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
43739 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
43740 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
43741 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
43742 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43743 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
43744 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
43745 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
43746 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
43747 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43748 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
43749 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
43750 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
43751 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
43752
43753 V18BIS=
43754 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43755 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43756 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43757 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
43758 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
43759 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43760 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
43761 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
43762 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
43763 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
43764 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
43765 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
43766 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
43767 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
43768 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
43769 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
43770 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
43771 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
43772 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
43773 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43774 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
43775 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
43776 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
43777 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
43778 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
43779 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
43780 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
43781 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
43782 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
43783 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
43784 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
43785 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
43786 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
43787 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
43788 &272*A1*A2*P1Q1*S/(3*P1Q2)+
43789 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
43790 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
43791 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
43792 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
43793 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
43794 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
43795 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
43796 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
43797 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
43798 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
43799 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
43800 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
43801 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
43802 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
43803 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
43804 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
43805 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
43806 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
43807 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
43808 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
43809 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
43810 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
43811 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
43812 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
43813 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
43814 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
43815 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
43816 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
43817 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
43818 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
43819 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
43820 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
43821 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
43822 &32*A12*P2Q1*S/(3*P1Q1)-
43823 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
43824 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
43825 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
43826 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
43827 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
43828 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
43829 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
43830 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
43831 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
43832 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
43833 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
43834 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
43835 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
43836 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
43837 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
43838 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
43839 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
43840 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
43841 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
43842 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
43843 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
43844 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
43845 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
43846 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
43847 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
43848 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
43849 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
43850 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
43851 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43852 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
43853 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
43854 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
43855 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
43856 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
43857 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
43858 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
43859 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
43860 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
43861 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43862 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
43863 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
43864 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43865 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43866 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43867 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43868 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43869 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
43870 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
43871 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
43872 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
43873 &272*A1*A2*P2Q1*S/(3*P2Q2)-
43874 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
43875 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
43876 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
43877 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
43878 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
43879 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
43880 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
43881 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
43882 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
43883 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
43884 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
43885 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
43886 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
43887 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
43888 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
43889 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
43890 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
43891 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
43892 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
43893 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
43894 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
43895 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
43896 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
43897C
43898
43899 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
43900 &512*A1*A2*MB*MT/3+
43901 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
43902 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
43903 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
43904 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
43905 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
43906 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
43907 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
43908 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
43909 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
43910 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
43911 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
43912 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
43913 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
43914 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
43915 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
43916 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
43917 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
43918 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
43919 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
43920 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
43921 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
43922 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
43923 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
43924 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
43925 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
43926 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
43927 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
43928 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
43929 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
43930 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
43931 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
43932 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
43933 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
43934 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
43935 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
43936 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
43937 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
43938 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
43939 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
43940 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
43941 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
43942 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
43943 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
43944 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
43945 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
43946 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
43947 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
43948 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
43949 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
43950 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
43951 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
43952 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
43953 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43954 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
43955 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
43956 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
43957 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
43958 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
43959 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
43960 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
43961 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
43962 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
43963 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
43964 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
43965 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
43966 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
43967 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
43968 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
43969 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
43970 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
43971 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
43972 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
43973 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43974 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43975 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
43976 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
43977 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
43978 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
43979 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
43980 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
43981 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
43982 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
43983 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
43984 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
43985 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
43986 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
43987 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
43988 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
43989 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
43990 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43991 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
43992 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
43993 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
43994 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
43995 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
43996 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
43997 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
43998 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
43999 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44000 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44001 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44002 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44003 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44004 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44005 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44006 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44007 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44008 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44009 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44010 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44011 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44012 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44013 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44014 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44015 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44016 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44017 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44018 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44019 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44020 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44021 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44022 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44023 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44024 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44025 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44026 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44027 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44028 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44029 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44030 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44031 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44032 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44033 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44034 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44035 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44036 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44037 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44038 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44039 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44040 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44041 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44042 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44043 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44044 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44045 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44046 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44047 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44048 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44049 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44050 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44051 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44052 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44053 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44054 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44055 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44056 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44057 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44058 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44059 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44060 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44061 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44062 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44063 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44064 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44065 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44066 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44067 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44068 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44069 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44070 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44071 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44072 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44073 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44074 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44075 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44076 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44077 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44078 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44079 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44080 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44081 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44082 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44083 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44084 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44085 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44086 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44087 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44088 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44089 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44090 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44091 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44092 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44093 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44094 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44095 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44096 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44097 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44098 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44099 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44100 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44101 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44102 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44103 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44104 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44105 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44106 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44107 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44108 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44109 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44110 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44111 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44112 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44113 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44114 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44115 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44116 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44117 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44118 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44119 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44120 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44121 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44122 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44123 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44124 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44125 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44126 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44127 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44128 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44129 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44130 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44131 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44132 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44133 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44134 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44135 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44136 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44137 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44138 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44139 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44140 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44141 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44142 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44143 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44144 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44145 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44146 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44147 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44148 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44149 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44150 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44151 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44152 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44153 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44154 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44155 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44156 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44157 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44158 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44159 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44160 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44161 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44162 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44163 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44164 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44165 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44166 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44167 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44168 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44169 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44170 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44171 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44172 &384*A12*MB*MT*P1Q1**2/S**2+
44173 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44174 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44175 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44176 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44177 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44178 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44179 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44180 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44181 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44182 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44183 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44184 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44185 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44186 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44187 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44188 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44189 &384*A2**2*MB*MT*P2Q2**2/S**2+
44190 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44191 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44192 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44193 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44194 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44195 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44196 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44197 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44198 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44199 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44200 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44201 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44202 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44203 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44204 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44205 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44206 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44207 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44208 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44209 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44210 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44211 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44212 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44213 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44214 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44215 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44216 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44217 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44218 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44219 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44220 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44221 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44222 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44223 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44224 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44225 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44226 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44227 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44228 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44229 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44230 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44231 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44232 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44233 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44234 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44235 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44236 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44237 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44238 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44239 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44240 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44241 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44242 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44243 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44244 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44245 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44246 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
44247 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44248 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44249 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44250 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44251 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44252 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44253 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
44254 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44255 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
44256 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44257 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
44258 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44259 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44260 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
44261 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
44262 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44263 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44264 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44265 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44266 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
44267 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44268 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
44269 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44270 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
44271 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44272 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
44273 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44274 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
44275 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44276 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
44277 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
44278 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
44279 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44280 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
44281 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
44282 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44283 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44284 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44285 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44286 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
44287 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44288 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44289 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
44290 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
44291 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
44292 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44293 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44294 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44295 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44296 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44297 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44298 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44299 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44300 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44301 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
44302 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44303 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
44304 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44305 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44306 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
44307 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
44308 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44309 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
44310 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44311 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
44312 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
44313 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44314 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44315 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
44316 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44317 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44318 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
44319 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44320 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44321 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44322 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
44323 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
44324 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44325 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
44326 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44327 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44328 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44329 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44330 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44331 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44332 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
44333 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
44334 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
44335 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44336 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44337 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44338 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
44339 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44340 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
44341 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
44342 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44343 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44344 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44345 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44346 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44347 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44348 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44349 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44350 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44351 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44352 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44353 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
44354 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44355 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44356 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44357 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
44358 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44359 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44360 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
44361 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44362 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
44363 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
44364 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44365 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44366 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44367 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44368 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44369 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44370 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
44371 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
44372 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44373 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44374 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
44375 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
44376 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44377 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
44378 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
44379 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
44380 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
44381 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44382 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
44383
44384 A18BIS=
44385 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44386 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44387 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44388 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44389 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44390 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
44391 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44392 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44393 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
44394 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44395 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
44396 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
44397 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44398 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44399 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
44400 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
44401 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
44402 &12*S/(P1Q2*P2Q1)+
44403 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44404 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
44405 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44406 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
44407 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44408 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44409 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44410 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44411 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44412 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
44413 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44414 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
44415 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
44416 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44417 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
44418 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
44419 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
44420 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44421 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44422 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44423 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44424 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44425 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
44426 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44427 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44428 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
44429 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44430 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44431 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
44432 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
44433 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44434 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
44435 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44436 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44437 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
44438 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44439 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
44440 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44441 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
44442 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44443 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44444 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44445 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44446 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44447 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
44448 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
44449 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44450 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
44451 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
44452 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44453 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
44454 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44455 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44456 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44457 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44458 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44459 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44460 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44461 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44462 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44463 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44464 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
44465 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
44466 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
44467 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44468 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
44469 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44470 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44471 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44472 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44473 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44474 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44475 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44476 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
44477 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44478 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44479 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44480 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
44481 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
44482 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44483 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44484 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
44485 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
44486 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44487 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44488 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44489C
44490 V18=V18+V18BIS
44491 A18=A18+A18BIS
44492 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
44493 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
44494 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44495 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44496 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44497 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
44498 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44499 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44500 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44501 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44502 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44503 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44504 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
44505 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
44506 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
44507 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
44508 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
44509 V910=V910+96*A1*A2*P1P2*P2Q1/S-
44510 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44511 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
44512 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
44513 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44514 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44515C
44516 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
44517 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
44518 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44519 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44520 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
44521 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
44522 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44523 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
44524 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
44525 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
44526 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44527 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44528 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
44529 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
44530 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
44531 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
44532 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
44533 A910=A910+96*A1*A2*P1P2*P2Q1/S-
44534 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
44535 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
44536 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
44537 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
44538 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
44539C
44540C FINAL RESULT;
44541C
44542 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
44543
44544 END
44545C---------------------------------------------------------
44546C 2) Q QBAR ->TBH^+
44547 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
44548C
44549C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
44550C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
44551 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44552 IMPLICIT INTEGER(I-N)
44553 DOUBLE PRECISION MW2,MT,MB,MHP,MW
44554 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
44555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44557 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44558 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44559 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44560C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44561C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44562C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44563C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
44564C
44565C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44566C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44567C
44568 DIMENSION YY(2,2)
44569
44570 PI = 4*DATAN(1.D0)
44571 MW = DSQRT(MW2)
44572
44573C COLLECTING THE RELEVANT OVERALL FACTORS:
44574C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
44575 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
44576C COUPLING CONSTANT (OVERALL NORMALIZATION)
44577 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44578C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44579C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44580C ALPHAS IS ALPHA_STRONG;
44581C SW2 IS SIN(THETA_W)**2.
44582C
44583C VTB=.998D0
44584C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44585C
44586 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44587 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44588C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44589C
44590C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44591C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44592 DO 100 KK=1,4
44593 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44594 100 CONTINUE
44595C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44596 S = 2*PYTBHS(Q1,Q2)
44597 P1Q1=PYTBHS(Q1,P1)
44598 P1Q2=PYTBHS(P1,Q2)
44599 P2Q1=PYTBHS(P2,Q1)
44600 P2Q2=PYTBHS(P2,Q2)
44601 P1P2=PYTBHS(P1,P2)
44602C
44603C TOP WIDTH CALCULATION
44604 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44605C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44606C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44607 A1INV= S -2*P1Q1 -2*P1Q2
44608 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44609C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44610C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
44611 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44612 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44613C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44614C NOW COMES THE AMP**2:
44615C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
44616C THE EXPRESSIONS BELOW
44617 YY(1, 1) = -16*A**2*A2**2*MB*MT+
44618 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
44619 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
44620 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
44621 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
44622 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
44623 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
44624 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
44625 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
44626 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
44627 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
44628 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
44629 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
44630 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
44631 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44632 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44633 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
44634 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
44635 &32*A2**2*MB**2*P1P2*V**2/S+
44636 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
44637 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
44638 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
44639 YY(1, 1)=2*YY(1, 1)
44640
44641 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
44642 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
44643 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
44644 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
44645 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
44646 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
44647 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
44648 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
44649 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
44650 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
44651 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
44652 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44653 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
44654 &64*A**2*A1*A2*MB*MT*P1P2/S+
44655 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
44656 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
44657 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
44658 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
44659 &64*A**2*A1*A2*P1Q1*P2Q1/S-
44660 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
44661 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
44662 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
44663 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
44664 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
44665 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
44666 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
44667 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
44668 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
44669 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
44670 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
44671 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
44672 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
44673 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
44674 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
44675 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
44676 &32*A1*A2*P1P2*P1Q1*V**2/S+
44677 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
44678 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
44679 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
44680 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
44681
44682
44683 YY(2, 2) =-16*A**2*A12*MB*MT+
44684 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
44685 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
44686 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
44687 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
44688 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
44689 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
44690 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
44691 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
44692 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
44693 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
44694 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
44695 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
44696 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
44697 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
44698 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
44699 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
44700 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
44701 &32*A12*MT**2*P2Q2*V**2/S-
44702 &32*A12*P1Q2*P2Q2*V**2/S
44703 YY(2, 2)=2*YY(2, 2)
44704
44705 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
44706 AMP2= FACT*PS*VTB**2*RES
44707
44708 END
44709C=====================================================================
44710C ************* FUNCTION SCALAR PRODUCTS *************************
44711 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
44712 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44713 IMPLICIT INTEGER(I-N)
44714 DIMENSION A(4),B(4)
44715 DUM=A(4)*B(4)
44716 DO 100 ID=1,3
44717 DUM=DUM-A(ID)*B(ID)
44718 100 CONTINUE
44719 PYTBHS=DUM
44720 RETURN
44721 END
44722
44723C*********************************************************************
44724
44725C...PYMSIN
44726C...Initializes supersymmetry: finds sparticle masses and
44727C...branching ratios and stores this information.
44728C...AUTHOR: STEPHEN MRENNA
44729C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
44730
44731 SUBROUTINE PYMSIN
44732
44733C...Double precision and integer declarations.
44734 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
44735 IMPLICIT INTEGER(I-N)
44736 INTEGER PYK,PYCHGE,PYCOMP
44737C...Parameter statement to help give large particle numbers.
44738 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
44739 &KEXCIT=4000000,KDIMEN=5000000)
44740C...Commonblocks.
44741 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44742 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44743 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
44744 COMMON/PYDAT4/CHAF(500,2)
44745 CHARACTER CHAF*16
44746 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
44747 COMMON/PYINT4/MWID(500),WIDS(500,5)
44748 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44749 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
44750 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
44751 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
44752 COMMON/PYHTRI/HHH(7)
44753 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
44754 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
44755 &/PYMSSM/,/PYMSRV/,/PYSSMT/
44756
44757C...Local variables.
44758 DOUBLE PRECISION ALFA,BETA
44759 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
44760 INTEGER I,J,J1,I1,K1
44761 INTEGER KC,LKNT,IDLAM(400,3)
44762 DOUBLE PRECISION XLAM(0:400)
44763 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
44764 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
44765 DOUBLE PRECISION DELM,XMDIF
44766 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
44767 DOUBLE PRECISION ARG,SGNMU,R
44768 INTEGER IMSSM
44769 INTEGER IRPRTY
44770 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
44771 SAVE MWIDSU,MDCYSU
44772 DATA KFSUSY/
44773 &1000001,2000001,1000002,2000002,1000003,2000003,
44774 &1000004,2000004,1000005,2000005,1000006,2000006,
44775 &1000011,2000011,1000012,2000012,1000013,2000013,
44776 &1000014,2000014,1000015,2000015,1000016,2000016,
44777 &1000021,1000022,1000023,1000025,1000035,1000024,
44778 &1000037,1000039, 25, 35, 36, 37,
44779 & 6, 24, 45, 46,1000045, 9*0/
44780 DATA INIT/0/
44781
44782C...Automatically read QNUMBERS, MASS, and DECAY tables
44783 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
44784 NQNUM=0
44785 CALL PYSLHA(0,0,IFAIL)
44786 CALL PYSLHA(5,0,IFAIL)
44787 ENDIF
44788 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
44789
44790C...Do nothing further if SUSY not requested
44791 IMSSM=IMSS(1)
44792 IF(IMSSM.EQ.0) RETURN
44793
44794C...Save copy of MWID(KC) and MDCY(KC,1) values before
44795C...they are set to zero for the LSP.
44796 IF(INIT.EQ.0) THEN
44797 INIT=1
44798 DO 100 I=1,36
44799 KF=KFSUSY(I)
44800 KC=PYCOMP(KF)
44801 MWIDSU(I)=MWID(KC)
44802 MDCYSU(I)=MDCY(KC,1)
44803 100 CONTINUE
44804 ENDIF
44805
44806C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
44807 DO 110 I=1,36
44808 KF=KFSUSY(I)
44809 KC=PYCOMP(KF)
44810 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
44811 MWID(KC)=MWIDSU(I)
44812 MDCY(KC,1)=MDCYSU(I)
44813 ENDIF
44814 110 CONTINUE
44815
44816C...First part of routine: set masses and couplings.
44817
44818C...Reset mixing values in sfermion sector to pure left/right.
44819 DO 120 I=1,16
44820 SFMIX(I,1)=1D0
44821 SFMIX(I,4)=1D0
44822 SFMIX(I,2)=0D0
44823 SFMIX(I,3)=0D0
44824 120 CONTINUE
44825
44826C...Add NMSSM states if NMSSM switched on, and change old names.
44827 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
44828C... Switch on NMSSM
44829 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
44830
44831 KFN=25
44832 KCN=KFN
44833 CHAF(KCN,1)='h_10'
44834 CHAF(KCN,2)=' '
44835
44836 KFN=35
44837 KCN=KFN
44838 CHAF(KCN,1)='h_20'
44839 CHAF(KCN,2)=' '
44840
44841 KFN=45
44842 KCN=KFN
44843 CHAF(KCN,1)='h_30'
44844 CHAF(KCN,2)=' '
44845
44846 KFN=36
44847 KCN=KFN
44848 CHAF(KCN,1)='A_10'
44849 CHAF(KCN,2)=' '
44850
44851 KFN=46
44852 KCN=KFN
44853 CHAF(KCN,1)='A_20'
44854 CHAF(KCN,2)=' '
44855
44856 KFN=1000045
44857 KCN=PYCOMP(KFN)
44858 IF (KCN.EQ.0) THEN
44859 DO 123 KCT=100,MSTU(6)
44860 IF(KCHG(KCT,4).GT.100) KCN=KCT
44861 123 CONTINUE
44862 KCN=KCN+1
44863 KCHG(KCN,4)=KFN
44864 MSTU(20)=0
44865 ENDIF
44866C... Set stable for now
44867 PMAS(KCN,2)=1D-6
44868 MWID(KCN)=0
44869 MDCY(KCN,1)=0
44870 MDCY(KCN,2)=0
44871 MDCY(KCN,3)=0
44872 CHAF(KCN,1)='~chi_50'
44873 CHAF(KCN,2)=' '
44874 ENDIF
44875
44876C...Read spectrum from SLHA file.
44877 IF (IMSSM.EQ.11) THEN
44878 CALL PYSLHA(1,0,IFAIL)
44879 ENDIF
44880
44881C...Common couplings.
44882 TANB=RMSS(5)
44883 BETA=ATAN(TANB)
44884 COSB=COS(BETA)
44885 SINB=TANB*COSB
44886 COS2B=COS(2D0*BETA)
44887 ALFA=RMSS(18)
44888 XMW2=PMAS(24,1)**2
44889 XMZ2=PMAS(23,1)**2
44890 XW=PARU(102)
44891
44892C...Define sparticle masses for a general MSSM simulation.
44893 IF(IMSSM.EQ.1) THEN
44894 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
44895 DO 130 I=1,5,2
44896 KC=PYCOMP(KSUSY1+I)
44897 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
44898 KC=PYCOMP(KSUSY2+I)
44899 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
44900 KC=PYCOMP(KSUSY1+I+1)
44901 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
44902 KC=PYCOMP(KSUSY2+I+1)
44903 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
44904 130 CONTINUE
44905 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
44906 IF(XARG.LT.0D0) THEN
44907 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
44908 & ' FROM THE SUM RULE. '
44909 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
44910 RETURN
44911 ELSE
44912 XARG=SQRT(XARG)
44913 ENDIF
44914 DO 140 I=11,15,2
44915 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
44916 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
44917 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
44918 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
44919 140 CONTINUE
44920 IF(IMSS(8).EQ.1) THEN
44921 RMSS(13)=RMSS(6)
44922 RMSS(14)=RMSS(7)
44923 ENDIF
44924
44925C...Alternatively derive masses from SUGRA relations.
44926 ELSEIF(IMSSM.EQ.2) THEN
44927 RMSS(36)=RMSS(16)
44928 CALL PYAPPS
44929C...Or use ISASUSY
44930 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
44931 RMSS(36)=RMSS(16)
44932 CALL PYSUGI
44933 ALFA=RMSS(18)
44934 GOTO 170
44935 ELSE
44936 GOTO 170
44937 ENDIF
44938
44939C...Add in extra D-term contributions.
44940 IF(IMSS(7).EQ.1) THEN
44941 R=0.43D0
44942 DX=RMSS(23)
44943 DY=RMSS(24)
44944 DS=RMSS(25)
44945 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44946 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
44947 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
44948 WRITE(MSTU(11),*) 'C DX = ',DX
44949 WRITE(MSTU(11),*) 'C DY = ',DY
44950 WRITE(MSTU(11),*) 'C DS = ',DS
44951 WRITE(MSTU(11),*) 'C '
44952 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
44953 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
44954 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
44955 DQ2=DY/6D0-DX/3D0-DS/3D0
44956 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
44957 DD2=DY/3D0+DX-2D0*DS/3D0
44958 DL2=-DY/2D0+DX-2D0*DS/3D0
44959 DE2=DY-DX/3D0-DS/3D0
44960 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
44961 DHD2=-DY/2D0-2D0*DX/3D0+DS
44962 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
44963 & /ABS(COS2B)
44964 DMA2 = 2D0*DMU2+DHU2+DHD2
44965 DO 150 I=1,5,2
44966 KC=PYCOMP(KSUSY1+I)
44967 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44968 KC=PYCOMP(KSUSY2+I)
44969 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
44970 KC=PYCOMP(KSUSY1+I+1)
44971 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
44972 KC=PYCOMP(KSUSY2+I+1)
44973 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
44974 150 CONTINUE
44975 DO 160 I=11,15,2
44976 KC=PYCOMP(KSUSY1+I)
44977 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44978 KC=PYCOMP(KSUSY2+I)
44979 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
44980 KC=PYCOMP(KSUSY1+I+1)
44981 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
44982 160 CONTINUE
44983 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
44984 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
44985 CALL PYSTOP(104)
44986 ENDIF
44987 SGNMU=SIGN(1D0,RMSS(4))
44988 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
44989 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
44990 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
44991 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
44992 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
44993 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
44994 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
44995 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
44996 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
44997 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
44998 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
44999 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45000 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45001 CALL PYSTOP(104)
45002 ENDIF
45003 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45004 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45005 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45006 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45007 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45008 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45009 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45010 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45011 ENDIF
45012
45013C...Fix the third generation sfermions.
45014 CALL PYTHRG
45015
45016C...Fix the neutralino--chargino--gluino sector.
45017 CALL PYINOM
45018
45019C...Fix the Higgs sector.
45020 CALL PYHGGM(ALFA)
45021
45022C...Choose the Gunion-Haber convention.
45023 ALFA=-ALFA
45024 RMSS(18)=ALFA
45025
45026C...Print information on mass parameters.
45027 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45028 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45029 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45030 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45031 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45032 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45033 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45034 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45035 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45036 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45037 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45038 ENDIF
45039 IF(IMSS(20).EQ.1) THEN
45040 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45041 WRITE(MSTU(11),*) ' DEBUG MODE '
45042 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45043 & UMIX(2,1),UMIX(2,2)
45044 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45045 & UMIXI(2,1),UMIXI(2,2)
45046 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45047 & VMIX(2,1),VMIX(2,2)
45048 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45049 & VMIXI(2,1),VMIXI(2,2)
45050 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45051 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45052 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45053 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45054 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45055 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45056 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45057 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45058 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45059 WRITE(MSTU(11),*) ' BETA = ',BETA
45060 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45061 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45062 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45063 ENDIF
45064
45065C...Set up the Higgs couplings - needed here since initialization
45066C...in PYINRE did not yet occur when PYWIDT is called below.
45067 170 AL=ALFA
45068 BE=BETA
45069 SINA=SIN(AL)
45070 COSA=COS(AL)
45071 COSB=COS(BE)
45072 SINB=TANB*COSB
45073 SBMA=SIN(BE-AL)
45074 SAPB=SIN(AL+BE)
45075 CAPB=COS(AL+BE)
45076 CBMA=COS(BE-AL)
45077 C2A=COS(2D0*AL)
45078 C2B=COSB**2-SINB**2
45079C...tanb (used for H+)
45080 PARU(141)=TANB
45081
45082C...Firstly: h
45083C...Coupling to d-type quarks
45084 PARU(161)=SINA/COSB
45085C...Coupling to u-type quarks
45086 PARU(162)=-COSA/SINB
45087C...Coupling to leptons
45088 PARU(163)=PARU(161)
45089C...Coupling to Z
45090 PARU(164)=SBMA
45091C...Coupling to W
45092 PARU(165)=PARU(164)
45093
45094C...Secondly: H
45095C...Coupling to d-type quarks
45096 PARU(171)=-COSA/COSB
45097C...Coupling to u-type quarks
45098 PARU(172)=-SINA/SINB
45099C...Coupling to leptons
45100 PARU(173)=PARU(171)
45101C...Coupling to Z
45102 PARU(174)=CBMA
45103C...Coupling to W
45104 PARU(175)=PARU(174)
45105C...Coupling to h
45106 IF(IMSS(4).GE.2) THEN
45107 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45108 ELSE
45109 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45110 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45111 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45112 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45113 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45114 ENDIF
45115C...Coupling to H+
45116C...Define later
45117 IF(IMSS(4).GE.2) THEN
45118 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45119 ELSE
45120 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45121 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45122 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45123 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45124 ENDIF
45125C...Coupling to A
45126 IF(IMSS(4).GE.2) THEN
45127 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45128 ELSE
45129 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45130 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45131 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45132 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45133 ENDIF
45134C...Coupling to H+
45135 IF(IMSS(4).GE.2) THEN
45136 PARU(178)=PARU(177)
45137 ELSE
45138 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45139 ENDIF
45140C...Thirdly, A
45141C...Coupling to d-type quarks
45142 PARU(181)=TANB
45143C...Coupling to u-type quarks
45144 PARU(182)=1D0/PARU(181)
45145C...Coupling to leptons
45146 PARU(183)=PARU(181)
45147 PARU(184)=0D0
45148 PARU(185)=0D0
45149C...Coupling to Z h
45150 PARU(186)=COS(BE-AL)
45151C...Coupling to Z H
45152 PARU(187)=SIN(BE-AL)
45153 PARU(188)=0D0
45154 PARU(189)=0D0
45155 PARU(190)=0D0
45156
45157C...Finally: H+
45158C...Coupling to W h
45159 PARU(195)=COS(BE-AL)
45160
45161C...Tell that all Higgs couplings have been set.
45162 MSTP(4)=1
45163
45164C...Set R-Violating couplings.
45165C...Set lambda couplings to common value or "natural values".
45166 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45167 VIR3=1D0/(126D0)**3
45168 DO 200 IRK=1,3
45169 DO 190 IRI=1,3
45170 DO 180 IRJ=1,3
45171 IF (IRI.NE.IRJ) THEN
45172 IF (IRI.LT.IRJ) THEN
45173 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45174 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45175 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45176 & PMAS(9+2*IRK,1)*VIR3)
45177 ELSE
45178 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45179 ENDIF
45180 ELSE
45181 RVLAM(IRI,IRJ,IRK)=0D0
45182 ENDIF
45183 180 CONTINUE
45184 190 CONTINUE
45185 200 CONTINUE
45186 ENDIF
45187C...Set lambda' couplings to common value or "natural values".
45188 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45189 VIR3=1D0/(126D0)**3
45190 DO 230 IRI=1,3
45191 DO 220 IRJ=1,3
45192 DO 210 IRK=1,3
45193 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45194 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45195 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45196 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45197 210 CONTINUE
45198 220 CONTINUE
45199 230 CONTINUE
45200 ENDIF
45201C...Set lambda'' couplings to common value or "natural values".
45202 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45203 VIR3=1D0/(126D0)**3
45204 DO 260 IRI=1,3
45205 DO 250 IRJ=1,3
45206 DO 240 IRK=1,3
45207 IF (IRJ.NE.IRK) THEN
45208 IF (IRJ.LT.IRK) THEN
45209 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45210 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45211 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45212 & PMAS(2*IRK-1,1)*VIR3)
45213 ELSE
45214 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45215 ENDIF
45216 ELSE
45217 RVLAMB(IRI,IRJ,IRK) = 0D0
45218 ENDIF
45219 240 CONTINUE
45220 250 CONTINUE
45221 260 CONTINUE
45222 ENDIF
45223
45224C...Antisymmetrize couplings set by user
45225 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45226 DO 290 IRI=1,3
45227 DO 280 IRJ=1,3
45228 DO 270 IRK=1,3
45229 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45230 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45231 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45232 ENDIF
45233 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45234 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45235 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45236 ENDIF
45237 270 CONTINUE
45238 280 CONTINUE
45239 290 CONTINUE
45240 ENDIF
45241
45242C...Write spectrum to SLHA file
45243 IF (IMSS(23).NE.0) THEN
45244 IFAIL=0
45245 CALL PYSLHA(3,0,IFAIL)
45246 ENDIF
45247
45248C...Second part of routine: set decay modes and branching ratios.
45249
45250C...Allow chi10 -> gravitino + gamma or not.
45251 KC=PYCOMP(KSUSY1+39)
45252 IF( IMSS(11) .NE. 0 ) THEN
45253 PMAS(KC,1)=RMSS(21)/1D9
45254 PMAS(KC,2)=0D0
45255 IRPRTY=0
45256 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
45257 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
45258 IRPRTY=0
45259 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
45260 & ' ALLOWING SUSY LLE DECAYS'
45261 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
45262 & ' ALLOWING SUSY LQD DECAYS'
45263 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
45264 & ' ALLOWING SUSY UDD DECAYS'
45265 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
45266 & ' --- Warning: R-Violating couplings possibly',
45267 & ' incompatible with proton decay'
45268 ELSE
45269 PMAS(KC,1)=9999D0
45270 IRPRTY=1
45271 ENDIF
45272
45273C...Loop over sparticle and Higgs species.
45274 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
45275C...Find the LSP or NLSP for a gravitino LSP
45276 ILSP=0
45277 PMLSP=1D20
45278 DO 300 I=1,36
45279 KF=KFSUSY(I)
45280 IF(KF.EQ.1000039) GOTO 300
45281 KC=PYCOMP(KF)
45282 IF(PMAS(KC,1).LT.PMLSP) THEN
45283 ILSP=I
45284 PMLSP=PMAS(KC,1)
45285 ENDIF
45286 300 CONTINUE
45287 DO 370 I=1,50
45288 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
45289 KF=KFSUSY(I)
45290 IF (KF.EQ.0) GOTO 370
45291 KC=PYCOMP(KF)
45292 LKNT=0
45293
45294C...Check if there are any decays listed for this sparticle
45295C...in a file
45296 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
45297 IFAIL=0
45298 CALL PYSLHA(2,KF,IFAIL)
45299 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
45300 ELSEIF (I.GE.37) THEN
45301 GOTO 370
45302 ENDIF
45303
45304C...Sfermion decays.
45305 IF(I.LE.24) THEN
45306C...First check to see if sneutrino is lighter than chi10.
45307 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
45308 & PMAS(KC,1).LT.PMCHI1) THEN
45309 ELSE
45310 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
45311 ENDIF
45312
45313C...Gluino decays.
45314 ELSEIF(I.EQ.25) THEN
45315 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
45316 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
45317
45318C...Neutralino decays.
45319 ELSEIF(I.GE.26.AND.I.LE.29) THEN
45320 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
45321C...chi10 stable or chi10 -> gravitino + gamma.
45322 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
45323 PMAS(KC,2)=1D-6
45324 MDCY(KC,1)=0
45325 MWID(KC)=0
45326 ENDIF
45327
45328C...Chargino decays.
45329 ELSEIF(I.GE.30.AND.I.LE.31) THEN
45330 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
45331
45332C...Gravitino is stable.
45333 ELSEIF(I.EQ.32) THEN
45334 MDCY(KC,1)=0
45335 MWID(KC)=0
45336
45337C...Higgs decays.
45338 ELSEIF(I.GE.33.AND.I.LE.36) THEN
45339C...Calculate decays to non-SUSY particles.
45340 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
45341 LKNT=0
45342 DO 310 I1=0,100
45343 XLAM(I1)=0D0
45344 310 CONTINUE
45345 DO 330 I1=1,MDCY(KC,3)
45346 K1=MDCY(KC,2)+I1-1
45347 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
45348 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
45349 XLAM(I1)=WDTP(I1)
45350 XLAM(0)=XLAM(0)+XLAM(I1)
45351 DO 320 J1=1,3
45352 IDLAM(I1,J1)=KFDP(K1,J1)
45353 320 CONTINUE
45354 LKNT=LKNT+1
45355 330 CONTINUE
45356C...Add the decays to SUSY particles.
45357 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
45358 ENDIF
45359C...Zero the branching ratios for use in loop mode
45360C...thanks to K. Matchev (FNAL)
45361 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
45362 BRAT(IDC)=0D0
45363 340 CONTINUE
45364
45365C...Set stable particles.
45366 IF(LKNT.EQ.0) THEN
45367 MDCY(KC,1)=0
45368 MWID(KC)=0
45369 PMAS(KC,2)=1D-6
45370 PMAS(KC,3)=1D-5
45371 PMAS(KC,4)=0D0
45372
45373C...Store branching ratios in the standard tables.
45374 ELSE
45375 IDC=MDCY(KC,2)+MDCY(KC,3)-1
45376 DELM=1D6
45377 DO 360 IL=1,LKNT
45378 IDCSV=IDC
45379 350 IDC=IDC+1
45380 BRAT(IDC)=0D0
45381 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
45382 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
45383 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
45384 BRAT(IDC)=XLAM(IL)/XLAM(0)
45385 XMDIF=PMAS(KC,1)
45386 IF(MDME(IDC,1).GE.1) THEN
45387 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
45388 & PMAS(PYCOMP(KFDP(IDC,2)),1)
45389 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
45390 & PMAS(PYCOMP(KFDP(IDC,3)),1)
45391 ENDIF
45392 IF(I.LE.32) THEN
45393 IF(XMDIF.GE.0D0) THEN
45394 DELM=MIN(DELM,XMDIF)
45395 ELSE
45396 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
45397 WRITE(MSTU(11),*) ' KF = ',KF
45398 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
45399 ENDIF
45400 ENDIF
45401 GOTO 360
45402 ELSEIF(IDC.EQ.IDCSV) THEN
45403 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
45404 & 'channel not recognized:'
45405 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
45406 GOTO 360
45407 ELSE
45408 GOTO 350
45409 ENDIF
45410 360 CONTINUE
45411
45412C...Store width, cutoff and lifetime.
45413 PMAS(KC,2)=XLAM(0)
45414 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
45415 PMAS(KC,3)=PMAS(KC,2)*10D0
45416 ELSE
45417 PMAS(KC,3)=0.95D0*DELM
45418 ENDIF
45419 IF(PMAS(KC,2).NE.0D0) THEN
45420 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
45421 ENDIF
45422C...Write decays to SLHA file
45423 IF (IMSS(24).NE.0) THEN
45424 IFAIL=0
45425 CALL PYSLHA(4,KF,IFAIL)
45426 ENDIF
45427
45428 ENDIF
45429 370 CONTINUE
45430
45431 RETURN
45432 END
45433C*********************************************************************
45434
45435C...PYSLHA
45436C...Read/write spectrum or decay data from SLHA standard file(s).
45437C...P. Skands
45438
45439C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
45440C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
45441C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
45442C... (KFORIG=0 : read all decay tables)
45443C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
45444C...(MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24))
45445C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
45446C... (KFORIG=0 : read all MASS entries)
45447
45448 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
45449
45450C...Double precision and integer declarations.
45451 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45452 IMPLICIT INTEGER(I-N)
45453 INTEGER PYK,PYCHGE,PYCOMP
45454 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45455 &KEXCIT=4000000,KDIMEN=5000000)
45456C...Commonblocks.
45457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45458 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45459 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45460 COMMON/PYDAT4/CHAF(500,2)
45461 CHARACTER CHAF*16
45462 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45463 CHARACTER*40 ISAVER,VISAJE
45464 COMMON/PYINT4/MWID(500),WIDS(500,5)
45465 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
45466C...SUSY blocks
45467 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45468 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45469 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45470 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45471 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
45472
45473C...Local arrays, character variables and data.
45474 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
45475 & AU(3,3),AD(3,3),AE(3,3)
45476 COMMON/PYLH3C/CPRO(2),CVER(2)
45477C...The common block of new states (QNUMBERS / PARTICLE)
45478 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45479C...- NQNUM : Number of QNUMBERS blocks that have been read in
45480C...- KQNUM(I,0) : KF of new state
45481C...- KQNUM(I,1) : 3 times electric charge
45482C...- KQNUM(I,2) : Number of spin states: (2S + 1)
45483C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
45484C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
45485C...- KQNUM(I,5:9) : space available for further quantum numbers
45486 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
45487 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
45488C...MMOD: flags to set for each block read in.
45489C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
45490C...MSPC: Flags to set for each block read in.
45491C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
45492C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
45493C...11: AD 12: AE 13: YU 14: YD 15: YE
45494C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
45495 CHARACTER CPRO*12,CVER*12,CHNLIN*6
45496 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
45497 CHARACTER CHINL*120,CHKF*9,CHTMP*16
45498 INTEGER VERBOS
45499 SAVE VERBOS
45500C...Date of last Change
45501 PARAMETER (DOC='13 Jul 2009')
45502C...Local arrays and initial values
45503 DIMENSION IDC(5),KFSUSY(50)
45504 SAVE KFSUSY
45505 DATA NQNUM /0/
45506 DATA NDECAY /0/
45507 DATA VERBOS /1/
45508 DATA NHELLO /0/
45509 DATA MLHEF /0/
45510 DATA MLHEFD /0/
45511 DATA KFSUSY/
45512 &1000001,1000002,1000003,1000004,1000005,1000006,
45513 &2000001,2000002,2000003,2000004,2000005,2000006,
45514 &1000011,1000012,1000013,1000014,1000015,1000016,
45515 &2000011,2000012,2000013,2000014,2000015,2000016,
45516 &1000021,1000022,1000023,1000025,1000035,1000024,
45517 &1000037,1000039, 25, 35, 36, 37,
45518 & 6, 24, 45, 46,1000045, 9*0/
45519 DATA KFDEC/100*0/
45520 RMFUN(IP)=PMAS(PYCOMP(IP),1)
45521
45522C...Shorthand for spectrum and decay table unit numbers
45523 IMSS21=IMSS(21)
45524 IMSS22=IMSS(22)
45525
45526C...Default for LHEF input: read header information
45527 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
45528 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
45529 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
45530 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
45531
45532C...Hello World
45533 IF (NHELLO.EQ.0) THEN
45534 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
45535 WRITE(MSTU(11),5000) DOC
45536 NHELLO=1
45537 ENDIF
45538 ENDIF
45539
45540C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
45541C...+MUPDA).
45542 LFN=IMSS21
45543 IF (MUPDA.EQ.2) LFN=IMSS22
45544 IF (MUPDA.EQ.3) LFN=IMSS(23)
45545 IF (MUPDA.EQ.4) LFN=IMSS(24)
45546C...Flag that we have not yet found whatever we were asked to find.
45547 IRETRN=1
45548C...Flag that we are skipping until <slha> tag found (if LHEF)
45549 ISKIP=0
45550 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
45551
45552C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
45553 IF (LFN.EQ.0) THEN
45554 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
45555 GOTO 9999
45556 ENDIF
45557
45558C...If reading LHEF header, start by rewinding file
45559 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
45560
45561C...If told to read spectrum, first zero all previous information.
45562 IF (MUPDA.EQ.1) THEN
45563C...Zero all block read flags
45564 DO 100 M=1,100
45565 MMOD(M)=0
45566 MSPC(M)=0
45567 100 CONTINUE
45568C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
45569 DO 110 ISUSY=1,36
45570 KC=PYCOMP(KFSUSY(ISUSY))
45571 PMAS(KC,1)=0D0
45572 110 CONTINUE
45573C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
45574 DO 130 J=1,4
45575 SFMIX(5,J) =0D0
45576 SFMIX(6,J) =0D0
45577 SFMIX(15,J)=0D0
45578 DO 120 L=1,4
45579 ZMIX(L,J) =0D0
45580 ZMIXI(L,J)=0D0
45581 IF (J.LE.2.AND.L.LE.2) THEN
45582 UMIX(L,J) =0D0
45583 UMIXI(L,J)=0D0
45584 VMIX(L,J) =0D0
45585 VMIXI(L,J)=0D0
45586 ENDIF
45587 120 CONTINUE
45588C...Zero signed masses.
45589 SMZ(J)=0D0
45590 IF (J.LE.2) SMW(J)=0D0
45591 130 CONTINUE
45592
45593C...If reading decays, reset PYTHIA decay counters.
45594 ELSEIF (MUPDA.EQ.2) THEN
45595C...Check if DECAY for this KF already read
45596 IF (KFORIG.NE.0) THEN
45597 DO 140 IDEC=1,NDECAY
45598 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
45599 IRETRN=0
45600 RETURN
45601 ENDIF
45602 140 CONTINUE
45603 ENDIF
45604 KCC=100
45605 NDC=0
45606 BRSUM=0D0
45607 DO 150 KC=1,MSTU(6)
45608 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
45609 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
45610 150 CONTINUE
45611 ELSEIF (MUPDA.EQ.5) THEN
45612C...Zero block read flags
45613 DO 160 M=1,100
45614 MSPC(M)=0
45615 160 CONTINUE
45616 ENDIF
45617
45618C............READ
45619C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
45620 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
45621C...Initialize program and version strings
45622 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
45623 CPRO(MUPDA)=' '
45624 CVER(MUPDA)=' '
45625 ENDIF
45626
45627C...Initialize read loop
45628 MERR=0
45629 NLINE=0
45630 CHBLCK=' '
45631C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
45632 170 CHINL=' '
45633 READ(LFN,'(A120)',END=400) CHINL
45634C...Count which line number we're at.
45635 NLINE=NLINE+1
45636 WRITE(CHNLIN,'(I6)') NLINE
45637
45638C...Skip comment and empty lines without processing.
45639 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
45640
45641C...We assume all upper case below. Rewrite CHINL to all upper case.
45642 INL=0
45643 IGOOD=0
45644 180 INL=INL+1
45645 IF (CHINL(INL:INL).NE.'#') THEN
45646 DO 190 ICH=97,122
45647 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
45648 190 CONTINUE
45649C...Extra safety. Chek for sensible input on line
45650 IF (IGOOD.EQ.0) THEN
45651 DO 200 ICH=48,90
45652 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
45653 200 CONTINUE
45654 ENDIF
45655 IF (INL.LT.120) GOTO 180
45656 ENDIF
45657 IF (IGOOD.EQ.0) GOTO 170
45658
45659C...If reading from LHEF file, skip until <slha> begin tag found
45660 IF (ISKIP.NE.0) THEN
45661 DO 205 I1=1,10
45662 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
45663 205 CONTINUE
45664 IF (ISKIP.NE.0) GOTO 170
45665 ENDIF
45666
45667C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
45668 DO 210 I1=1,10
45669 IF (CHINL(I1:I1+5).EQ.'</SLHA'
45670 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
45671 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
45672 REWIND(LFN)
45673 GOTO 400
45674 ENDIF
45675 210 CONTINUE
45676
45677C...Check for BLOCK begin statement (spectrum).
45678 IF (CHINL(1:5).EQ.'BLOCK') THEN
45679 MERR=0
45680 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
45681C...Check if another of this type of block was already read.
45682C...(logarithmic interpolation not yet implemented, so duplicates always
45683C...give errors)
45684 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
45685 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
45686 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
45687 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
45688 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
45689 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
45690 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
45691 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
45692 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
45693 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
45694 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
45695 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
45696 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
45697 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
45698 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
45699 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
45700 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
45701C...Check for new particles
45702 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45703 & THEN
45704 MSPC(19)=MSPC(19)+1
45705C...Read PDG code
45706 READ(CHBLCK(9:60),*) KFQ
45707
45708 DO 220 MQ=1,NQNUM
45709 IF (KQNUM(MQ,0).EQ.KFQ) THEN
45710 MERR=17
45711 GOTO 380
45712 ENDIF
45713 220 CONTINUE
45714 IF (NHELLO.EQ.0) THEN
45715 WRITE(MSTU(11),5000) DOC
45716 NHELLO=1
45717 ENDIF
45718 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45719 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
45720 & ' for KF =',KFQ
45721 NQNUM=NQNUM+1
45722 KQNUM(NQNUM,0)=KFQ
45723 MSPC(19)=MSPC(19)+1
45724 KCQ=PYCOMP(KFQ)
45725C...Only read in new codes (also OK to overwrite if KF > 3000000)
45726 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
45727 IF (KCQ.EQ.0) THEN
45728 DO 230 KCT=100,MSTU(6)
45729 IF(KCHG(KCT,4).GT.100) KCQ=KCT
45730 230 CONTINUE
45731 KCQ=KCQ+1
45732 ENDIF
45733 KCC=KCQ
45734 KCHG(KCQ,4)=KFQ
45735C...First write PDG code as name
45736 WRITE(CHTMP,*) KFQ
45737 WRITE(CHTMP,'(A)') CHTMP(2:10)
45738C...Then look for real name
45739 IBEG=9
45740 240 IBEG=IBEG+1
45741 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
45742 250 IBEG=IBEG+1
45743 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
45744 IEND=IBEG-1
45745 260 IEND=IEND+1
45746 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
45747 IF (IEND.LT.59) THEN
45748 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
45749 IF (CHDUM.NE.' ') CHTMP=CHDUM
45750 ENDIF
45751 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
45752 MSTU(20)=0
45753C...Set stable for now
45754 PMAS(KCQ,2)=1D-6
45755 MWID(KCQ)=0
45756 MDCY(KCQ,1)=0
45757 MDCY(KCQ,2)=0
45758 MDCY(KCQ,3)=0
45759 ELSE
45760 WRITE(MSTU(11),*)
45761 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
45762 & CHAF(KCQ,1), '. Entry ignored.'
45763 MERR=7
45764 ENDIF
45765 ENDIF
45766C...Finalize this line and read next.
45767 GOTO 380
45768C...Check for DECAY begin statement (decays).
45769 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
45770 MERR=0
45771 BRSUM=0D0
45772 CHBLCK='DECAY'
45773C...Read KF code and WIDTH
45774 MPSIGN=1
45775 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
45776 IF (KF.LE.0) THEN
45777 KF=-KF
45778 MPSIGN=-1
45779 ENDIF
45780C...If this is not the KF we're looking for...
45781 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
45782C...Set block skip flag and read next line.
45783 MERR=16
45784 GOTO 380
45785 ELSE
45786C...Check whether decay table for this particle already read in
45787 DO 280 IDECAY=1,NDECAY
45788 IF (KFDEC(IDECAY).EQ.KF) THEN
45789 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
45790 & ' * (PYSLHA:) Ignoring DECAY table ',
45791 & 'for KF =',KF,' on line ',CHNLIN,
45792 & ' (duplicate)'
45793 MERR=16
45794 GOTO 380
45795 ENDIF
45796 280 CONTINUE
45797 ENDIF
45798
45799C...Determine PYTHIA KC code of particle
45800 KCREP=0
45801 IF(KF.LE.100) THEN
45802 KCREP=KF
45803 ELSE
45804 DO 290 KCR=101,KCC
45805 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
45806 290 CONTINUE
45807 ENDIF
45808 KC=KCREP
45809 IF (KCREP.NE.0) THEN
45810C...Particle is already known. Do not overwrite low-mass SM particles,
45811C...since this could give problems at hadronization / hadron decay stage.
45812 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
45813C...Set block skip flag and read next line
45814 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45815 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
45816 & KF, ' (SLHA read-in not allowed)'
45817 MERR=16
45818 GOTO 380
45819 ENDIF
45820 ELSE
45821C... Add new particle. Actually, this should not happen.
45822C... New particles should be added already when reading the spectrum
45823C... information, so go under previously stable category.
45824 KCC=KCC+1
45825 KC=KCC
45826 ENDIF
45827
45828 IF (WIDTH.LE.0D0) THEN
45829C...Stable (i.e. LSP)
45830 WRITE(MSTU(11),'(A,I9,A,A)')
45831 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
45832 & KF,', ',CHAF(KCREP,1)(1:16)
45833 IF (WIDTH.LT.0D0) THEN
45834 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
45835 & ' zero !')
45836 WIDTH=0D0
45837 ENDIF
45838 PMAS(KC,2)=1D-6
45839 MWID(KC)=0
45840 MDCY(KC,1)=0
45841C...Ignore any decay lines that may be present for this KF
45842 MERR=16
45843 MDCY(KC,2)=0
45844 MDCY(KC,3)=0
45845C...Return ok
45846 IRETRN=0
45847 ENDIF
45848C...Finalize and start reading in decay modes.
45849 GOTO 380
45850 ELSEIF (MOD(MERR,10).GE.6) THEN
45851C...If ignore block flag set, skip directly to next line.
45852 GOTO 170
45853 ENDIF
45854
45855C...READ SPECTRUM
45856 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
45857 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
45858 & THEN
45859 READ(CHINL,*) INDX, IVAL
45860 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
45861 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
45862 IF (INDX.EQ.3) KCHG(KCQ,2)=0
45863 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
45864 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
45865 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
45866 IF (INDX.EQ.4) THEN
45867 KCHG(KCQ,3)=IVAL
45868 IF (IVAL.EQ.1) THEN
45869 CHTMP=CHAF(KCQ,1)
45870 IF (CHTMP.EQ.' ') THEN
45871 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
45872 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
45873 ELSE
45874 ILAST=17
45875 300 ILAST=ILAST-1
45876 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
45877 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
45878 CHTMP(ILAST:ILAST)='-'
45879 ELSE
45880 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
45881 ENDIF
45882 CHAF(KCQ,2)=CHTMP
45883 ENDIF
45884 ENDIF
45885 ENDIF
45886 ELSE
45887 MERR=8
45888 ENDIF
45889 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
45890C...MASS: Mass spectrum
45891 IF (CHBLCK(1:4).EQ.'MASS') THEN
45892 READ(CHINL,*) KF, VAL
45893 MERR=1
45894 KC=0
45895 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
45896C...Read in masses for almost anything
45897 MERR=0
45898 KC=PYCOMP(KF)
45899 IF (KC.NE.0) THEN
45900C...Don't read in masses for special code particles
45901 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
45902 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45903 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45904 & KF, ' (KF reserved by PYTHIA)'
45905 GOTO 170
45906 ENDIF
45907C...Be careful with light SM particles / hadrons
45908 IF (PMAS(KC,1).LE.20D0) THEN
45909 IF (IABS(KF).LE.22) THEN
45910 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45911 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45912 & KF, ' (SLHA read-in not allowed)'
45913
45914 GOTO 170
45915 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
45916 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45917 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
45918 & KF, ' (SLHA read-in not allowed)'
45919 GOTO 170
45920 ENDIF
45921 ENDIF
45922 MSPC(1)=MSPC(1)+1
45923 PMAS(KC,1) = ABS(VAL)
45924 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
45925 WRITE(MSTU(11),'(A,I9,A,F12.3)')
45926 & ' * (PYSLHA:) Reading MASS entry for KF =',
45927 & KF, ', pole mass =', VAL
45928 IRETRN=0
45929 ENDIF
45930C...Check Z, W and top masses
45931 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
45932 & THEN
45933 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45934 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
45935 & //CHTMP)
45936 ENDIF
45937 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
45938 & THEN
45939 WRITE(CHTMP,*) PMAS(PYCOMP(23),1)
45940 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
45941 & //CHTMP)
45942 ENDIF
45943 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
45944 & THEN
45945 WRITE(CHTMP,*) PMAS(PYCOMP(6),1)
45946 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
45947 & //CHTMP//'GeV')
45948 ENDIF
45949C... Signed masses
45950 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
45951 IF (KF.EQ.1000022) SMZ(1)=VAL
45952 IF (KF.EQ.1000023) SMZ(2)=VAL
45953 IF (KF.EQ.1000025) SMZ(3)=VAL
45954 IF (KF.EQ.1000035) SMZ(4)=VAL
45955 IF (KF.EQ.1000024) SMW(1)=VAL
45956 IF (KF.EQ.1000037) SMW(2)=VAL
45957 ENDIF
45958 ELSEIF (MUPDA.EQ.5) THEN
45959 MERR=0
45960 ENDIF
45961C... MODSEL: Model selection and global switches
45962 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
45963 READ(CHINL,*) INDX, IVAL
45964 IF (INDX.LE.200.AND.INDX.GT.0) THEN
45965 IF (IMSS(1).EQ.0) IMSS(1)=11
45966 MODSEL(INDX)=IVAL
45967 MMOD(1)=MMOD(1)+1
45968 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
45969C... Switch on NMSSM
45970 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
45971 IMSS(13)=MAX(1,IMSS(13))
45972C... Add NMSSM states if not already done
45973
45974 KFN=25
45975 KCN=KFN
45976 CHAF(KCN,1)='h_10'
45977 CHAF(KCN,2)=' '
45978
45979 KFN=35
45980 KCN=KFN
45981 CHAF(KCN,1)='h_20'
45982 CHAF(KCN,2)=' '
45983
45984 KFN=45
45985 KCN=KFN
45986 CHAF(KCN,1)='h_30'
45987 CHAF(KCN,2)=' '
45988
45989 KFN=36
45990 KCN=KFN
45991 CHAF(KCN,1)='A_10'
45992 CHAF(KCN,2)=' '
45993
45994 KFN=46
45995 KCN=KFN
45996 CHAF(KCN,1)='A_20'
45997 CHAF(KCN,2)=' '
45998
45999 KFN=1000045
46000 KCN=PYCOMP(KFN)
46001 IF (KCN.EQ.0) THEN
46002 DO 310 KCT=100,MSTU(6)
46003 IF(KCHG(KCT,4).GT.100) KCN=KCT
46004 310 CONTINUE
46005 KCN=KCN+1
46006 KCHG(KCN,4)=KFN
46007 MSTU(20)=0
46008 ENDIF
46009C... Set stable for now
46010 PMAS(KCN,2)=1D-6
46011 MWID(KCN)=0
46012 MDCY(KCN,1)=0
46013 MDCY(KCN,2)=0
46014 MDCY(KCN,3)=0
46015 CHAF(KCN,1)='~chi_50'
46016 CHAF(KCN,2)=' '
46017 ENDIF
46018 ELSE
46019 MERR=1
46020 ENDIF
46021 ELSEIF (MUPDA.EQ.5) THEN
46022C...If MUPDA = 5, skip all except MASS, return if MODSEL
46023 MERR=8
46024 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46025 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46026C...Don't print a warning for QNUMBERS when reading spectrum
46027 MERR=8
46028C...MINPAR: Minimal model parameters
46029 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46030 READ(CHINL,*) INDX, VAL
46031 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46032 PARMIN(INDX)=VAL
46033 MMOD(2)=MMOD(2)+1
46034 ELSE
46035 MERR=1
46036 ENDIF
46037 IF (MMOD(3).NE.0) THEN
46038 WRITE(MSTU(11),*)
46039 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46040 MERR=1
46041 ENDIF
46042C...tan(beta)
46043 IF (INDX.EQ.3) RMSS(5)=VAL
46044C...EXTPAR: non-minimal model parameters.
46045 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46046 IF (MMOD(1).NE.0) THEN
46047 READ(CHINL,*) INDX, VAL
46048 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46049 PAREXT(INDX)=VAL
46050 MMOD(3)=MMOD(3)+1
46051 ELSE
46052 MERR=1
46053 ENDIF
46054 ELSE
46055 WRITE(MSTU(11),*)
46056 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46057 MERR=1
46058 ENDIF
46059C...tan(beta)
46060 IF (INDX.EQ.25) RMSS(5)=VAL
46061 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46062 READ(CHINL,*) INDX, VAL
46063 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46064 MERR=1
46065 ELSEIF (INDX.EQ.4) THEN
46066 PMAS(PYCOMP(23),1)=VAL
46067 ELSEIF (INDX.EQ.6) THEN
46068 PMAS(PYCOMP(6),1)=VAL
46069 ENDIF
46070 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46071 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46072 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46073 $ THEN
46074C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46075 IM=0
46076 IF (CHBLCK(5:6).EQ.'IM') IM=1
46077 320 READ(CHINL,*) INDX1, INDX2, VAL
46078 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46079 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46080 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46081 MSPC(2)=MSPC(2)+1
46082 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46083 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46084 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46085 MSPC(3)=MSPC(3)+1
46086 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46087 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46088 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46089 MSPC(4)=MSPC(4)+1
46090 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46091 $ .CHBLCK(1:4).EQ.'STAU') THEN
46092 IF (CHBLCK(1:4).EQ.'STOP') THEN
46093 KFSM=6
46094 ISPC=6
46095 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46096 KFSM=5
46097 ISPC=5
46098 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46099 KFSM=15
46100 ISPC=7
46101 ENDIF
46102C...Set SFMIX element
46103 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46104 MSPC(ISPC)=MSPC(ISPC)+1
46105 ENDIF
46106C...Running parameters
46107 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46108 READ(CHBLCK(8:25),*,ERR=620) Q
46109 READ(CHINL,*) INDX, VAL
46110 MSPC(8)=MSPC(8)+1
46111 IF (INDX.EQ.1) THEN
46112 RMSS(4) = VAL
46113 ELSE
46114 MERR=1
46115 MSPC(8)=MSPC(8)-1
46116 ENDIF
46117 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46118 READ(CHINL,*,ERR=630) VAL
46119 RMSS(18)= VAL
46120 MSPC(17)=MSPC(17)+1
46121C...Higgs parameters set manually or with FeynHiggs.
46122 IMSS(4)=MAX(2,IMSS(4))
46123 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46124 & .CHBLCK(1:2).EQ.'AE') THEN
46125 READ(CHBLCK(9:26),*,ERR=620) Q
46126 READ(CHINL,*) INDX1, INDX2, VAL
46127 IF (CHBLCK(2:2).EQ.'U') THEN
46128 AU(INDX1,INDX2)=VAL
46129 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46130 MSPC(11)=MSPC(11)+1
46131 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46132 AD(INDX1,INDX2)=VAL
46133 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46134 MSPC(10)=MSPC(10)+1
46135 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46136 AE(INDX1,INDX2)=VAL
46137 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46138 MSPC(12)=MSPC(12)+1
46139 ELSE
46140 MERR=1
46141 ENDIF
46142 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46143 IF (MSPC(18).EQ.0) THEN
46144 READ(CHBLCK(9:25),*,ERR=620) Q
46145 RMSOFT(0)=Q
46146 ENDIF
46147 READ(CHINL,*) INDX, VAL
46148 RMSOFT(INDX)=VAL
46149 MSPC(18)=MSPC(18)+1
46150 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46151 MERR=8
46152 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46153 & .CHBLCK(1:2).EQ.'YE') THEN
46154 MERR=8
46155 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46156 READ(CHINL(1:6),*) INDX
46157 IT=0
46158 MIRD=0
46159 330 IT=IT+1
46160 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46161C...Don't read index
46162 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46163 MIRD=1
46164 GOTO 330
46165 ENDIF
46166 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46167 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46168 ELSE
46169C... Set unrecognized block flag.
46170 MERR=6
46171 ENDIF
46172
46173C...DECAY TABLES
46174C...Read in decay information
46175 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46176C...Read new decay chanel
46177 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46178 NDC=NDC+1
46179C...Read in branching ratio and number of daughters for this mode.
46180 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46181 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46182 IF (NDA.LE.5) THEN
46183 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46184 & '(PYSLHA:) Decay data arrays full by KF = '
46185 $ //CHAF(KC,1))
46186C...If first decay channel, set decays start point in decay table
46187 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46188 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46189 & '* (PYSLHA:) Reading DECAY table for '//
46190 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46191C...Set particle parameters (mass set when reading BLOCK MASS above)
46192 PMAS(KC,2)=WIDTH
46193 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46194 WRITE(MSTU(11),'(1x,A)')
46195 & '* Note: the Pythia gg->h/H/A cross section'//
46196 & ' is proportional to the h/H/A->gg width'
46197 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46198 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46199 WRITE(MSTU(11),'(1x,A,A16)')
46200 & '* Warning: will use DECAY table (fixed-width,'//
46201 & ' flat PS) for ',CHAF(KC,1)(1:16)
46202 ENDIF
46203 PMAS(KC,3)=0D0
46204 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46205 MWID(KC)=2
46206 MDCY(KC,1)=1
46207 MDCY(KC,2)=NDC
46208 MDCY(KC,3)=0
46209C...Add to list of DECAY blocks currently read
46210 NDECAY=NDECAY+1
46211 KFDEC(NDECAY)=KF
46212C...Return ok
46213 IRETRN=0
46214 ENDIF
46215C... Count up number of decay modes for this particle
46216 MDCY(KC,3)=MDCY(KC,3)+1
46217C... Read in decay daughters.
46218 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46219C... Flip sign if reading antiparticle decays (if antipartner exists)
46220 DO 340 IDA=1,NDA
46221 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46222 & IDC(IDA)=MPSIGN*IDC(IDA)
46223 340 CONTINUE
46224C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46225 MDME(NDC,1)=1
46226 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46227 BRSUM=BRSUM+ABS(BRAT(NDC))
46228 BRAT(NDC)=ABS(BRAT(NDC))
46229 350 IFLIP=0
46230 DO 360 IDA=1,NDA-1
46231 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46232 ITMP=IDC(IDA)
46233 IDC(IDA)=IDC(IDA+1)
46234 IDC(IDA+1)=ITMP
46235 IFLIP=IFLIP+1
46236 ENDIF
46237 360 CONTINUE
46238 IF (IFLIP.GT.0) GOTO 350
46239C...Treat as ordinary decay, no fancy stuff.
46240 MDME(NDC,2)=0
46241 DO 370 IDA=1,5
46242 IF (IDA.LE.NDA) THEN
46243 KFDP(NDC,IDA)=IDC(IDA)
46244 ELSE
46245 KFDP(NDC,IDA)=0
46246 ENDIF
46247 370 CONTINUE
46248C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
46249C & (KFDP(NDC,J),J=1,NDA)
46250 ELSE
46251 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
46252 & CHNLIN)
46253 MERR=11
46254 NDC=NDC-1
46255 ENDIF
46256 ELSEIF(CHINL(1:1).EQ.'+') THEN
46257 MERR=11
46258 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
46259 MERR=16
46260 ELSE
46261 MERR=16
46262 ENDIF
46263 ENDIF
46264C... Error check.
46265 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
46266 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
46267 & //CHINL(1:40)
46268 MERR=0
46269 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
46270 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
46271 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
46272 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
46273 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
46274 & //CHBLCK(1:INL)//'... on line'//CHNLIN
46275 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
46276 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
46277 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
46278 & //'... on line'//CHNLIN
46279 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
46280 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
46281 & /CHBLCK(1:INL)//'... on line'//CHNLIN
46282 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
46283 WRITE (CHTMP,*) KF
46284 WRITE(MSTU(11),*)
46285 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
46286 & CHTMP(1:9)//' on line'//CHNLIN
46287 ENDIF
46288C...Iterate read loop
46289 GOTO 170
46290C...Error catching
46291 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
46292 & ', ignoring subsequent lines.'
46293 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
46294 CHBLCK=' '
46295 GOTO 170
46296C...End of read loop
46297 400 CONTINUE
46298C...Set flag that KC codes have been rearranged.
46299 MSTU(20)=0
46300 VERBOS=0
46301
46302C...Perform possible tests that new information is consistent.
46303 IF (MUPDA.EQ.1) THEN
46304 MSTU23=MSTU(23)
46305 MSTU27=MSTU(27)
46306C...Check masses
46307 DO 410 ISUSY=1,37
46308 KF=KFSUSY(ISUSY)
46309C...Don't complain about right-handed neutrinos
46310 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
46311 & +16) GOTO 410
46312C...Only check gravitino in GMSB scenarios
46313 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
46314 KC=PYCOMP(KF)
46315 IF (PMAS(KC,1).EQ.0D0) THEN
46316 WRITE(CHTMP,*) KF
46317 CALL PYERRM(9
46318 & ,'(PYSLHA:) No mass information found for KF ='
46319 & //CHTMP)
46320 ENDIF
46321 410 CONTINUE
46322C...Check mixing matrices (MSSM only)
46323 IF (IMSS(13).EQ.0) THEN
46324 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
46325 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
46326 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
46327 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
46328 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
46329 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
46330 IF (MSPC(5).NE.4) CALL PYERRM(9
46331 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
46332 IF (MSPC(6).NE.4) CALL PYERRM(9
46333 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
46334 IF (MSPC(7).NE.4) CALL PYERRM(9
46335 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
46336 IF (MSPC(8).LT.1) CALL PYERRM(9
46337 & ,'(PYSLHA:) Too few elements in HMIX')
46338 IF (MSPC(10).EQ.0) CALL PYERRM(9
46339 & ,'(PYSLHA:) Missing A_b trilinear coupling')
46340 IF (MSPC(11).EQ.0) CALL PYERRM(9
46341 & ,'(PYSLHA:) Missing A_t trilinear coupling')
46342 IF (MSPC(12).EQ.0) CALL PYERRM(9
46343 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
46344 IF (MSPC(17).LT.1) CALL PYERRM(9
46345 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
46346 ENDIF
46347C...Check wavefunction normalizations.
46348C...Sfermions
46349 DO 420 ISPC=5,7
46350 IF (MSPC(ISPC).EQ.4) THEN
46351 KFSM=ISPC
46352 IF (ISPC.EQ.7) KFSM=15
46353 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
46354 & *SFMIX(KFSM,3))
46355 IF (ABS(1D0-CHECK).GT.1D-3) THEN
46356 KCSM=PYCOMP(KFSM)
46357 CALL PYERRM(17
46358 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
46359 & //CHAF(KCSM,1))
46360 ENDIF
46361C...Bug fix 30/09 2008: PS
46362C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
46363 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
46364 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
46365 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
46366 ENDIF
46367 ENDIF
46368 420 CONTINUE
46369C...Neutralinos + charginos
46370 DO 440 J=1,4
46371 CN1=0D0
46372 CN2=0D0
46373 CU1=0D0
46374 CU2=0D0
46375 CV1=0D0
46376 CV2=0D0
46377 DO 430 L=1,4
46378 CN1=CN1+ZMIX(J,L)**2
46379 CN2=CN2+ZMIX(L,J)**2
46380 IF (J.LE.2.AND.L.LE.2) THEN
46381 CU1=CU1+UMIX(J,L)**2
46382 CU2=CU2+UMIX(L,J)**2
46383 CV1=CV1+VMIX(J,L)**2
46384 CV2=CV2+VMIX(L,J)**2
46385 ENDIF
46386 430 CONTINUE
46387C...NMIX normalization
46388 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
46389 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
46390 CALL PYERRM(19,
46391 & '(PYSLHA:) NMIX: Inconsistent normalization.')
46392 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
46393 ENDIF
46394C...UMIX, VMIX normalizations
46395 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
46396 IF (J.LE.2) THEN
46397 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
46398 CALL PYERRM(19
46399 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
46400 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
46401 & CU2
46402 ENDIF
46403 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
46404 CALL PYERRM(19,
46405 & '(PYSLHA:) VMIX: Inconsistent normalization.')
46406 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
46407 & CV2
46408 ENDIF
46409 ENDIF
46410 ENDIF
46411 440 CONTINUE
46412 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
46413 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
46414 & '* (PYSLHA:) No spectrum inconsistencies were found.'
46415 ELSE
46416 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
46417 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
46418 & ,' Warning: one or more (serious)'//
46419 & ' inconsistencies were found in the spectrum !'
46420 & ,' Read the error messages above and check your'//
46421 & ' input file.'
46422 ENDIF
46423C...Increase precision in Higgs sector using FeynHiggs
46424 IF (IMSS(4).EQ.3) THEN
46425C...FeynHiggs needs MSOFT.
46426 IERR=0
46427 IF (MSPC(18).EQ.0) THEN
46428 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
46429 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
46430 & ' Cannot call FeynHiggs.'
46431 IERR=-1
46432 ELSE
46433 WRITE(MSTU(11),'(1x,/1x,A/)')
46434 & '* (PYSLHA:) Now calling FeynHiggs.'
46435 CALL PYFEYN(IERR)
46436 IF (IERR.NE.0) IMSS(4)=2
46437 ENDIF
46438 ENDIF
46439 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
46440 IBEG=1
46441 IF (KFORIG.NE.0) IBEG=NDECAY
46442 DO 490 IDECAY=IBEG,NDECAY
46443 KF = KFDEC(IDECAY)
46444 KC = PYCOMP(KF)
46445 WRITE(CHKF,8300) KF
46446 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
46447 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
46448 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
46449 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
46450 $ //CHKF)
46451 BRSUM=0D0
46452 BROPN=0D0
46453 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46454 IF(MDME(IDA,2).GT.80) GOTO 460
46455 KQ=KCHG(KC,1)
46456 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
46457 MERR=0
46458 DO 450 J=1,5
46459 KP=KFDP(IDA,J)
46460 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
46461 IF(KP.EQ.81) KQ=0
46462 ELSEIF(PYCOMP(KP).EQ.0) THEN
46463 MERR=3
46464 ELSE
46465 KQ=KQ-PYCHGE(KP)
46466 KPC=PYCOMP(KP)
46467 PMS=PMS-PMAS(KPC,1)
46468 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
46469 & PMAS(KPC,3))
46470 ENDIF
46471 450 CONTINUE
46472 IF(KQ.NE.0) MERR=MAX(2,MERR)
46473 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
46474 & MERR=MAX(1,MERR)
46475 IF(MERR.EQ.3) CALL PYERRM(17,
46476 & '(PYSLHA:) Unknown particle code in decay of KF ='
46477 $ //CHKF)
46478 IF(MERR.EQ.2) CALL PYERRM(17,
46479 & '(PYSLHA:) Charge not conserved in decay of KF ='
46480 $ //CHKF)
46481 IF(MERR.EQ.1) CALL PYERRM(7,
46482 & '(PYSLHA:) Kinematically unallowed decay of KF ='
46483 $ //CHKF)
46484 BRSUM=BRSUM+BRAT(IDA)
46485 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
46486 460 CONTINUE
46487C...Check branching ratio sum.
46488 IF (BROPN.LE.0D0) THEN
46489C...If zero, set stable.
46490 WRITE(CHTMP,8500) BROPN
46491 CALL PYERRM(7
46492 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
46493 & CHTMP(9:16)//'. Changed to stable.')
46494 PMAS(KC,2)=1D-6
46495 MWID(KC)=0
46496C...If BR's > 1, rescale.
46497 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
46498 WRITE(CHTMP,8500) BRSUM
46499 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
46500 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
46501 & ' ; sum was'//CHTMP(9:16)//'.')
46502 FAC=1D0/BRSUM
46503 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46504 IF(MDME(IDA,2).GT.80) GOTO 470
46505 BRAT(IDA)=FAC*BRAT(IDA)
46506 470 CONTINUE
46507 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
46508C...If BR's < 1, insert dummy mode for proper cross section rescaling.
46509 WRITE(CHTMP,8500) BRSUM
46510 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
46511 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
46512 & CHTMP(9:16)//'. Dummy mode will be inserted.')
46513C...Move table and insert dummy mode
46514 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46515 NDC=NDC+1
46516 BRAT(NDC)=BRAT(IDA)
46517 KFDP(NDC,1)=KFDP(IDA,1)
46518 KFDP(NDC,2)=KFDP(IDA,2)
46519 KFDP(NDC,3)=KFDP(IDA,3)
46520 KFDP(NDC,4)=KFDP(IDA,4)
46521 KFDP(NDC,5)=KFDP(IDA,5)
46522 MDME(NDC,1)=MDME(IDA,1)
46523 480 CONTINUE
46524 NDC=NDC+1
46525 BRAT(NDC)=1D0-BRSUM
46526 KFDP(NDC,1)=0
46527 KFDP(NDC,2)=0
46528 KFDP(NDC,3)=0
46529 KFDP(NDC,4)=0
46530 KFDP(NDC,5)=0
46531 MDME(NDC,1)=0
46532 BRSUM=1D0
46533C...Update MDCY
46534 MDCY(KC,3)=MDCY(KC,3)+1
46535 MDCY(KC,2)=NDC-MDCY(KC,3)+1
46536 ENDIF
46537 490 CONTINUE
46538 ENDIF
46539
46540
46541C...WRITE SPECTRUM ON SLHA FILE
46542 ELSEIF(MUPDA.EQ.3) THEN
46543C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
46544 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
46545 MODSEL(1)=1
46546 PARMIN(1)=RMSS(8)
46547 PARMIN(2)=RMSS(1)
46548 PARMIN(3)=RMSS(5)
46549 PARMIN(4)=SIGN(1D0,RMSS(4))
46550 PARMIN(5)=RMSS(36)
46551 ENDIF
46552C...Write spectrum
46553 WRITE(LFN,7000) 'SLHA MSSM spectrum'
46554 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
46555 & // ' P. Skands.'
46556 WRITE(LFN,7010) 'MODSEL', 'Model selection'
46557 WRITE(LFN,7110) 1, MODSEL(1)
46558 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
46559 IF (MODSEL(1).EQ.1) THEN
46560 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
46561 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
46562 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46563 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46564 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
46565 ELSEIF(MODSEL(2).EQ.2) THEN
46566 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
46567 WRITE(LFN,7210) 2, PARMIN(2), 'M'
46568 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
46569 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
46570 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
46571 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
46572 ENDIF
46573 WRITE(LFN,7000) ' '
46574 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
46575 DO 500 I=1,36
46576 KF=KFSUSY(I)
46577 KC=PYCOMP(KF)
46578 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
46579 KFSM=KF-KSUSY1
46580 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
46581 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
46582 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
46583 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
46584 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
46585 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
46586 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
46587 ELSE
46588 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
46589 ENDIF
46590 500 CONTINUE
46591C...SUSY scale
46592 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
46593 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
46594 WRITE(LFN,7210) 1, RMSS(4),'mu'
46595 WRITE(LFN,7010) 'ALPHA',' '
46596 WRITE(LFN,7210) 1, RMSS(18), 'alpha'
46597 WRITE(LFN,7020) 'AU',RMSUSY
46598 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
46599 WRITE(LFN,7020) 'AD',RMSUSY
46600 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
46601 WRITE(LFN,7020) 'AE',RMSUSY
46602 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
46603 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
46604 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
46605 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
46606 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
46607 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
46608 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
46609 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
46610 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
46611 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
46612 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
46613 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
46614 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
46615 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
46616 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
46617 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
46618 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
46619 DO 520 I1=1,4
46620 DO 510 I2=1,4
46621 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
46622 510 CONTINUE
46623 520 CONTINUE
46624 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
46625 DO 540 I1=1,2
46626 DO 530 I2=1,2
46627 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
46628 530 CONTINUE
46629 540 CONTINUE
46630 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
46631 DO 560 I1=1,2
46632 DO 550 I2=1,2
46633 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
46634 550 CONTINUE
46635 560 CONTINUE
46636 WRITE(LFN,7010) 'SPINFO'
46637 IF (IMSS(1).EQ.2) THEN
46638 CPRO(1)='PYTHIA'
46639 CVER(1)='6.4'
46640 ELSEIF (IMSS(1).EQ.12) THEN
46641 ISAVER=VISAJE()
46642 CPRO(1)='ISASUSY'
46643 CVER(1)=ISAVER(1:12)
46644 ENDIF
46645 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
46646 WRITE(LFN,7310) 2, CVER(1), 'Version number'
46647 ENDIF
46648
46649C...Print user information about spectrum
46650 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
46651 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
46652 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
46653 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
46654 IF (MUPDA.EQ.1) THEN
46655 WRITE(MSTU(11),5020) LFN
46656 ELSE
46657 WRITE(MSTU(11),5010) LFN
46658 ENDIF
46659
46660 WRITE(MSTU(11),5400)
46661 WRITE(MSTU(11),5500) 'Pole masses'
46662 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
46663 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
46664 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
46665 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
46666 IF (IMSS(13).EQ.0) THEN
46667 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
46668 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
46669 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
46670 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
46671 & CHAF(37,1), ' ', ' ',' ',' ',
46672 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
46673 ELSEIF (IMSS(13).EQ.1) THEN
46674 KF1=KSUSY1+21
46675 KF2=KSUSY1+22
46676 KF3=KSUSY1+23
46677 KF4=KSUSY1+25
46678 KF5=KSUSY1+35
46679 KF6=KSUSY1+45
46680 KF7=KSUSY1+24
46681 KF8=KSUSY1+37
46682 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
46683 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
46684 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
46685 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
46686 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
46687 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
46688 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
46689 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
46690 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
46691 & RMFUN(37)
46692 ENDIF
46693 WRITE(MSTU(11),5400)
46694 WRITE(MSTU(11),5500) 'Mixing structure'
46695 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
46696 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
46697 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
46698 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
46699 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
46700 & ),(SFMIX(15,J),J=3,4)
46701 WRITE(MSTU(11),5400)
46702 WRITE(MSTU(11),5500) 'Couplings'
46703 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
46704 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
46705 WRITE(MSTU(11),5400)
46706 WRITE(MSTU(11),6500)
46707
46708 ENDIF
46709
46710C...Only rewind when reading
46711 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
46712
46713 9999 RETURN
46714
46715C...Serious error catching
46716 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
46717 write(*,*) CHINL(1:80)
46718 CALL PYSTOP(106)
46719 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
46720 WRITE(*,*) CHINL(1:72)
46721 CALL PYSTOP(106)
46722 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
46723 WRITE(*,*) CHINL(1:80)
46724 CALL PYSTOP(106)
46725 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
46726 WRITE(*,*) CHINL(1:80)
46727 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
46728 CALL PYSTOP(106)
46729 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
46730 WRITE(*,*) CHINL(1:80)
46731 CALL PYSTOP(106)
46732
46733 8300 FORMAT(I9)
46734 8500 FORMAT(F16.5)
46735
46736C...Formats for user information printout.
46737 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.13: SUSY/BSM SPECTRUM '
46738 & ,'INTERFACE',1x,17('*')/1x,'*',1x
46739 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
46740 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
46741 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
46742 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
46743 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
46744 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
46745 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
46746 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
46747 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
46748 & ,'----------------')
46749 5400 FORMAT(1x,'*',1x,A)
46750 5500 FORMAT(1x,'*',1x,A,':')
46751 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
46752 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
46753 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
46754 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
46755 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46756 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
46757 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
46758 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
46759 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
46760 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
46761 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
46762 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
46763 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
46764 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
46765 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
46766 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
46767 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
46768 & ,1x,F6.3,1x),'|')
46769 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
46770 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
46771 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
46772 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
46773 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
46774 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
46775 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
46776 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
46777 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
46778 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
46779 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
46780 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
46781 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
46782 & ,'A_tau = ',F8.2)
46783 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
46784 & ,' mu = ',F8.2)
46785 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
46786
46787C...Format to use for comments
46788 7000 FORMAT('# ',A)
46789C...Format to use for block statements
46790 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
46791 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
46792C...Indexed Int
46793 7110 FORMAT(1x,I4,1x,I4,3x,'#')
46794C...Non-Indexed Double
46795 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
46796C...Indexed Double
46797 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
46798C...Long Indexed Double (PDG + double)
46799 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
46800C...Indexed Char(12)
46801 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
46802C...Single matrix
46803 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
46804C...Double Matrix
46805 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
46806C...Write Decay Table
46807 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
46808 7510 FORMAT(4x,I5,1x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),
46809 & 3x,'#',1x,A)
46810
46811 END
46812
46813
46814C*********************************************************************
46815
46816C...PYAPPS
46817C...Uses approximate analytical formulae to determine the full set of
46818C...MSSM parameters from SUGRA input.
46819C...See M. Drees and S.P. Martin, hep-ph/9504124
46820
46821 SUBROUTINE PYAPPS
46822
46823C...Double precision and integer declarations.
46824 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46825 IMPLICIT INTEGER(I-N)
46826 INTEGER PYK,PYCHGE,PYCOMP
46827C...Parameter statement to help give large particle numbers.
46828 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46829 &KEXCIT=4000000,KDIMEN=5000000)
46830C...Commonblocks.
46831 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46832 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46833 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46834 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
46835
46836 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
46837 &' not intended for serious physics studies'
46838 IMSS(5)=0
46839 IMSS(8)=0
46840 XMT=PMAS(6,1)
46841 XMZ2=PMAS(23,1)**2
46842 XMW2=PMAS(24,1)**2
46843 TANB=RMSS(5)
46844 BETA=ATAN(TANB)
46845 XW=PARU(102)
46846 XMG=RMSS(1)
46847 XMG2=XMG*XMG
46848 XM0=RMSS(8)
46849 XM02=XM0*XM0
46850C...Temporary sign change for AT. Others unchanged.
46851 AT=-RMSS(16)
46852 RMSS(15)=RMSS(16)
46853 RMSS(17)=RMSS(16)
46854 SINB=TANB/SQRT(TANB**2+1D0)
46855 COSB=SINB/TANB
46856
46857 DTERM=XMZ2*COS(2D0*BETA)
46858 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
46859 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
46860 RMSS(6)=XMEL
46861 RMSS(7)=XMER
46862 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
46863 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
46864 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
46865 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
46866 DO 100 I=1,5,2
46867 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
46868 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
46869 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
46870 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
46871 100 CONTINUE
46872 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
46873 IF(XARG.LT.0D0) THEN
46874 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
46875 & ' FROM THE SUM RULE. '
46876 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
46877 RETURN
46878 ELSE
46879 XARG=SQRT(XARG)
46880 ENDIF
46881 DO 110 I=11,15,2
46882 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
46883 PMAS(PYCOMP(KSUSY2+I),1)=XMER
46884 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
46885 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
46886 110 CONTINUE
46887 RMT=PYMRUN(6,PMAS(6,1)**2)
46888 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
46889 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
46890 RMB=PYMRUN(5,PMAS(6,1)**2)
46891 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
46892 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
46893 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
46894 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
46895 &SINB)**2)
46896 RMSS(16)=-ATP
46897 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
46898 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
46899 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
46900 XMU=SIGN(SQRT(XMU2),RMSS(4))
46901 RMSS(4)=XMU
46902 IF(XMA2.GT.0D0) THEN
46903 RMSS(19)=SQRT(XMA2)
46904 ELSE
46905 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
46906 CALL PYSTOP(102)
46907 ENDIF
46908 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
46909 IF(ARG.GT.0D0) THEN
46910 RMSS(14)=SQRT(ARG)
46911 ELSE
46912 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
46913 CALL PYSTOP(102)
46914 ENDIF
46915 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
46916 IF(ARG.GT.0D0) THEN
46917 RMSS(13)=SQRT(ARG)
46918 ELSE
46919 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
46920 CALL PYSTOP(102)
46921 ENDIF
46922 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
46923 IF(ARG.GT.0D0) THEN
46924 RMSS(10)=SQRT(ARG)
46925 ELSE
46926 RMSS(10)=-SQRT(-ARG)
46927 ENDIF
46928 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
46929 IF(ARG.GT.0D0) THEN
46930 RMSS(12)=SQRT(ARG)
46931 ELSE
46932 RMSS(12)=-SQRT(-ARG)
46933 ENDIF
46934 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
46935 IF(ARG.GT.0D0) THEN
46936 RMSS(11)=SQRT(ARG)
46937 ELSE
46938 RMSS(11)=-SQRT(-ARG)
46939 ENDIF
46940
46941 RETURN
46942 END
46943
46944C*********************************************************************
46945
46946C...PYSUGI
46947C...Interface to ISASUSY version 7.71.
46948C...Warning: this interface should not be used with earlier versions
46949C...of ISASUSY, since common block incompatibilities may then arise.
46950C...Calls SUGRA (in ISAJET) to perform RGE evolution.
46951C...Then converts to Gunion-Haber conventions.
46952
46953 SUBROUTINE PYSUGI
46954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46955
46956 INTEGER PYK,PYCHGE,PYCOMP
46957 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46958 &KEXCIT=4000000,KDIMEN=5000000)
46959
46960C...Date of Change
46961 CHARACTER DOC*11
46962 PARAMETER (DOC='01 May 2006')
46963
46964C...ISASUGRA Input:
46965 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
46966C...XISAIN contains the MSSMi inputs in natural order.
46967 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
46968 $XAMIN(7)
46969 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
46970 SAVE /SUGXIN/
46971C...ISASUGRA Output
46972 CHARACTER*40 ISAVER,VISAJE
46973 REAL SUPER
46974 COMMON /SSPAR/ SUPER(72)
46975 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
46976 $FBGUT,FTAGUT,FNGUT
46977 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
46978 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46979 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46980 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
46981 $VUMT,VDMT,ASMTP,ASMSS,M3Q
46982 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
46983 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
46984 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
46985 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
46986 INTEGER IALLOW
46987 SAVE /SUGMG/,/SSPAR/
46988C SUPER: Filled by ISASUGRA.
46989C SUPER(1) = mass of ~g
46990C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
46991C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
46992C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
46993C ,~tau_2
46994C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
46995C SUPER(29) = Higgsino mass = - mu
46996C SUPER(30) = ratio v2/v1 of vev's
46997C SUPER(31:34) = Signed neutralino masses
46998C SUPER(35:50) = Neutralino mixing matrix
46999C SUPER(51:52) = Signed chargino masses
47000C SUPER(53:54) = Chargino left, right mixing angles
47001C SUPER(55:58) = mass of h0, H0, A0, H+
47002C SUPER(59) = Higgs mixing angle alpha
47003C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47004C SUPER(66) = Gravitino mass
47005C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47006C SUPER(70) = b-Yukawa at mA scale (not used)
47007C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47008C GSS: Filled by ISASUGRA
47009C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47010C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47011C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47012C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47013C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47014C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47015C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47016C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47017C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47018C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47019C GSS(31) = log(vuq)
47020C MSS: Filled by ISASUGRA
47021C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47022C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47023C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47024C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47025C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47026C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47027C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47028C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47029C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47030C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47031C MSS(31) = ha0 MSS(32) = h+
47032C Unification, filled by ISASUGRA if applicable.
47033C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47034
47035C...SPYTHIA Input/Output
47036 INTEGER IMSS
47037 DOUBLE PRECISION RMSS
47038 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47039 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47040 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47041C...SLHA Input/Output
47042 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47043 & AU(3,3),AD(3,3),AE(3,3)
47044C...PYTHIA common blocks
47045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47046 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47047 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47048
47049 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47050CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47051 INTEGER IMODEL
47052 REAL M0,MHF,A0,MT
47053 CHARACTER*20 CHMOD(5)
47054 CHARACTER*32 FNAME
47055
47056 COMMON /SUGNU/ XNUSUG(18)
47057 REAL XNUSUG
47058 SAVE /SUGNU/
47059
47060 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47061 & 'truly unified SUGRA', 'non-minimal GMSB'/
47062
47063C...Start by checking for incompatibilities/inconsistencies:
47064 DO 100 ICHK=2,9
47065 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47066 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47067 & ,' option not used by PYSUGI'
47068 ENDIF
47069 100 CONTINUE
47070C...ISAJET works with REAL numbers.
47071 MZERO=REAL(RMSS(8))
47072 MHLF=REAL(RMSS(1))
47073 AZERO=REAL(RMSS(16))
47074 TANB=REAL(RMSS(5))
47075 SGNMU=REAL(RMSS(4))
47076 MTOP=REAL(PMAS(6,1))
47077 IMODEL=0
47078 IF (IMSS(1).EQ.12) THEN
47079 IMODEL=1
47080 GOTO 130
47081 ELSEIF(IMSS(1).EQ.13) THEN
47082C...Read from isajet par file in IMSS(20)
47083 LFN=IMSS(20)
47084C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47085 IF (LFN.EQ.0) THEN
47086 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47087 GOTO 9999
47088 ENDIF
47089 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47090CMrenna change to allow any susy model
47091 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47092 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47093 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47094 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47095 & ' gauge couplings:'
47096 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47097 READ(LFN,*) IMODEL
47098 IF (IMODEL.EQ.4) THEN
47099 IAL3UN=1
47100 IMODEL=1
47101 ENDIF
47102 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47103 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47104 & //' sgn(mu), M_t:'
47105 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47106 IF (IMODEL.EQ.3) THEN
47107 IMODEL=1
47108 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47109 & //' 0 to continue:'
47110 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47111 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47112 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47113 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47114 & //' generation masses'
47115 WRITE(MSTU(11),*)
47116 & ' NUSUG5 = GUT scale 3rd generation masses'
47117 READ(LFN,*) INUSUG
47118 IF (INUSUG.EQ.0) THEN
47119 GOTO 120
47120 ELSEIF (INUSUG.EQ.1) THEN
47121 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47122 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47123 IF (XNUSUG(3).LE.0.) THEN
47124 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47125 CALL PYSTOP(109)
47126 END IF
47127 ELSEIF (INUSUG.EQ.2) THEN
47128 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47129 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47130 ELSEIF (INUSUG.EQ.3) THEN
47131 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47132 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47133 ELSEIF (INUSUG.EQ.4) THEN
47134 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47135 & //' M(ur), M(el), M(er):'
47136 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47137 & XNUSUG(10),XNUSUG(9)
47138 ELSEIF (INUSUG.EQ.5) THEN
47139 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47140 & //' M(Ll), M(Lr):'
47141 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47142 & XNUSUG(15),XNUSUG(14)
47143 ENDIF
47144 GOTO 110
47145 ENDIF
47146 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47147 IMSS(11)=1
47148 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47149 & ,' sgn(mu), M_t, C_gv:'
47150 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47151 XGMIN(7)=XCMGV
47152 XGMIN(8)=1.
47153C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47154 AMPL=2.4D18
47155 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47156 IF (IMODEL.EQ.5) THEN
47157 IMODEL=2
47158 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47159 & ,' masses at M_mes'
47160 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47161 & ,' shifts at M_mes'
47162 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47163 & ' Y at M_mes'
47164 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47165 & ,'SU(2),SU(3)'
47166 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47167 & ,' n5_2, n5_3'
47168 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47169 $ XGMIN(13),XGMIN(14)
47170 ENDIF
47171 ELSE
47172 WRITE(MSTU(11),*) 'Invalid model choice.'
47173 GOTO 9999
47174 ENDIF
47175 ENDIF
47176
47177 120 MZERO=M0
47178 MHLF=MHF
47179 AZERO=A0
47180C TANB=REAL(RMSS(5))
47181C SGNMU=REAL(RMSS(4))
47182 MTOP=MT
47183
47184C...Initialize MSSM parameter array
47185 130 DO 140 IPAR=1,72
47186 SUPER(IPAR)=0.0
47187 140 CONTINUE
47188C...Call ISASUGRA
47189 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47190C...Check whether ISASUSY thought the model was OK.
47191 IF (NOGOOD.NE.0) THEN
47192 IF (NOGOOD.EQ.1) CALL PYERRM(26
47193 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47194 IF (NOGOOD.EQ.2) CALL PYERRM(26
47195 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
47196 IF (NOGOOD.EQ.3) CALL PYERRM(26
47197 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
47198 IF (NOGOOD.EQ.4) CALL PYERRM(26
47199 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
47200 IF (NOGOOD.EQ.7) CALL PYERRM(26
47201 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
47202 IF (NOGOOD.EQ.8) CALL PYERRM(26
47203 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
47204C...Give warning, but don't stop, if LSP not ~chi_10.
47205 IF (NOGOOD.EQ.5) CALL PYERRM(16
47206 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
47207 ENDIF
47208C...Warn about possible GUT scale tachyons.
47209 IF (ITACHY.NE.0) CALL PYERRM(16,
47210 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
47211C...Finalize spectrum (last iteration)
47212C...(Thanks to A. Raklev for pointing this out.)
47213C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
47214 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
47215 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
47216 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
47217 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
47218 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
47219 $ MTOP,IALLOW,1)
47220
47221C...M1, M2, M3.
47222 RMSS(1)=dble(GSS(7))
47223 RMSS(2)=dble(GSS(8))
47224 RMSS(3)=dble(GSS(9))
47225 RMSOFT(1)=dble(GSS(7))
47226 RMSOFT(2)=dble(GSS(8))
47227 RMSOFT(3)=dble(GSS(9))
47228C...Mu = - Higgsino mass.
47229 RMSS(4)=-SUPER(29)
47230 RMSS(5)=TANB
47231C...Slepton and squark masses. 2 first generations.
47232 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
47233 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
47234 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
47235 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
47236C...Third generation.
47237 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
47238 RMSS(11)=SUPER(11)
47239 RMSS(12)=SUPER(15)
47240 RMSS(13)=SUPER(22)
47241 RMSS(14)=SUPER(23)
47242C...SLHA: store exact soft spectrum in RMSOFT
47243 RMSOFT(31)=SUPER(18)
47244 RMSOFT(32)=SUPER(20)
47245 RMSOFT(33)=SUPER(22)
47246 RMSOFT(34)=SUPER(19)
47247 RMSOFT(35)=SUPER(21)
47248 RMSOFT(36)=SUPER(23)
47249 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
47250 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
47251 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
47252 RMSOFT(44)=SUPER(3)
47253 RMSOFT(45)=SUPER(9)
47254 RMSOFT(46)=SUPER(15)
47255 RMSOFT(47)=SUPER(5)
47256 RMSOFT(48)=SUPER(7)
47257 RMSOFT(49)=SUPER(11)
47258
47259C...~b, ~t, and ~tau trilinear couplings and mixing angles.
47260 RMSS(15)=SUPER(62)
47261 RMSS(16)=SUPER(60)
47262 RMSS(17)=SUPER(64)
47263 RMSS(26)=SUPER(63)
47264 RMSS(27)=SUPER(61)
47265 RMSS(28)=SUPER(65)
47266C...SLHA trilinears
47267 DO 142 K1=1,3
47268 DO 141 K2=1,3
47269 AE(K1,K2)=0D0
47270 AU(K1,K2)=0D0
47271 AD(K1,K2)=0D0
47272 141 CONTINUE
47273 142 CONTINUE
47274 AE(3,3)=SUPER(64)
47275 AU(3,3)=SUPER(60)
47276 AD(3,3)=SUPER(62)
47277C...Higgs mixing angle alpha (Gunion-Haber convention).
47278 RMSS(18)=-SUPER(59)
47279C...A0 mass.
47280 RMSS(19)=SUPER(57)
47281C...GUT scale coupling
47282 RMSS(20)=AGUTSS
47283C...Gravitino mass (for future compatibility)
47284 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
47285
47286C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
47287C...Higgs sector.
47288 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
47289 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
47290 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
47291 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
47292C...Gluino.
47293 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
47294C...Squarks and Sleptons.
47295 DO 150 ILR=1,2
47296 ILRM=ILR-1
47297 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
47298 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
47299 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
47300 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
47301 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
47302 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
47303 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
47304 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
47305 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
47306 150 CONTINUE
47307 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
47308 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
47309 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
47310C...Neutralinos.
47311 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
47312 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
47313 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
47314 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
47315C...Signed masses (extra minus from going to G-H convention).
47316 SMZ(1)=-SUPER(31)
47317 SMZ(2)=-SUPER(32)
47318 SMZ(3)=-SUPER(33)
47319 SMZ(4)=-SUPER(34)
47320C...Charginos
47321 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
47322 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
47323C...Signed masses (extra minus from going to G-H convention).
47324 SMW(1)=-SUPER(51)
47325 SMW(2)=-SUPER(52)
47326
47327C... Neutralino Mixing.
47328 DO 160 IN=1,4
47329 ZMIX(IN,1)= SUPER(38+4*(IN-1))
47330 ZMIX(IN,2)= SUPER(37+4*(IN-1))
47331 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
47332 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
47333 160 CONTINUE
47334C...Chargino Mixing (PYTHIA same angle as HERWIG).
47335 THX=1D0
47336 THY=1D0
47337 IF (SUPER(53).GT.0) THX=-1D0
47338 IF (SUPER(54).GT.0) THY=-1D0
47339 UMIX(1,1) = -SIN(SUPER(53))
47340 UMIX(1,2) = -COS(SUPER(53))
47341 UMIX(2,1) = -THX*COS(SUPER(53))
47342 UMIX(2,2) = THX*SIN(SUPER(53))
47343 VMIX(1,1) = -SIN(SUPER(54))
47344 VMIX(1,2) = -COS(SUPER(54))
47345 VMIX(2,1) = -THY*COS(SUPER(54))
47346 VMIX(2,2) = THY*SIN(SUPER(54))
47347C...Sfermion mixing (PYTHIA same angle as ISAJET)
47348 SFMIX(5,1)=COS(SUPER(63))
47349 SFMIX(5,2)=SIN(SUPER(63))
47350 SFMIX(5,3)=-SIN(SUPER(63))
47351 SFMIX(5,4)=COS(SUPER(63))
47352 SFMIX(6,1)=COS(SUPER(61))
47353 SFMIX(6,2)=SIN(SUPER(61))
47354 SFMIX(6,3)=-SIN(SUPER(61))
47355 SFMIX(6,4)=COS(SUPER(61))
47356 SFMIX(15,1)=COS(SUPER(65))
47357 SFMIX(15,2)=SIN(SUPER(65))
47358 SFMIX(15,3)=-SIN(SUPER(65))
47359 SFMIX(15,4)=COS(SUPER(65))
47360
47361 IF (MSTP(122).NE.0) THEN
47362C...Print a few lines to make the user know what's happening
47363 ISAVER=VISAJE()
47364 WRITE(MSTU(11),5000) DOC, ISAVER
47365 WRITE(MSTU(11),5100)
47366 IF (IMODEL.EQ.1) THEN
47367 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
47368 & MTOP
47369 WRITE(MSTU(11),5300)
47370 ENDIF
47371 WRITE(MSTU(11),5500) 'Pole masses'
47372 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
47373 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
47374 & ,(SUPER(IP),IP=19,25,2)
47375 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
47376 & ,IP=1,2)
47377 WRITE(MSTU(11),5400)
47378 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
47379 WRITE(MSTU(11),5400)
47380 WRITE(MSTU(11),5500) 'EW scale mixing structure'
47381 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47382 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47383 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47384 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47385 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47386 & ),(SFMIX(15,J),J=3,4)
47387 WRITE(MSTU(11),5400)
47388 WRITE(MSTU(11),6450) RMSS(18)
47389 WRITE(MSTU(11),5400)
47390 WRITE(MSTU(11),5500) 'Couplings'
47391 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
47392 WRITE(MSTU(11),5400)
47393 ENDIF
47394
47395C...Call FeynHiggs to improve Higgs sector if requested
47396 IF (IMSS(4).EQ.3) THEN
47397 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
47398 & ' (PYSUGI:) Now calling FeynHiggs.'
47399 CALL PYFEYN(IERR)
47400 IF (IERR.EQ.0) THEN
47401 IMSS(4)=2
47402 IF (MSTP(122).NE.0) THEN
47403 WRITE(MSTU(11),5400)
47404 WRITE(MSTU(11),5500)
47405 & 'Corrected Higgs masses and mixing'
47406 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
47407 & PMAS(37,1)
47408 WRITE(MSTU(11),6450) RMSS(18)
47409 WRITE(MSTU(11),5400)
47410 ENDIF
47411 ENDIF
47412 ENDIF
47413
47414 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
47415
47416C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
47417C...output by ISASUSY.
47418 IMSS(4)=MAX(2,IMSS(4))
47419
47420 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
47421 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
47422 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
47423 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
47424 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47425 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47426 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
47427 & ,'----------------')
47428 5400 FORMAT(1x,'*',1x,A)
47429 5500 FORMAT(1x,'*',1x,A,':')
47430 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47431 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47432 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
47433 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
47434 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
47435 & ,1x))
47436 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
47437 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
47438 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
47439 & .2,1x))
47440 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47441 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47442 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47443 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47444 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
47445 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
47446 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
47447 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47448 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47449 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47450 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47451 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47452 & ,1x,F6.3,1x),'|')
47453 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47454 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47455 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47456 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47457 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47458 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47459 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47460 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47461 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47462 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47463 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47464 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47465 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
47466 & ,4x,'Alpha_GUT = ',F8.2)
47467 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
47468 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
47469
47470 9999 RETURN
47471 END
47472
47473C*********************************************************************
47474
47475C...PYFEYN
47476C...Interface to FeynHiggs for MSSM Higgs sector.
47477C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
47478C...P. Skands
47479
47480 SUBROUTINE PYFEYN(IERR)
47481
47482C...Double precision and integer declarations.
47483 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47484 IMPLICIT INTEGER(I-N)
47485 INTEGER PYK,PYCHGE,PYCOMP
47486C...Commonblocks.
47487 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47488 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47489C...SUSY blocks
47490 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47491C...FeynHiggs variables
47492 DOUBLE PRECISION RMHIGG(4)
47493 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
47494 DOUBLE COMPLEX DMU,
47495 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47496 & DM1, DM2, DM3
47497C...SLHA Common Block
47498 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47499 & AU(3,3),AD(3,3),AE(3,3)
47500 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
47501
47502 IERR=0
47503 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
47504 IF (IERR.NE.0) THEN
47505 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
47506 & //'Will not use FeynHiggs for this run.')
47507 RETURN
47508 ENDIF
47509 Q=RMSOFT(0)
47510 DMB=PMAS(5,1)
47511 DMT=PMAS(6,1)
47512 DMZ=PMAS(23,1)
47513 DMW=PMAS(24,1)
47514 DMA=PMAS(36,1)
47515 DM1=RMSOFT(1)
47516 DM2=RMSOFT(2)
47517 DM3=RMSOFT(3)
47518 DTANB=RMSS(5)
47519 DMU=RMSS(4)
47520 DM3SL=RMSOFT(33)
47521 DM3SE=RMSOFT(36)
47522 DM3SQ=RMSOFT(43)
47523 DM3SU=RMSOFT(46)
47524 DM3SD=RMSOFT(49)
47525 DM2SL=RMSOFT(32)
47526 DM2SE=RMSOFT(35)
47527 DM2SQ=RMSOFT(42)
47528 DM2SU=RMSOFT(45)
47529 DM2SD=RMSOFT(48)
47530 DM1SL=RMSOFT(31)
47531 DM1SE=RMSOFT(34)
47532 DM1SQ=RMSOFT(41)
47533 DM1SU=RMSOFT(44)
47534 DM1SD=RMSOFT(47)
47535 AE33=AE(3,3)
47536 AE22=AE(2,2)
47537 AE11=AE(1,1)
47538 AU33=AU(3,3)
47539 AU22=AU(2,2)
47540 AU11=AU(1,1)
47541 AD33=AD(3,3)
47542 AD22=AD(2,2)
47543 AD11=AD(1,1)
47544 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
47545 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
47546 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
47547 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
47548 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
47549 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
47550 IF (IERR.NE.0) THEN
47551 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
47552 & //' Will not use FeynHiggs for this run.')
47553 RETURN
47554 ENDIF
47555C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
47556 SAEFF=0D0
47557 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
47558 IF (IERR.NE.0) THEN
47559 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
47560 & 'GSCORR. Will not use FeynHiggs for this run.')
47561 RETURN
47562 ENDIF
47563 ALPHA = ASIN(DBLE(SAEFF))
47564 R=RMSS(18)/ALPHA
47565 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
47566 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47567 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
47568 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
47569 ENDIF
47570 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
47571 & 1.15D0*PMAS(25,1)) THEN
47572 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
47573 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
47574 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
47575 ENDIF
47576 RMSS(18)=ALPHA
47577 PMAS(25,1)=RMHIGG(1)
47578 PMAS(35,1)=RMHIGG(2)
47579 PMAS(36,1)=RMHIGG(3)
47580 PMAS(37,1)=RMHIGG(4)
47581
47582 RETURN
47583 END
47584
47585C*********************************************************************
47586
47587C...PYRNMQ
47588C...Determines the running mass of Squarks.
47589
47590 FUNCTION PYRNMQ(ID,DTERM)
47591
47592C...Double precision and integer declarations.
47593 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47594 IMPLICIT INTEGER(I-N)
47595 INTEGER PYK,PYCHGE,PYCOMP
47596C...Commonblock.
47597 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47598 SAVE /PYMSSM/
47599
47600C...Local variables.
47601 DOUBLE PRECISION PI,R
47602 DOUBLE PRECISION TOL
47603 DOUBLE PRECISION CI(3)
47604 EXTERNAL PYALPS
47605 DOUBLE PRECISION PYALPS
47606 DATA TOL/0.001D0/
47607 DATA PI,R/3.141592654D0,.61803399D0/
47608 DATA CI/0.47D0,0.07D0,0.02D0/
47609
47610 C=1D0-R
47611 CA=CI(ID)
47612 AG=(0.71D0)**2/4D0/PI
47613 AG=RMSS(20)
47614 XM0=RMSS(8)
47615 XMG=RMSS(1)
47616 XM02=XM0*XM0
47617 XMG2=XMG*XMG
47618
47619 AS=PYALPS(XM02+6D0*XMG2)
47620 CG=8D0/9D0*((AS/AG)**2-1D0)
47621 BX=XM02+(CA+CG)*XMG2+DTERM
47622 AX=MIN(50D0**2,0.5D0*BX)
47623 CX=MAX(2000D0**2,2D0*BX)
47624
47625 X0=AX
47626 X3=CX
47627 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
47628 X1=BX
47629 X2=BX+C*(CX-BX)
47630 ELSE
47631 X2=BX
47632 X1=BX-C*(BX-AX)
47633 ENDIF
47634 AS1=PYALPS(X1)
47635 CG=8D0/9D0*((AS1/AG)**2-1D0)
47636 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47637 AS2=PYALPS(X2)
47638 CG=8D0/9D0*((AS2/AG)**2-1D0)
47639 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47640 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
47641 IF(F2.LT.F1) THEN
47642 X0=X1
47643 X1=X2
47644 X2=R*X1+C*X3
47645 F1=F2
47646 AS2=PYALPS(X2)
47647 CG=8D0/9D0*((AS2/AG)**2-1D0)
47648 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
47649 ELSE
47650 X3=X2
47651 X2=X1
47652 X1=R*X2+C*X0
47653 F2=F1
47654 AS1=PYALPS(X1)
47655 CG=8D0/9D0*((AS1/AG)**2-1D0)
47656 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
47657 ENDIF
47658 GOTO 100
47659 ENDIF
47660 IF(F1.LT.F2) THEN
47661 PYRNMQ=X1
47662 XMIN=X1
47663 ELSE
47664 PYRNMQ=X2
47665 XMIN=X2
47666 ENDIF
47667
47668 RETURN
47669 END
47670
47671C*********************************************************************
47672
47673C...PYTHRG
47674C...Calculates the mass eigenstates of the third generation sfermions.
47675C...Created: 5-31-96
47676
47677 SUBROUTINE PYTHRG
47678
47679C...Double precision and integer declarations.
47680 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47681 IMPLICIT INTEGER(I-N)
47682 INTEGER PYK,PYCHGE,PYCOMP
47683C...Parameter statement to help give large particle numbers.
47684 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47685 &KEXCIT=4000000,KDIMEN=5000000)
47686C...Commonblocks.
47687 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47688 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47689 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47690 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47691 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47692 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47693
47694C...Local variables.
47695 DOUBLE PRECISION BETA
47696 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
47697 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
47698 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
47699 DOUBLE PRECISION ATR,AMQR,AMQL
47700 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
47701 INTEGER IF,I,J,II,JJ,IT,L
47702 LOGICAL DTERM
47703 DATA SMALL/1D-3/
47704 DATA ID1/10,10,13/
47705 DATA ID2/5,6,15/
47706 DATA ID3/15,16,17/
47707 DATA ID4/11,12,14/
47708 DATA DTERM/.TRUE./
47709
47710 XMZ2=PMAS(23,1)**2
47711 XMW2=PMAS(24,1)**2
47712 TANB=RMSS(5)
47713 XMU=-RMSS(4)
47714 BETA=ATAN(TANB)
47715 COS2B=COS(2D0*BETA)
47716
47717C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
47718
47719 IOPT=IMSS(5)
47720 IF(IOPT.EQ.1) THEN
47721 CTT=DCOS(RMSS(27))
47722 CTT2=CTT**2
47723 STT=DSIN(RMSS(27))
47724 STT2=STT**2
47725 XM12=RMSS(10)**2
47726 XM22=RMSS(12)**2
47727 XMQL2=CTT2*XM12+STT2*XM22
47728 XMQR2=STT2*XM12+CTT2*XM22
47729 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
47730 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47731 RMSS(16)=ATOP
47732C......SUBTRACT OUT D-TERM AND FERMION MASS
47733 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
47734 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
47735 IF(XMQL2.GE.0D0) THEN
47736 RMSS(10)=SQRT(XMQL2)
47737 ELSE
47738 RMSS(10)=-SQRT(-XMQL2)
47739 ENDIF
47740 IF(XMQR2.GE.0D0) THEN
47741 RMSS(12)=SQRT(XMQR2)
47742 ELSE
47743 RMSS(12)=-SQRT(-XMQR2)
47744 ENDIF
47745
47746C SAME FOR BOTTOM SQUARK
47747 CTT=DCOS(RMSS(26))
47748 CTT2=CTT**2
47749 STT=DSIN(RMSS(26))
47750 STT2=STT**2
47751 XM22=RMSS(11)**2
47752 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
47753 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
47754 IF(ABS(CTT).GE..9999D0) THEN
47755 ABOT=-XMU*TANB
47756 XMQR2=RMSS(11)**2
47757 ELSEIF(ABS(CTT).LE.1D-4) THEN
47758 ABOT=-XMU*TANB
47759 XMQR2=RMSS(11)**2
47760 ELSE
47761 XM12=(XMQL2-STT2*XM22)/CTT2
47762 XMQR2=STT2*XM12+CTT2*XM22
47763 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47764 ENDIF
47765 RMSS(15)=ABOT
47766C......SUBTRACT OUT D-TERM AND FERMION MASS
47767 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
47768 IF(XMQR2.GE.0D0) THEN
47769 RMSS(11)=SQRT(XMQR2)
47770 ELSE
47771 RMSS(11)=-SQRT(-XMQR2)
47772 ENDIF
47773C SAME FOR TAU SLEPTON
47774 CTT=DCOS(RMSS(28))
47775 CTT2=CTT**2
47776 STT=DSIN(RMSS(28))
47777 STT2=STT**2
47778 XM12=RMSS(13)**2
47779 XM22=RMSS(14)**2
47780 XMQL2=CTT2*XM12+STT2*XM22
47781 XMQR2=STT2*XM12+CTT2*XM22
47782 XMFR=PMAS(15,1)
47783 XMF2=XMFR**2
47784 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
47785 RMSS(17)=ATAU
47786C......SUBTRACT OUT D-TERM AND FERMION MASS
47787 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
47788 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
47789 IF(XMQL2.GE.0D0) THEN
47790 RMSS(13)=SQRT(XMQL2)
47791 ELSE
47792 RMSS(13)=-SQRT(-XMQL2)
47793 ENDIF
47794 IF(XMQR2.GE.0D0) THEN
47795 RMSS(14)=SQRT(XMQR2)
47796 ELSE
47797 RMSS(14)=-SQRT(-XMQR2)
47798 ENDIF
47799 ENDIF
47800 DO 170 L=1,3
47801 AMQL=RMSS(ID1(L))
47802 IF(AMQL.LT.0D0) THEN
47803 XMQL2=-AMQL**2
47804 ELSE
47805 XMQL2=AMQL**2
47806 ENDIF
47807 ATR=RMSS(ID3(L))
47808 AMQR=RMSS(ID4(L))
47809 IF(AMQR.LT.0D0) THEN
47810 XMQR2=-AMQR**2
47811 ELSE
47812 XMQR2=AMQR**2
47813 ENDIF
47814 IF=ID2(L)
47815 XMF=PYMRUN(IF,PMAS(6,1)**2)
47816 XMF2=XMF**2
47817 AM2(1,1)=XMQL2+XMF2
47818 AM2(2,2)=XMQR2+XMF2
47819 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
47820 IF(DTERM) THEN
47821 IF(L.EQ.1) THEN
47822 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
47823 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
47824 AM2(1,2)=XMF*(ATR+XMU*TANB)
47825 ELSEIF(L.EQ.2) THEN
47826 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
47827 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
47828 AM2(1,2)=XMF*(ATR+XMU/TANB)
47829 ELSEIF(L.EQ.3) THEN
47830 IF(IMSS(8).EQ.1) THEN
47831 AM2(1,1)=RMSS(6)**2
47832 AM2(2,2)=RMSS(7)**2
47833 AM2(1,2)=0D0
47834 RMSS(13)=RMSS(6)
47835 RMSS(14)=RMSS(7)
47836 ELSE
47837 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
47838 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
47839 AM2(1,2)=XMF*(ATR+XMU*TANB)
47840 ENDIF
47841 ENDIF
47842 ENDIF
47843 AM2(2,1)=AM2(1,2)
47844 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
47845 IF(DETM.LT.0D0) THEN
47846 WRITE(MSTU(11),*) ID2(L),DETM,AM2
47847 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
47848 ENDIF
47849 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
47850 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
47851 XMF12=SAME-DIFF
47852 XMF22=SAME+DIFF
47853 IT=0
47854 IF(XMF22-XMF12.GT.0D0) THEN
47855 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
47856 RT(2,2) = RT(1,1)
47857 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
47858 & AM2(1,2)/(XMF22-XMF12))
47859 RT(2,1) = -RT(1,2)
47860 ELSE
47861 RT(1,1) = 1D0
47862 RT(2,2) = RT(1,1)
47863 RT(1,2) = 0D0
47864 RT(2,1) = -RT(1,2)
47865 ENDIF
47866 100 CONTINUE
47867 IT=IT+1
47868
47869 DO 140 I=1,2
47870 DO 130 JJ=1,2
47871 DI(I,JJ)=0D0
47872 DO 120 II=1,2
47873 DO 110 J=1,2
47874 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
47875 110 CONTINUE
47876 120 CONTINUE
47877 130 CONTINUE
47878 140 CONTINUE
47879
47880 IF(DI(1,1).GT.DI(2,2)) THEN
47881 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
47882 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
47883 WRITE(MSTU(11),*) AM2
47884 WRITE(MSTU(11),*) DI
47885 WRITE(MSTU(11),*) RT
47886 DI(1,1)=-RT(2,1)
47887 DI(2,2)=RT(1,2)
47888 DI(1,2)=-RT(2,2)
47889 DI(2,1)=RT(1,1)
47890 DO 160 I=1,2
47891 DO 150 J=1,2
47892 RT(I,J)=DI(I,J)
47893 150 CONTINUE
47894 160 CONTINUE
47895 GOTO 100
47896 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
47897 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47898 & ' OFF DIAGONAL ELEMENTS '
47899 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
47900 WRITE(MSTU(11),*) DI
47901 WRITE(MSTU(11),*) ' ROTATION = ',RT
47902C...STOP
47903 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
47904 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
47905 & ' NEGATIVE MASSES '
47906 CALL PYSTOP(111)
47907 ENDIF
47908 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
47909 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
47910 SFMIX(IF,1)=RT(1,1)
47911 SFMIX(IF,2)=RT(1,2)
47912 SFMIX(IF,3)=RT(2,1)
47913 SFMIX(IF,4)=RT(2,2)
47914 170 CONTINUE
47915
47916C.....TAU SNEUTRINO MASS...L=3
47917
47918 XARG=AM2(1,1)+XMW2*COS2B
47919 IF(XARG.LT.0D0) THEN
47920 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
47921 & ' FROM THE SUM RULE. '
47922 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47923 RETURN
47924 ELSE
47925 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
47926 ENDIF
47927
47928 RETURN
47929 END
47930C*********************************************************************
47931
47932C...PYINOM
47933C...Finds the mass eigenstates and mixing matrices for neutralinos
47934C...and charginos.
47935
47936 SUBROUTINE PYINOM
47937
47938C...Double precision and integer declarations.
47939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47940 IMPLICIT INTEGER(I-N)
47941 INTEGER PYCOMP
47942C...Parameter statement to help give large particle numbers.
47943 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47944 &KEXCIT=4000000,KDIMEN=5000000)
47945C...Commonblocks.
47946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47947 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47948 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47949 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47950 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47951 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
47952
47953C...Local variables.
47954 DOUBLE PRECISION XMW,XMZ,XM(4)
47955 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
47956 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
47957 DOUBLE PRECISION COSW,SINW
47958 DOUBLE PRECISION XMU
47959 DOUBLE PRECISION TANB,COSB,SINB
47960 DOUBLE PRECISION XM1,XM2,XM3,BETA
47961 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
47962 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
47963 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
47964 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
47965 DOUBLE PRECISION PYALPS,PYALEM
47966 DOUBLE PRECISION PYRNM3
47967 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
47968 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
47969 DATA KFNCHI/1000022,1000023,1000025,1000035/
47970
47971 IOPT=IMSS(2)
47972 IF(IMSS(1).EQ.2) THEN
47973 IOPT=1
47974 ENDIF
47975C...M1, M2, AND M3 ARE INDEPENDENT
47976 IF(IOPT.EQ.0) THEN
47977 XM1=RMSS(1)
47978 XM2=RMSS(2)
47979 XM3=RMSS(3)
47980 ELSEIF(IOPT.GE.1) THEN
47981 Q2=PMAS(23,1)**2
47982 AEM=PYALEM(Q2)
47983 A2=AEM/PARU(102)
47984 A1=AEM/(1D0-PARU(102))
47985 XM1=RMSS(1)
47986 XM2=RMSS(2)
47987 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
47988 IF(IOPT.EQ.1) THEN
47989 XM2=XM1*A2/A1*3D0/5D0
47990 RMSS(2)=XM2
47991 ELSEIF(IOPT.EQ.3) THEN
47992 XM1=XM2*5D0/3D0*A1/A2
47993 RMSS(1)=XM1
47994 ENDIF
47995 XM3=PYRNM3(XM2/A2)
47996 RMSS(3)=XM3
47997 IF(XM3.LE.0D0) THEN
47998 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
47999 CALL PYSTOP(105)
48000 ENDIF
48001 ENDIF
48002
48003C...GLUINO MASS
48004 IF(IMSS(3).EQ.1) THEN
48005 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48006 ELSE
48007 AQ=0D0
48008 DO 110 I=1,4
48009 DO 100 ILR=1,2
48010 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48011 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48012 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48013 100 CONTINUE
48014 110 CONTINUE
48015
48016 DO 130 I=5,6
48017 DO 120 ILR=1,2
48018 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48019 RM2=PMAS(I,1)**2/XM3**2
48020 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48021 IF(ARG.GE.0D0) THEN
48022 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48023 AX0=ABS(X0)
48024 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48025 AX1=ABS(X1)
48026 IF(X0.EQ.1D0) THEN
48027 AT=-1D0
48028 BT=0.25D0
48029 ELSEIF(X0.EQ.0D0) THEN
48030 AT=0D0
48031 BT=-0.25D0
48032 ELSE
48033 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48034 & 0.5D0*X0**2*LOG(AX0)
48035 BT=(-1D0-2D0*X0)/4D0
48036 ENDIF
48037 IF(X1.EQ.1D0) THEN
48038 AT=-1D0+AT
48039 BT=0.25D0+BT
48040 ELSEIF(X1.EQ.0D0) THEN
48041 AT=0D0+AT
48042 BT=-0.25D0+BT
48043 ELSE
48044 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48045 & X1**2*LOG(AX1)+AT
48046 BT=(-1D0-2D0*X1)/4D0+BT
48047 ENDIF
48048 AQ=AQ+AT+BT
48049 ELSE
48050 X0=0.5D0*(1D0+RM2-RM1)
48051 Y0=-0.5D0*SQRT(-ARG)
48052 AMGX0=SQRT(X0**2+Y0**2)
48053 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48054 ARGX0=ATAN2(-X0,-Y0)
48055 AR1X0=ATAN2(1D0-X0,Y0)
48056 X1=X0
48057 Y1=-Y0
48058 AMGX1=AMGX0
48059 AM1X1=AM1X0
48060 ARGX1=ATAN2(-X1,-Y1)
48061 AR1X1=ATAN2(1D0-X1,Y1)
48062 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48063 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48064 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48065 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48066 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48067 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48068 AQ=AQ+AT+BT
48069 ENDIF
48070 120 CONTINUE
48071 130 CONTINUE
48072 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48073 & /(2D0*PARU(2))*(15D0+AQ))
48074 ENDIF
48075
48076C...NEUTRALINO MASSES
48077 DO 150 I=1,4
48078 DO 140 J=1,4
48079 AI(I,J)=0D0
48080 140 CONTINUE
48081 150 CONTINUE
48082 XMZ=PMAS(23,1)/100D0
48083 XMW=PMAS(24,1)/100D0
48084 XMU=RMSS(4)/100D0
48085 SINW=SQRT(PARU(102))
48086 COSW=SQRT(1D0-PARU(102))
48087 TANB=RMSS(5)
48088 BETA=ATAN(TANB)
48089 COSB=COS(BETA)
48090 SINB=TANB*COSB
48091
48092 XM2=XM2/100D0
48093 XM1=XM1/100D0
48094
48095
48096C... Definitions:
48097C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48098C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48099 AR(1,1) = XM1*COS(RMSS(30))
48100 AI(1,1) = XM1*SIN(RMSS(30))
48101 AR(2,2) = XM2*COS(RMSS(31))
48102 AI(2,2) = XM2*SIN(RMSS(31))
48103 AR(3,3) = 0D0
48104 AR(4,4) = 0D0
48105 AR(1,2) = 0D0
48106 AR(2,1) = 0D0
48107 AR(1,3) = -XMZ*SINW*COSB
48108 AR(3,1) = AR(1,3)
48109 AR(1,4) = XMZ*SINW*SINB
48110 AR(4,1) = AR(1,4)
48111 AR(2,3) = XMZ*COSW*COSB
48112 AR(3,2) = AR(2,3)
48113 AR(2,4) = -XMZ*COSW*SINB
48114 AR(4,2) = AR(2,4)
48115 AR(3,4) = -XMU*COS(RMSS(33))
48116 AI(3,4) = -XMU*SIN(RMSS(33))
48117 AR(4,3) = -XMU*COS(RMSS(33))
48118 AI(4,3) = -XMU*SIN(RMSS(33))
48119C CALL PYEIG4(AR,WR,ZR)
48120 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48121 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48122 & 'PROBLEM WITH PYEICG IN PYINOM ')
48123 DO 160 I=1,4
48124 INDEX(I)=I
48125 XM(I)=ABS(WR(I))
48126 160 CONTINUE
48127 DO 180 I=2,4
48128 K=I
48129 DO 170 J=I-1,1,-1
48130 IF(XM(K).LT.XM(J)) THEN
48131 ITMP=INDEX(J)
48132 XTMP=XM(J)
48133 INDEX(J)=INDEX(K)
48134 XM(J)=XM(K)
48135 INDEX(K)=ITMP
48136 XM(K)=XTMP
48137 K=K-1
48138 ELSE
48139 GOTO 180
48140 ENDIF
48141 170 CONTINUE
48142 180 CONTINUE
48143
48144
48145 DO 210 I=1,4
48146 K=INDEX(I)
48147 SMZ(I)=WR(K)*100D0
48148 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48149 S=0D0
48150 DO 190 J=1,4
48151 S=S+ZR(J,K)**2+ZI(J,K)**2
48152 190 CONTINUE
48153 DO 200 J=1,4
48154 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48155 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48156 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48157 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48158 200 CONTINUE
48159 210 CONTINUE
48160
48161C...CHARGINO MASSES
48162C.....Find eigenvectors of X X^*
48163 DO I=1,4
48164 DO J=1,4
48165 AR(I,J)=0D0
48166 AI(I,J)=0D0
48167 ENDDO
48168 ENDDO
48169 AI(1,1) = 0D0
48170 AI(2,2) = 0D0
48171 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48172 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48173 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48174 &XMU*COS(RMSS(33))*SINB)
48175 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48176 &XMU*SIN(RMSS(33))*SINB)
48177 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48178 &XMU*COS(RMSS(33))*SINB)
48179 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48180 &XMU*SIN(RMSS(33))*SINB)
48181 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48182 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48183 & 'PROBLEM WITH PYEICG IN PYINOM ')
48184 INDEX(1)=1
48185 INDEX(2)=2
48186 IF(WR(2).LT.WR(1)) THEN
48187 INDEX(1)=2
48188 INDEX(2)=1
48189 ENDIF
48190
48191
48192 DO 240 I=1,2
48193 K=INDEX(I)
48194 SMW(I)=SQRT(WR(K))*100D0
48195 S=0D0
48196 DO 220 J=1,2
48197 S=S+ZR(J,K)**2+ZI(J,K)**2
48198 220 CONTINUE
48199 DO 230 J=1,2
48200 UMIX(I,J)=ZR(J,K)/SQRT(S)
48201 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
48202 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
48203 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
48204 230 CONTINUE
48205 240 CONTINUE
48206C...Force chargino mass > neutralino mass
48207 IFRC=0
48208 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
48209 CALL PYERRM(8,'(PYINOM:) '//
48210 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
48211 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
48212 IFRC=1
48213 ENDIF
48214 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
48215 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
48216
48217C.....Find eigenvectors of X^* X
48218 DO I=1,4
48219 DO J=1,4
48220 AR(I,J)=0D0
48221 AI(I,J)=0D0
48222 ZR(I,J)=0D0
48223 ZI(I,J)=0D0
48224 ENDDO
48225 ENDDO
48226 AI(1,1) = 0D0
48227 AI(2,2) = 0D0
48228 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
48229 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
48230 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48231 &XMU*COS(RMSS(33))*COSB)
48232 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
48233 &XMU*SIN(RMSS(33))*COSB)
48234 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
48235 &XMU*COS(RMSS(33))*COSB)
48236 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
48237 &XMU*SIN(RMSS(33))*COSB)
48238 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48239 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48240 & 'PROBLEM WITH PYEICG IN PYINOM ')
48241 INDEX(1)=1
48242 INDEX(2)=2
48243 IF(WR(2).LT.WR(1)) THEN
48244 INDEX(1)=2
48245 INDEX(2)=1
48246 ENDIF
48247
48248 SIMAG=0D0
48249 DO 270 I=1,2
48250 K=INDEX(I)
48251 S=0D0
48252 DO 250 J=1,2
48253 S=S+ZR(J,K)**2+ZI(J,K)**2
48254 SIMAG=SIMAG+ZI(J,K)**2
48255 250 CONTINUE
48256 DO 260 J=1,2
48257 VMIX(I,J)=ZR(J,K)/SQRT(S)
48258 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
48259 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
48260 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
48261 260 CONTINUE
48262 270 CONTINUE
48263
48264C.....Simplify if no phases
48265 IF(SIMAG.LT.1D-6) THEN
48266 AR(1,1) = XM2*COS(RMSS(31))
48267 AR(2,2) = XMU*COS(RMSS(33))
48268 AR(1,2) = SQRT(2D0)*XMW*SINB
48269 AR(2,1) = SQRT(2D0)*XMW*COSB
48270 IKNT=0
48271 300 CONTINUE
48272 DO I=1,2
48273 DO J=1,2
48274 ZR(I,J)=0D0
48275 ENDDO
48276 ENDDO
48277
48278 DO I=1,2
48279 DO J=1,2
48280 DO K=1,2
48281 DO L=1,2
48282 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
48283 ENDDO
48284 ENDDO
48285 ENDDO
48286 ENDDO
48287 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
48288 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
48289 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
48290 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
48291 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48292 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48293 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
48294 IKNT=IKNT+1
48295 GOTO 300
48296 ENDIF
48297C.....Must deal with phases
48298 ELSE
48299 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
48300 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
48301 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
48302 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
48303
48304 IKNT=0
48305 310 CONTINUE
48306 DO I=1,2
48307 DO J=1,2
48308 CAI(I,J)=CMPLX(0D0,0D0)
48309 ENDDO
48310 ENDDO
48311
48312 DO I=1,2
48313 DO J=1,2
48314 DO K=1,2
48315 DO L=1,2
48316 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
48317 & CMPLX(VMIX(J,L),VMIXI(J,L))
48318 ENDDO
48319 ENDDO
48320 ENDDO
48321 ENDDO
48322
48323 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
48324 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
48325 TEMPR=VMIX(1,1)
48326 TEMPI=VMIXI(1,1)
48327 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48328 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48329 TEMPR=VMIX(1,2)
48330 TEMPI=VMIXI(1,2)
48331 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
48332 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
48333 TEMPR=VMIX(2,1)
48334 TEMPI=VMIXI(2,1)
48335 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48336 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48337 TEMPR=VMIX(2,2)
48338 TEMPI=VMIXI(2,2)
48339 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
48340 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
48341 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
48342 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
48343 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
48344 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
48345 IKNT=IKNT+1
48346 GOTO 310
48347 ENDIF
48348 ENDIF
48349 RETURN
48350 END
48351
48352C*********************************************************************
48353
48354C...PYRNM3
48355C...Calculates the running of M3, the SU(3) gluino mass parameter.
48356
48357 FUNCTION PYRNM3(RGUT)
48358
48359C...Double precision and integer declarations.
48360 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48361 IMPLICIT INTEGER(I-N)
48362 INTEGER PYK,PYCHGE,PYCOMP
48363
48364C...Local variables.
48365 DOUBLE PRECISION R
48366 DOUBLE PRECISION TOL
48367 EXTERNAL PYALPS
48368 DOUBLE PRECISION PYALPS
48369 DATA TOL/0.001D0/
48370 DATA R/0.61803399D0/
48371
48372 C=1D0-R
48373
48374 BX=RGUT*PYALPS(RGUT**2)
48375 AX=MIN(50D0,BX*0.5D0)
48376 CX=MAX(2000D0,2D0*BX)
48377
48378 X0=AX
48379 X3=CX
48380 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48381 X1=BX
48382 X2=BX+C*(CX-BX)
48383 ELSE
48384 X2=BX
48385 X1=BX-C*(BX-AX)
48386 ENDIF
48387 AS1=PYALPS(X1**2)
48388 F1=ABS(X1-RGUT*AS1)
48389 AS2=PYALPS(X2**2)
48390 F2=ABS(X2-RGUT*AS2)
48391 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48392 IF(F2.LT.F1) THEN
48393 X0=X1
48394 X1=X2
48395 X2=R*X1+C*X3
48396 F1=F2
48397 AS2=PYALPS(X2**2)
48398 F2=ABS(X2-RGUT*AS2)
48399 ELSE
48400 X3=X2
48401 X2=X1
48402 X1=R*X2+C*X0
48403 F2=F1
48404 AS1=PYALPS(X1**2)
48405 F1=ABS(X1-RGUT*AS1)
48406 ENDIF
48407 GOTO 100
48408 ENDIF
48409 IF(F1.LT.F2) THEN
48410 PYRNM3=X1
48411 XMIN=X1
48412 ELSE
48413 PYRNM3=X2
48414 XMIN=X2
48415 ENDIF
48416
48417 RETURN
48418 END
48419
48420C*********************************************************************
48421
48422C...PYEIG4
48423C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
48424C...Specific application: mixing in neutralino sector.
48425
48426 SUBROUTINE PYEIG4(A,W,Z)
48427
48428C...Double precision and integer declarations.
48429 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48430 IMPLICIT INTEGER(I-N)
48431 INTEGER PYK,PYCHGE,PYCOMP
48432
48433C...Arrays: in call and local.
48434 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
48435
48436C...Coefficients of fourth-degree equation from matrix.
48437C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
48438 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
48439 B2=0D0
48440 DO 110 I=1,3
48441 DO 100 J=I+1,4
48442 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
48443 100 CONTINUE
48444 110 CONTINUE
48445 B1=0D0
48446 B0=0D0
48447 DO 120 I=1,4
48448 I1=MOD(I,4)+1
48449 I2=MOD(I+1,4)+1
48450 I3=MOD(I+2,4)+1
48451 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
48452 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
48453 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
48454 B0=B0+(-1D0)**(I+1)*A(1,I)*(
48455 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
48456 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
48457 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
48458 120 CONTINUE
48459
48460C...Coefficients of third-degree equation needed for
48461C...separation into two second-degree equations.
48462C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
48463 C2=-B2
48464 C1=B1*B3-4D0*B0
48465 C0=-B1**2-B0*B3**2+4D0*B0*B2
48466 CQ=C1/3D0-C2**2/9D0
48467 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
48468 CQR=CQ**3+CR**2
48469
48470C...Cases with one or three real roots.
48471 IF(CQR.GE.0D0) THEN
48472 S1=(CR+SQRT(CQR))**(1D0/3D0)
48473 S2=(CR-SQRT(CQR))**(1D0/3D0)
48474 U=S1+S2-C2/3D0
48475 ELSE
48476 SABS=SQRT(-CQ)
48477 THE=ACOS(CR/SABS**3)/3D0
48478 SRE=SABS*COS(THE)
48479 U=2D0*SRE-C2/3D0
48480 ENDIF
48481
48482C...Find and solve two second-degree equations.
48483 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
48484 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
48485 Q1=U/2D0+SQRT(U**2/4D0-B0)
48486 Q2=U/2D0-SQRT(U**2/4D0-B0)
48487 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
48488 QSAV=Q1
48489 Q1=Q2
48490 Q2=QSAV
48491 ENDIF
48492 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
48493 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
48494 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
48495 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
48496
48497C...Order eigenvalues in asceding mass.
48498 W(1)=X(1)
48499 DO 150 I1=2,4
48500 DO 130 I2=I1-1,1,-1
48501 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
48502 W(I2+1)=W(I2)
48503 130 CONTINUE
48504 140 W(I2+1)=X(I1)
48505 150 CONTINUE
48506
48507C...Find equation system for eigenvectors.
48508 DO 250 I=1,4
48509 DO 170 J1=1,4
48510 D(J1,J1)=A(J1,J1)-W(I)
48511 DO 160 J2=J1+1,4
48512 D(J1,J2)=A(J1,J2)
48513 D(J2,J1)=A(J2,J1)
48514 160 CONTINUE
48515 170 CONTINUE
48516
48517C...Find largest element in matrix.
48518 DAMAX=0D0
48519 DO 190 J1=1,4
48520 DO 180 J2=1,4
48521 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
48522 JA=J1
48523 JB=J2
48524 DAMAX=ABS(D(J1,J2))
48525 180 CONTINUE
48526 190 CONTINUE
48527
48528C...Subtract others by multiple of row selected above.
48529 DAMAX=0D0
48530 DO 210 J3=JA+1,JA+3
48531 J1=J3-4*((J3-1)/4)
48532 RL=D(J1,JB)/D(JA,JB)
48533 DO 200 J2=1,4
48534 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
48535 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
48536 JC=J1
48537 JD=J2
48538 DAMAX=ABS(D(J1,J2))
48539 200 CONTINUE
48540 210 CONTINUE
48541
48542C...Do one more subtraction of a row.
48543 DAMAX=0D0
48544 DO 230 J3=JC+1,JC+3
48545 J1=J3-4*((J3-1)/4)
48546 IF(J1.EQ.JA) GOTO 230
48547 RL=D(J1,JD)/D(JC,JD)
48548 DO 220 J2=1,4
48549 IF(J2.EQ.JB) GOTO 220
48550 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
48551 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
48552 JE=J1
48553 DAMAX=ABS(D(J1,J2))
48554 220 CONTINUE
48555 230 CONTINUE
48556
48557C...Construct unnormalized eigenvector.
48558 JF1=JD+1-4*(JD/4)
48559 JF2=JD+2-4*((JD+1)/4)
48560 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
48561 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
48562 E(JF1)=-D(JE,JF2)
48563 E(JF2)=D(JE,JF1)
48564 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
48565 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
48566 & D(JA,JB)
48567
48568C...Normalize and fill in final array.
48569 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
48570 SGN=(-1D0)**INT(PYR(0)+0.5D0)
48571 DO 240 J=1,4
48572 Z(I,J)=SGN*E(J)/EA
48573 240 CONTINUE
48574 250 CONTINUE
48575
48576 RETURN
48577 END
48578
48579C*********************************************************************
48580
48581C...PYHGGM
48582C...Determines the Higgs boson mass spectrum using several inputs.
48583
48584 SUBROUTINE PYHGGM(ALPHA)
48585
48586C...Double precision and integer declarations.
48587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48588 IMPLICIT INTEGER(I-N)
48589 INTEGER PYK,PYCHGE,PYCOMP
48590C...Parameter statement to help give large particle numbers.
48591 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48592 &KEXCIT=4000000,KDIMEN=5000000)
48593C...Commonblocks.
48594 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48595 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48596 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
48597 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48598 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
48599
48600C...Local variables.
48601 DOUBLE PRECISION AT,AB,XMU,TANB
48602 DOUBLE PRECISION ALPHA
48603 INTEGER IHOPT
48604 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
48605 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
48606 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
48607 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
48608
48609 IHOPT=IMSS(4)
48610 IF(IHOPT.EQ.2) THEN
48611 ALPHA=RMSS(18)
48612 RETURN
48613 ENDIF
48614 AT=RMSS(16)
48615 AB=RMSS(15)
48616 DMGL=RMSS(3)
48617 XMU=RMSS(4)
48618 TANB=RMSS(5)
48619
48620 DMA=RMSS(19)
48621 DTANB=TANB
48622 DMQ=RMSS(10)
48623 DMUR=RMSS(12)
48624 DMDR=RMSS(11)
48625 DMTOP=PMAS(6,1)
48626 DMC=PMAS(PYCOMP(KSUSY1+37),1)
48627 DAU=AT
48628 DAD=AB
48629 DMU=XMU
48630 RMSS(40)=0D0
48631 RMSS(41)=0D0
48632
48633 IF(IHOPT.EQ.0) THEN
48634 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48635 & DMHCH,DSA,DCA,DTANBA)
48636 ELSEIF(IHOPT.EQ.1) THEN
48637 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
48638 & DMHCH,DSA,DCA,DTANBA)
48639 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
48640 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
48641 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
48642 RMSS(40)=DDT
48643 RMSS(41)=DDB
48644 DMH=DMHP
48645 DHM=DHMP
48646 DMA=DAMP
48647 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
48648 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
48649 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
48650 & PMAS(PYCOMP(1000006),1),DSTOP2
48651 ENDIF
48652 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
48653 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
48654 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
48655 & PMAS(PYCOMP(2000006),1),DSTOP1
48656 ENDIF
48657 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
48658 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
48659 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
48660 & PMAS(PYCOMP(1000005),1),DSBOT2
48661 ENDIF
48662 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
48663 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
48664 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
48665 & PMAS(PYCOMP(2000005),1),DSBOT1
48666 ENDIF
48667
48668 ELSEIF (IHOPT.EQ.3) THEN
48669c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
48670C...Currently only available for SLHA spectrum read-in.
48671 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
48672 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
48673 & //' spectrum, change IMSS(1) or IMSS(4) option.')
48674 ENDIF
48675 ALPHA=RMSS(18)
48676 RETURN
48677 ENDIF
48678
48679 ALPHA=ACOS(DCA)
48680
48681 PMAS(25,1)=DMH
48682 PMAS(35,1)=DHM
48683 PMAS(36,1)=DMA
48684 PMAS(37,1)=DMHCH
48685
48686 RETURN
48687 END
48688
48689C*********************************************************************
48690
48691C...PYSUBH
48692C...This routine computes the renormalization group improved
48693C...values of Higgs masses and couplings in the MSSM.
48694
48695C...Program based on the work by M. Carena, J.R. Espinosa,
48696c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
48697
48698C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
48699C...All masses in GeV units. MA is the CP-odd Higgs mass,
48700C...MTOP is the physical top mass, MQ and MUR are the soft
48701C...supersymmetry breaking mass parameters of left handed
48702C...and right handed stops respectively, AU and AD are the
48703C...stop and sbottom trilinear soft breaking terms,
48704C...respectively, and MU is the supersymmetric
48705C...Higgs mass parameter. We use the conventions from
48706C...the physics report of Haber and Kane: left right
48707C...stop mixing term proportional to (AU - MU/TANB)
48708C...We use as input TANB defined at the scale MTOP
48709
48710C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
48711C...where MH and HM are the lightest and heaviest CP-even
48712C...Higgs masses, MHCH is the charged Higgs mass and
48713C...ALPHA is the Higgs mixing angle
48714C...TANBA is the angle TANB at the CP-odd Higgs mass scale
48715
48716C...Range of validity:
48717C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
48718C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
48719C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
48720C...are the sbottom mass eigenvalues, respectively. This
48721C...range automatically excludes the existence of tachyons.
48722C...For the charged Higgs mass computation, the method is
48723C...valid if
48724C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
48725C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
48726C...where M_SUSY**2 is the average of the squared stop mass
48727C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
48728C...masses have been assumed to be of order of the stop ones
48729C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
48730
48731 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
48732 &XMHCH,SA,CA,TANBA)
48733
48734C...Double precision and integer declarations.
48735 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48736 IMPLICIT INTEGER(I-N)
48737 INTEGER PYK,PYCHGE,PYCOMP
48738C...Parameter statement to help give large particle numbers.
48739 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48740 &KEXCIT=4000000,KDIMEN=5000000)
48741C...Commonblocks.
48742 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48743 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48744 COMMON/PYHTRI/HHH(7)
48745 SAVE /PYDAT1/,/PYDAT2/
48746
48747C...Local variables.
48748 DOUBLE PRECISION PYALEM,PYALPS
48749 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
48750 DOUBLE PRECISION XMHCH,SA,CA
48751 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
48752 DOUBLE PRECISION Q02
48753 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
48754 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
48755 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
48756 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
48757 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
48758 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
48759 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
48760 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
48761
48762 XMZ = PMAS(23,1)
48763 Q02=XMZ**2
48764 AEM=PYALEM(Q02)
48765 ALP1=AEM/(1D0-PARU(102))
48766 ALP2=AEM/PARU(102)
48767 ALPH3Z=PYALPS(Q02)
48768
48769 ALP1 = 0.0101D0
48770 ALP2 = 0.0337D0
48771 ALPH3Z = 0.12D0
48772
48773 V = 174.1D0
48774 PI = PARU(1)
48775 TANBA = TANB
48776 TANBT = TANB
48777
48778C...MBOTTOM(MTOP) = 3. GEV
48779 XMB = PYMRUN(5,XMTOP**2)
48780 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
48781 &LOG(XMTOP**2/XMZ**2))
48782
48783C...RMTOP= RUNNING TOP QUARK MASS
48784 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
48785 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
48786 T = LOG(XMS**2/XMTOP**2)
48787 SINB = TANB/((1D0 + TANB**2)**0.5D0)
48788 COSB = SINB/TANB
48789C...IF(MA.LE.XMTOP) TANBA = TANBT
48790 IF(XMA.GT.XMTOP)
48791 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
48792 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
48793 &LOG(XMA**2/XMTOP**2))
48794
48795 SINBT = TANBT/SQRT(1D0 + TANBT**2)
48796 COSBT = 1D0/SQRT(1D0 + TANBT**2)
48797C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
48798 G1 = SQRT(ALP1*4D0*PI)
48799 G2 = SQRT(ALP2*4D0*PI)
48800 G3 = SQRT(ALP3*4D0*PI)
48801 HU = RMTOP/V/SINBT
48802 HD = XMB/V/COSBT
48803 HU2=HU*HU
48804 HD2=HD*HD
48805 HU4=HU2*HU2
48806 HD4=HD2*HD2
48807 AU2=AU**2
48808 AD2=AD**2
48809 XMS2=XMS**2
48810 XMS3=XMS**3
48811 XMS4=XMS2*XMS2
48812 XMU2=XMU*XMU
48813 PI2=PI*PI
48814
48815 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
48816 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
48817 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
48818 &+ 3D0*(AU + AD)**2/XMS2)/6D0
48819 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
48820 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
48821 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
48822 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
48823 &- 16D0*G3**2) *T/16D0/PI2)
48824 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
48825 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
48826 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
48827 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
48828 &- 16D0*G3**2) *T/16D0/PI2)
48829 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
48830 &(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)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
48835 &- 16D0*G3**2) *T/16D0/PI2)
48836 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48837 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
48838 &- 16D0*G3**2) *T/16D0/PI2)
48839 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
48840 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
48841 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
48842 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
48843 &XMS4)*
48844 &(1+ (6D0*HU2 -2D0* HD2
48845 &- 16D0*G3**2) *T/16D0/PI2)
48846 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
48847 &XMS4)*
48848 &(1+ (6D0*HD2 -2D0* HU2/2D0
48849 &- 16D0*G3**2) *T/16D0/PI2)
48850 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
48851 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
48852 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
48853 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
48854 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
48855 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48856 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
48857 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48858 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
48859 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48860 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
48861 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
48862 HHH(1)=XLAM1
48863 HHH(2)=XLAM2
48864 HHH(3)=XLAM3
48865 HHH(4)=XLAM4
48866 HHH(5)=XLAM5
48867 HHH(6)=XLAM6
48868 HHH(7)=XLAM7
48869 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
48870 &2D0* XLAM6*SINBT*COSBT
48871 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
48872 &+ XLAM5*COSBT**2)
48873 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
48874 &XLAM6*COSBT**2
48875 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
48876 &2D0* XLAM6* COSBT*SINBT
48877 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48878 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
48879 &((XLAM1* COSBT**2 +2D0*
48880 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
48881 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
48882 &*SINBT**2
48883 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
48884 &+ XLAM4) + XLAM6*COSBT**2
48885 &+ XLAM7* SINBT**2))
48886
48887 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
48888 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
48889 XHM = SQRT(XHM2)
48890 XMH = SQRT(XMH2)
48891 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
48892 XMHCH = SQRT(XMHCH2)
48893
48894 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48895 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48896 &XLAM6* COSBT*SINBT
48897 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48898 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48899 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
48900 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
48901
48902 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
48903 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
48904 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
48905 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
48906 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
48907 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
48908 &XLAM6* COSBT*SINBT
48909 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
48910 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
48911 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
48912
48913 SA = -SINALP
48914 CA = -COSALP
48915
48916 100 CONTINUE
48917
48918 RETURN
48919 END
48920
48921C*********************************************************************
48922
48923C...PYPOLE
48924C...This subroutine computes the CP-even higgs and CP-odd pole
48925c...Higgs masses and mixing angles.
48926
48927C...Program based on the work by M. Carena, M. Quiros
48928C...and C.E.M. Wagner, "Effective potential methods and
48929C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
48930
48931C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
48932C...AT,AB,MU
48933C...where MCHI is the largest chargino mass, MA is the running
48934C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
48935C...expectaion values at the scale MTOP, MQ is the third generation
48936C...left handed squark mass parameter, MUR is the third generation
48937C...right handed stop mass parameter, MDR is the third generation
48938C...right handed sbottom mass parameter, MTOP is the pole top quark
48939C...mass; AT,AB are the soft supersymmetry breaking trilinear
48940C...couplings of the stop and sbottoms, respectively, and MU is the
48941C...supersymmetric mass parameter
48942
48943C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
48944C...Higgses whose pole mass is computed. If IHIGGS=0 only running
48945C...masses are given, what makes the running of the program
48946c...much faster and it is quite generally a good approximation
48947c...(for a theoretical discussion see ref. above). If IHIGGS=1,
48948C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
48949c...and if IHIGGS=3, then h,H,A polarizations are computed
48950
48951C...Output: MH and MHP which are the lightest CP-even Higgs running
48952C...and pole masses, respectively; HM and HMP are the heaviest CP-even
48953C...Higgs running and pole masses, repectively; SA and CA are the
48954C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
48955C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
48956C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
48957C...the value of TANB at the CP-odd Higgs mass scale
48958
48959C...This subroutine makes use of CERN library subroutine
48960C...integration package, which makes the computation of the
48961C...pole Higgs masses somewhat faster. We thank P. Janot for this
48962C...improvement. Those who are not able to call the CERN
48963C...libraries, please use the subroutine SUBHPOLE2.F, which
48964C...although somewhat slower, gives identical results
48965
48966 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
48967 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
48968
48969C...Double precision and integer declarations.
48970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48971 IMPLICIT INTEGER(I-N)
48972
48973C...Parameters.
48974 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48975 SAVE /PYDAT1/
48976 INTEGER PYK,PYCHGE,PYCOMP
48977
48978C...Local variables.
48979 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
48980 &SSBOT2(2),B(2,2),COUPB(2,2),
48981 &HCOUPT(2,2),HCOUPB(2,2),
48982 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
48983
48984 DELTA(1,1) = 1D0
48985 DELTA(2,2) = 1D0
48986 DELTA(1,2) = 0D0
48987 DELTA(2,1) = 0D0
48988 V = 174.1D0
48989 XMZ=91.18D0
48990 PI=PARU(1)
48991 RXMT=PYMRUN(6,XMT**2)
48992 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
48993 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
48994
48995 SINB = TANB/(TANB**2+1D0)**0.5D0
48996 COSB = 1D0/(TANB**2+1D0)**0.5D0
48997 COS2B = SINB**2 - COSB**2
48998 SINBPA = SINB*CA + COSB*SA
48999 COSBPA = COSB*CA - SINB*SA
49000 RMBOT = PYMRUN(5,XMT**2)
49001 XMQ2 = XMQ**2
49002 XMUR2 = XMUR**2
49003 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49004 XMDR2 = XMDR**2
49005 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49006 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49007 IF(XMST11.LT.0D0) GOTO 500
49008 IF(XMST22.LT.0D0) GOTO 500
49009 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49010 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49011 IF(XMSB11.LT.0D0) GOTO 500
49012 IF(XMSB22.LT.0D0) GOTO 500
49013C WMST11 = RXMT**2 + XMQ2
49014C WMST22 = RXMT**2 + XMUR2
49015 XMST12 = RXMT*(AT - XMU/TANB)
49016 XMSB12 = RMBOT*(AB - XMU*TANB)
49017
49018CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49019C...STOP EIGENVALUES CALCULATION
49020CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49021
49022 STOP12 = 0.5D0*(XMST11+XMST22) +
49023 &0.5D0*((XMST11+XMST22)**2 -
49024 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49025 STOP22 = 0.5D0*(XMST11+XMST22) -
49026 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49027 &XMST12**2))**0.5D0
49028
49029 IF(STOP22.LT.0D0) GOTO 500
49030 SSTOP2(1) = STOP12
49031 SSTOP2(2) = STOP22
49032 STOP1 = STOP12**0.5D0
49033 STOP2 = STOP22**0.5D0
49034C STOP1W = STOP1
49035C STOP2W = STOP2
49036
49037 IF(XMST12.EQ.0D0) XST11 = 1D0
49038 IF(XMST12.EQ.0D0) XST12 = 0D0
49039 IF(XMST12.EQ.0D0) XST21 = 0D0
49040 IF(XMST12.EQ.0D0) XST22 = 1D0
49041
49042 IF(XMST12.EQ.0D0) GOTO 110
49043
49044 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49045 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49046 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49047 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49048
49049 110 T(1,1) = XST11
49050 T(2,2) = XST22
49051 T(1,2) = XST12
49052 T(2,1) = XST21
49053
49054 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49055 &0.5D0*((XMSB11+XMSB22)**2 -
49056 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49057 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49058 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49059 &XMSB12**2))**0.5D0
49060 IF(SBOT22.LT.0D0) GOTO 500
49061 SBOT1 = SBOT12**0.5D0
49062 SBOT2 = SBOT22**0.5D0
49063
49064 SSBOT2(1) = SBOT12
49065 SSBOT2(2) = SBOT22
49066
49067 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49068 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49069 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49070 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49071
49072 IF(XMSB12.EQ.0D0) GOTO 130
49073
49074 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49075 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49076 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49077 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49078
49079 130 B(1,1) = XSB11
49080 B(2,2) = XSB22
49081 B(1,2) = XSB12
49082 B(2,1) = XSB21
49083
49084
49085 SINT = 0.2320D0
49086 SQR = DSQRT(2D0)
49087 VP = 174.1D0*SQR
49088
49089CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49090C...STARTING OF LIGHT HIGGS
49091CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49092
49093 IF(IHIGGS.EQ.0) GOTO 490
49094
49095 DO 150 I = 1,2
49096 DO 140 J = 1,2
49097 COUPT(I,J) =
49098 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49099 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49100 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49101 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49102 & T(1,J)*T(2,I))
49103 140 CONTINUE
49104 150 CONTINUE
49105
49106
49107 DO 170 I = 1,2
49108 DO 160 J = 1,2
49109 COUPB(I,J) =
49110 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49111 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49112 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49113 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49114 & B(1,J)*B(2,I))
49115 160 CONTINUE
49116 170 CONTINUE
49117
49118 PRUN = XMH
49119 EPS = 1D-4*PRUN
49120 ITER = 0
49121 180 ITER = ITER + 1
49122 DO 230 I3 = 1,3
49123
49124 PR(I3)=PRUN+(I3-2)*EPS/2
49125 P2=PR(I3)**2
49126 POLT = 0D0
49127 DO 200 I = 1,2
49128 DO 190 J = 1,2
49129 POLT = POLT + COUPT(I,J)**2*3D0*
49130 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49131 190 CONTINUE
49132 200 CONTINUE
49133
49134 POLB = 0D0
49135 DO 220 I = 1,2
49136 DO 210 J = 1,2
49137 POLB = POLB + COUPB(I,J)**2*3D0*
49138 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49139 210 CONTINUE
49140 220 CONTINUE
49141C RXMT2 = RXMT**2
49142 XMT2=XMT**2
49143
49144 POLTT =
49145 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49146 & CA**2/SINB**2 *
49147 & (-2D0*XMT**2+0.5D0*P2)*
49148 & PYFINT(P2,XMT2,XMT2)
49149
49150 POL = POLT + POLB + POLTT
49151 POLAR(I3) = P2 - XMH**2 - POL
49152 230 CONTINUE
49153 DERIV = (POLAR(3)-POLAR(1))/EPS
49154 DRUN = - POLAR(2)/DERIV
49155 PRUN = PRUN + DRUN
49156 P2 = PRUN**2
49157 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49158 GOTO 180
49159 240 CONTINUE
49160
49161 XMHP = DSQRT(P2)
49162
49163CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49164C...END OF LIGHT HIGGS
49165CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49166
49167 250 IF(IHIGGS.EQ.1) GOTO 490
49168
49169CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49170C... STARTING OF HEAVY HIGGS
49171CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49172
49173 DO 270 I = 1,2
49174 DO 260 J = 1,2
49175 HCOUPT(I,J) =
49176 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49177 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49178 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49179 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49180 & T(1,J)*T(2,I))
49181 260 CONTINUE
49182 270 CONTINUE
49183
49184 DO 290 I = 1,2
49185 DO 280 J = 1,2
49186 HCOUPB(I,J) =
49187 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49188 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49189 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49190 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49191 & B(1,J)*B(2,I))
49192 HCOUPB(I,J)=0D0
49193 280 CONTINUE
49194 290 CONTINUE
49195
49196 PRUN = HM
49197 EPS = 1D-4*PRUN
49198 ITER = 0
49199 300 ITER = ITER + 1
49200 DO 350 I3 = 1,3
49201 PR(I3)=PRUN+(I3-2)*EPS/2
49202 HP2=PR(I3)**2
49203
49204 HPOLT = 0D0
49205 DO 320 I = 1,2
49206 DO 310 J = 1,2
49207 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
49208 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49209 310 CONTINUE
49210 320 CONTINUE
49211
49212 HPOLB = 0D0
49213 DO 340 I = 1,2
49214 DO 330 J = 1,2
49215 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
49216 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49217 330 CONTINUE
49218 340 CONTINUE
49219
49220C RXMT2 = RXMT**2
49221 XMT2 = XMT**2
49222
49223 HPOLTT =
49224 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49225 & SA**2/SINB**2 *
49226 & (-2D0*XMT**2+0.5D0*HP2)*
49227 & PYFINT(HP2,XMT2,XMT2)
49228
49229 HPOL = HPOLT + HPOLB + HPOLTT
49230 POLAR(I3) =HP2-HM**2-HPOL
49231 350 CONTINUE
49232 DERIV = (POLAR(3)-POLAR(1))/EPS
49233 DRUN = - POLAR(2)/DERIV
49234 PRUN = PRUN + DRUN
49235 HP2 = PRUN**2
49236 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
49237 GOTO 300
49238 360 CONTINUE
49239
49240
49241 370 CONTINUE
49242 HMP = HP2**0.5D0
49243
49244CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49245C... END OF HEAVY HIGGS
49246CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49247
49248 IF(IHIGGS.EQ.2) GOTO 490
49249
49250CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49251C...BEGINNING OF PSEUDOSCALAR HIGGS
49252CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49253
49254 DO 390 I = 1,2
49255 DO 380 J = 1,2
49256 ACOUPT(I,J) =
49257 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
49258 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
49259 380 CONTINUE
49260 390 CONTINUE
49261 DO 410 I = 1,2
49262 DO 400 J = 1,2
49263 ACOUPB(I,J) =
49264 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
49265 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
49266 400 CONTINUE
49267 410 CONTINUE
49268
49269 PRUN = XMA
49270 EPS = 1D-4*PRUN
49271 ITER = 0
49272 420 ITER = ITER + 1
49273 DO 470 I3 = 1,3
49274 PR(I3)=PRUN+(I3-2)*EPS/2
49275 AP2=PR(I3)**2
49276 APOLT = 0D0
49277 DO 440 I = 1,2
49278 DO 430 J = 1,2
49279 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
49280 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49281 430 CONTINUE
49282 440 CONTINUE
49283 APOLB = 0D0
49284 DO 460 I = 1,2
49285 DO 450 J = 1,2
49286 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
49287 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49288 450 CONTINUE
49289 460 CONTINUE
49290C RXMT2 = RXMT**2
49291 XMT2=XMT**2
49292 APOLTT =
49293 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49294 & COSB**2/SINB**2 *
49295 & (-0.5D0*AP2)*
49296 & PYFINT(AP2,XMT2,XMT2)
49297 APOL = APOLT + APOLB + APOLTT
49298 POLAR(I3) = AP2 - XMA**2 -APOL
49299 470 CONTINUE
49300 DERIV = (POLAR(3)-POLAR(1))/EPS
49301 DRUN = - POLAR(2)/DERIV
49302 PRUN = PRUN + DRUN
49303 AP2 = PRUN**2
49304 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
49305 GOTO 420
49306 480 CONTINUE
49307
49308 AMP = DSQRT(AP2)
49309
49310CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49311C...END OF PSEUDOSCALAR HIGGS
49312CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49313
49314 IF(IHIGGS.EQ.3) GOTO 490
49315
49316 490 CONTINUE
49317 RETURN
49318 500 CONTINUE
49319 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
49320 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
49321 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
49322 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
49323 CALL PYSTOP(107)
49324 END
49325
49326C*********************************************************************
49327
49328C...PYRGHM
49329C...Auxiliary to PYPOLE.
49330
49331 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
49332 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
49333 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
49334 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
49335C...Parameters.
49336 INTEGER MSTU,MSTJ
49337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49338 SAVE /PYDAT1/
49339
49340 MZ = 91.18D0
49341 PI = PARU(1)
49342 V = 174.1D0
49343 ALPHA1 = 0.0101D0
49344 ALPHA2 = 0.0337D0
49345 ALPHA3Z = 0.12D0
49346 TANBA = TANB
49347 TANBT = TANB
49348C MBOTTOM(MTOP) = 3. GEV
49349 MB = PYMRUN(5,MTOP**2)
49350 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
49351 *LOG(MTOP**2/MZ**2))
49352C RMTOP= RUNNING TOP QUARK MASS
49353 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49354 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
49355 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
49356 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
49357CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49358C
49359C NEW DEFINITION, TGLU.
49360C
49361CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49362 TGLU = LOG(MGLU**2/MTOP**2)
49363 SINB = TANB/DSQRT(1D0 + TANB**2)
49364 COSB = SINB/TANB
49365 IF(MA.GT.MTOP)
49366 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
49367 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
49368 *LOG(MA**2/MTOP**2))
49369 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
49370 SINB = TANBT/SQRT(1D0 + TANBT**2)
49371 COSB = 1D0/DSQRT(1D0 + TANBT**2)
49372 G1 = SQRT(ALPHA1*4D0*PI)
49373 G2 = SQRT(ALPHA2*4D0*PI)
49374 G3 = SQRT(ALPHA3*4D0*PI)
49375 HU = RMTOP/V/SINB
49376 HD = MB/V/COSB
49377 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
49378 *SBOT1,SBOT2,DELTAMT,DELTAMB)
49379 IF(MQ.GT.MUR) TP = TQ - TU
49380 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
49381 IF(MQ.GT.MUR) TDP = TU
49382 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
49383 IF(MQ.GT.MD) TPD = TQ - TD
49384 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
49385 IF(MQ.GT.MD) TDPD = TD
49386 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
49387
49388 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
49389 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
49390 * HD**2*(G1**2/3D0+G2**2)*TPD
49391
49392 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
49393 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
49394 * HU**2*(-G1**2/3D0+G2**2)*TP
49395
49396CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49397C
49398C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
49399C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
49400C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
49401C TWO STOPS.
49402C
49403C
49404CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49405
49406 DLAMBDAP2 = 0D0
49407 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
49408 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
49409 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
49410 ENDIF
49411
49412 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
49413 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49414 ENDIF
49415
49416 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
49417 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
49418 ENDIF
49419
49420 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
49421 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
49422 ENDIF
49423
49424 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
49425 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49426 ENDIF
49427
49428 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
49429 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
49430 ENDIF
49431 ENDIF
49432 DLAMBDA3 = 0D0
49433 DLAMBDA4 = 0D0
49434 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
49435 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
49436 *(G2**2-G1**2/3D0)*TPD
49437 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
49438 *1D0/16D0/PI**2*G1**2*HU**2*TP
49439 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
49440 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
49441 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
49442 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
49443 *HD**2*TPD
49444 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
49445 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
49446 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
49447 *+ (3D0*HD**2/2D0 + HU**2/2D0
49448 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
49449 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
49450 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
49451 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
49452 *(TP + TDP)/8D0/PI**2)
49453 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
49454 *+ (3D0*HU**2/2D0 + HD**2/2D0
49455 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
49456 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
49457 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
49458 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49459 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
49460 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
49461 LAMBDA4 = (- G2**2/2D0)*(1D0
49462 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
49463 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
49464
49465 LAMBDA5 = 0D0
49466 LAMBDA6 = 0D0
49467 LAMBDA7 = 0D0
49468
49469 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
49470 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
49471
49472 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
49473 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
49474 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
49475 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
49476
49477 M2(2,1) = M2(1,2)
49478CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49479CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
49480CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49481
49482 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
49483
49484 IF(MCHI.GT.MSSUSY) GOTO 100
49485 IF(MCHI.LT.MTOP) MCHI=MTOP
49486
49487 TCHAR=LOG(MSSUSY**2/MCHI**2)
49488
49489 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
49490 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
49491 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
49492
49493 DELTAM112=2D0*DELTAL12*V**2*COSB**2
49494 DELTAM222=2D0*DELTAL12*V**2*SINB**2
49495 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
49496
49497 M2(1,1)=M2(1,1)+DELTAM112
49498 M2(2,2)=M2(2,2)+DELTAM222
49499 M2(1,2)=M2(1,2)+DELTAM122
49500 M2(2,1)=M2(2,1)+DELTAM122
49501
49502 100 CONTINUE
49503
49504CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49505CCC END OF CHARGINOS/NEUTRALINOS
49506CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49507
49508 DO 120 I = 1,2
49509 DO 110 J = 1,2
49510 M2P(I,J) = M2(I,J) + VH(I,J)
49511 110 CONTINUE
49512 120 CONTINUE
49513 TRM2P = M2P(1,1) + M2P(2,2)
49514 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
49515 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49516 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
49517 HMP = DSQRT(HM2P)
49518 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
49519 MCH=DSQRT(MCH2)
49520 IF(MH2P.LT.0.) GOTO 130
49521 MHP = SQRT(MH2P)
49522 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
49523 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
49524 IF(COS2ALPHA.GE.0.) THEN
49525 ALPHA = ASIN(SIN2ALPHA)/2D0
49526 ELSE
49527 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
49528 ENDIF
49529 SA = SIN(ALPHA)
49530 CA = COS(ALPHA)
49531CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49532C
49533C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
49534C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
49535C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
49536C
49537C
49538CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49539 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
49540 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
49541 130 CONTINUE
49542 RETURN
49543 END
49544
49545C*********************************************************************
49546
49547C...PYGFXX
49548C...Auxiliary to PYRGHM.
49549
49550 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
49551 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
49552 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
49553 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
49554C...Commonblocks.
49555 INTEGER MSTU,MSTJ,KCHG
49556 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49557 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49558 SAVE /PYDAT1/,/PYDAT2/
49559
49560 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
49561
49562 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
49563 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
49564
49565 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
49566 MQ2 = MQ**2
49567 MUR2 = MUR**2
49568 MD2 = MD**2
49569 TANBA = TANB
49570 SINBA = TANBA/DSQRT(TANBA**2+1D0)
49571 COSBA = SINBA/TANBA
49572
49573 SINB = TANB/DSQRT(TANB**2+1D0)
49574 COSB = SINB/TANB
49575
49576 PI = PARU(1)
49577 MZ = PMAS(23,1)
49578 MW = PMAS(24,1)
49579 SW = 1D0-MW**2/MZ**2
49580 V = 174.1D0
49581
49582 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
49583 G2 = DSQRT(0.0336D0*4D0*PI)
49584 G1 = DSQRT(0.0101D0*4D0*PI)
49585
49586 IF(MQ.GT.MUR) MST = MQ
49587 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
49588
49589 MSUSYT = DSQRT(MST**2 + MTOP**2)
49590
49591 IF(MQ.GT.MD) MSB = MQ
49592 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
49593
49594 MB = PYMRUN(5,MSB**2)
49595 MSUSYB = DSQRT(MSB**2 + MB**2)
49596 TT = LOG(MSUSYT**2/MTOP**2)
49597 TB = LOG(MSUSYB**2/MTOP**2)
49598
49599 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
49600 HT = RMTOP/(V*SINB)
49601 HTST = RMTOP/V
49602 HB = MB/V/COSB
49603 G32 = ALPHA3*4D0*PI
49604 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
49605 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
49606 AL2 = 3D0/8D0/PI**2*HT**2
49607C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
49608C ALST = 3./8./PI**2*HTST**2
49609 AL1 = 3D0/8D0/PI**2*HB**2
49610
49611 AL(1,1) = AL1
49612 AL(1,2) = (AL2+AL1)/2D0
49613 AL(2,1) = (AL2+AL1)/2D0
49614 AL(2,2) = AL2
49615
49616 IF(MA.GT.MTOP) THEN
49617 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
49618 * LOG(MTOP**2/MA**2))
49619 H1I = VI* COSBA
49620 H2I = VI*SINBA
49621 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
49622 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
49623 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
49624 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
49625 ELSE
49626 VI = V
49627 H1I = VI*COSB
49628 H2I = VI*SINB
49629 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49630 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
49631 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49632 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
49633 ENDIF
49634
49635 TANBST = H2T/H1T
49636 SINBT = TANBST/DSQRT(1D0+TANBST**2)
49637
49638 TANBSB = H2B/H1B
49639 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
49640 COSBB = SINBB/TANBSB
49641
49642 DELTAMT = 0D0
49643 DELTAMB = 0D0
49644
49645 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49646 MTOP2 = DSQRT(MTOP4)
49647 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49648 * /(1D0+DELTAMB)**4
49649 MBOT2 = DSQRT(MBOT4)
49650
49651 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49652 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49653 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49654 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49655 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49656 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49657 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49658 * MQ2 - MUR2)**2*0.25D0
49659 * + MTOP2*(AT-XMU/TANBST)**2)
49660 IF(STOP22.LT.0.) GOTO 120
49661 SBOT12 = (MQ2 + MD2)*.5D0
49662 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49663 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49664 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49665 SBOT22 = (MQ2 + MD2)*.5D0
49666 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49667 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49668 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49669 IF(SBOT22.LT.0.) SBOT22 = 10000D0
49670
49671 STOP1 = DSQRT(STOP12)
49672 STOP2 = DSQRT(STOP22)
49673 SBOT1 = DSQRT(SBOT12)
49674 SBOT2 = DSQRT(SBOT22)
49675
49676CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49677C
49678C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
49679C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
49680C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
49681C INDUCED CORRECTIONS.
49682C
49683CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49684
49685 X=SBOT1
49686 Y=SBOT2
49687 Z=XMGL
49688 IF(X.EQ.Y) X = X - 0.00001D0
49689 IF(X.EQ.Z) X = X - 0.00002D0
49690 IF(Y.EQ.Z) Y = Y - 0.00003D0
49691
49692 T1=T(X,Y,Z)
49693 X=STOP1
49694 Y=STOP2
49695 Z=XMU
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 T2=T(X,Y,Z)
49700 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
49701 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
49702 X=STOP1
49703 Y=STOP2
49704 Z=XMGL
49705 IF(X.EQ.Y) X = X - 0.00001D0
49706 IF(X.EQ.Z) X = X - 0.00002D0
49707 IF(Y.EQ.Z) Y = Y - 0.00003D0
49708 T3=T(X,Y,Z)
49709 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
49710
49711CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49712C
49713C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
49714C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
49715C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
49716C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
49717C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
49718C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
49719C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
49720C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
49721C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
49722C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
49723C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
49724C
49725C
49726CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49727
49728 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
49729 MTOP2 = DSQRT(MTOP4)
49730 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
49731 * /(1D0+DELTAMB)**4
49732 MBOT2 = DSQRT(MBOT4)
49733
49734 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
49735 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49736 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49737 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
49738 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
49739 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
49740 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
49741 * MQ2 - MUR2)**2*0.25D0
49742 * + MTOP2*(AT-XMU/TANBST)**2)
49743
49744 IF(STOP22.LT.0.) GOTO 120
49745 SBOT12 = (MQ2 + MD2)*.5D0
49746 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49747 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49748 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49749 SBOT22 = (MQ2 + MD2)*.5D0
49750 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
49751 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
49752 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
49753 IF(SBOT22.LT.0.) GOTO 120
49754
49755
49756 STOP1 = DSQRT(STOP12)
49757 STOP2 = DSQRT(STOP22)
49758 SBOT1 = DSQRT(SBOT12)
49759 SBOT2 = DSQRT(SBOT22)
49760
49761CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49762CCC D-TERMS
49763CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49764 STW=SW
49765
49766 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
49767 * LOG(STOP1/STOP2)
49768 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
49769 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
49770
49771 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
49772 * LOG(SBOT1/SBOT2)
49773 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
49774 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
49775
49776 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
49777 * (-.5D0*LOG(STOP12/STOP22)
49778 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
49779 * G(STOP12,STOP22))
49780
49781 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
49782 * (.5D0*LOG(SBOT12/SBOT22)
49783 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
49784 * G(SBOT12,SBOT22))
49785
49786 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
49787 * (MQ2+MBOT2)/(MD2+MBOT2))
49788 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
49789 * LOG(SBOT1**2/SBOT2**2)) +
49790 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
49791 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
49792
49793 VH3T(1,1) =
49794 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
49795 * -STOP2**2))**2*G(STOP12,STOP22)
49796
49797 VH3B(1,1)=VH3B(1,1)+
49798 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
49799
49800 VH3T(1,1) = VH3T(1,1) +
49801 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
49802
49803 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
49804 * (MQ2+MTOP2)/(MUR2+MTOP2))
49805 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
49806 * LOG(STOP1**2/STOP2**2)) +
49807 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
49808 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
49809
49810 VH3B(2,2) =
49811 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
49812 * -SBOT2**2))**2*G(SBOT12,SBOT22)
49813
49814 VH3T(2,2)=VH3T(2,2)+
49815 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
49816 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
49817 VH3T(1,2) = -
49818 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
49819 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
49820 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
49821
49822 VH3B(1,2) =
49823 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
49824 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
49825 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
49826
49827
49828 VH3T(1,2)=VH3T(1,2) +
49829 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
49830
49831 VH3B(1,2)=VH3B(1,2) +
49832 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
49833
49834 VH3T(2,1) = VH3T(1,2)
49835 VH3B(2,1) = VH3B(1,2)
49836
49837C TQ = LOG((MQ2 + MTOP2)/MTOP2)
49838C TU = LOG((MUR2+MTOP2)/MTOP2)
49839C TQD = LOG((MQ2 + MB**2)/MB**2)
49840C TD = LOG((MD2+MB**2)/MB**2)
49841
49842 DO 110 I = 1,2
49843 DO 100 J = 1,2
49844 VH(I,J) =
49845 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
49846 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
49847 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
49848 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
49849 100 CONTINUE
49850 110 CONTINUE
49851
49852 GOTO 150
49853 120 DO 140 I =1,2
49854 DO 130 J = 1,2
49855 VH(I,J) = -1D15
49856 130 CONTINUE
49857 140 CONTINUE
49858
49859
49860 150 RETURN
49861 END
49862
49863
49864
49865
49866
49867C*********************************************************************
49868
49869C...PYFINT
49870C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
49871
49872 FUNCTION PYFINT(A,B,C)
49873
49874C...Double precision and integer declarations.
49875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49876 IMPLICIT INTEGER(I-N)
49877 INTEGER PYK,PYCHGE,PYCOMP
49878C...Commonblock.
49879 COMMON/PYINTS/XXM(20)
49880 SAVE/PYINTS/
49881
49882C...Local variables.
49883 EXTERNAL PYFISB
49884 DOUBLE PRECISION PYFISB
49885
49886 XXM(1)=A
49887 XXM(2)=B
49888 XXM(3)=C
49889 XLO=0D0
49890 XHI=1D0
49891 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
49892
49893 RETURN
49894 END
49895
49896C*********************************************************************
49897
49898C...PYFISB
49899C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
49900
49901 FUNCTION PYFISB(X)
49902
49903C...Double precision and integer declarations.
49904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49905 IMPLICIT INTEGER(I-N)
49906 INTEGER PYK,PYCHGE,PYCOMP
49907C...Commonblock.
49908 COMMON/PYINTS/XXM(20)
49909 SAVE/PYINTS/
49910
49911 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
49912 &(X*(XXM(2)-XXM(3))+XXM(3)))
49913
49914 RETURN
49915 END
49916
49917C*********************************************************************
49918
49919C...PYSFDC
49920C...Calculates decays of sfermions.
49921
49922 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
49923
49924C...Double precision and integer declarations.
49925 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49926 IMPLICIT INTEGER(I-N)
49927 INTEGER PYK,PYCHGE,PYCOMP
49928C...Parameter statement to help give large particle numbers.
49929 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49930 &KEXCIT=4000000,KDIMEN=5000000)
49931C...Commonblocks.
49932 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49933 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49934 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49935 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
49936 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
49937 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
49938
49939C...Local variables.
49940 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
49941 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
49942 INTEGER KFIN,KCIN
49943 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
49944 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
49945 DOUBLE PRECISION PYLAMF,XL
49946 DOUBLE PRECISION TANW,XW,AEM,C1,AS
49947 DOUBLE PRECISION AL,AR,BL,BR
49948 DOUBLE PRECISION CH1,CH2,CH3,CH4
49949 DOUBLE PRECISION XMBOT,XMTOP
49950 DOUBLE PRECISION XLAM(0:400)
49951 INTEGER IDLAM(400,3)
49952 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
49953 DOUBLE PRECISION SR2
49954 DOUBLE PRECISION CBETA,SBETA
49955 DOUBLE PRECISION CW
49956 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
49957 DOUBLE PRECISION COSA,SINA,TANB
49958 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
49959 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
49960 INTEGER IG,KF1,KF2
49961 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
49962 DATA IGG/23,25,35,36/
49963 DATA PI/3.141592654D0/
49964 DATA SR2/1.4142136D0/
49965 DATA KFNCHI/1000022,1000023,1000025,1000035/
49966 DATA KFCCHI/1000024,1000037/
49967
49968C...COUNT THE NUMBER OF DECAY MODES
49969 LKNT=0
49970
49971C...NO NU_R DECAYS
49972 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
49973 &KFIN.EQ.KSUSY2+16) RETURN
49974
49975 XMW=PMAS(24,1)
49976 XMW2=XMW**2
49977 XMZ=PMAS(23,1)
49978 XW=PARU(102)
49979 TANW = SQRT(XW/(1D0-XW))
49980 CW=SQRT(1D0-XW)
49981
49982 DO 110 I=1,4
49983 DO 100 J=1,4
49984 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
49985 100 CONTINUE
49986 110 CONTINUE
49987 DO 130 I=1,2
49988 DO 120 J=1,2
49989 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
49990 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
49991 120 CONTINUE
49992 130 CONTINUE
49993
49994C...KCIN
49995 KCIN=PYCOMP(KFIN)
49996C...ILR is 1 for left and 2 for right.
49997 ILR=KFIN/KSUSY1
49998C...IFL is matching non-SUSY flavour.
49999 IFL=MOD(KFIN,KSUSY1)
50000C...IDU is weak isospin, 1 for down and 2 for up.
50001 IDU=2-MOD(IFL,2)
50002
50003 XMI=PMAS(KCIN,1)
50004 XMI2=XMI**2
50005 AEM=PYALEM(XMI2)
50006 AS =PYALPS(XMI2)
50007 C1=AEM/XW
50008 XMI3=XMI**3
50009 EI=KCHG(IFL,1)/3D0
50010
50011 XMBOT=PYMRUN(5,XMI2)
50012 XMTOP=PYMRUN(6,XMI2)
50013
50014 TANB=RMSS(5)
50015 BETA=ATAN(TANB)
50016 ALFA=RMSS(18)
50017 CBETA=COS(BETA)
50018 SBETA=TANB*CBETA
50019 SINA=SIN(ALFA)
50020 COSA=COS(ALFA)
50021 XMU=-RMSS(4)
50022 ATRIT=RMSS(16)
50023 ATRIB=RMSS(15)
50024 ATRIL=RMSS(17)
50025
50026C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50027
50028 IF(IMSS(11).EQ.1) THEN
50029 XMP=RMSS(29)
50030 IDG=39+KSUSY1
50031 XMGR=PMAS(PYCOMP(IDG),1)
50032 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50033 IF(IFL.EQ.5) THEN
50034 XMF=XMBOT
50035 ELSEIF(IFL.EQ.6) THEN
50036 XMF=XMTOP
50037 ELSE
50038 XMF=PMAS(IFL,1)
50039 ENDIF
50040 IF(XMI.GT.XMGR+XMF) THEN
50041 LKNT=LKNT+1
50042 IDLAM(LKNT,1)=IDG
50043 IDLAM(LKNT,2)=IFL
50044 IDLAM(LKNT,3)=0
50045 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50046 ENDIF
50047 ENDIF
50048
50049C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50050
50051C...CHARGED DECAYS:
50052 DO 140 IX=1,2
50053C...DI -> U CHI1-,CHI2-
50054 IF(IDU.EQ.1) THEN
50055 XMFP=PMAS(IFL+1,1)
50056 XMF =PMAS(IFL,1)
50057C...UI -> D CHI1+,CHI2+
50058 ELSE
50059 XMFP=PMAS(IFL-1,1)
50060 XMF =PMAS(IFL,1)
50061 ENDIF
50062 XMJ=SMW(IX)
50063 AXMJ=ABS(XMJ)
50064 IF(XMI.GE.AXMJ+XMFP) THEN
50065 XMA2=XMJ**2
50066 XMB2=XMFP**2
50067 IF(IDU.EQ.2) THEN
50068 IF(IFL.EQ.6) THEN
50069 XMFP=XMBOT
50070 XMF =XMTOP
50071 ELSEIF(IFL.LT.6) THEN
50072 XMF=0D0
50073 XMFP=0D0
50074 ENDIF
50075 CBL=VMIXC(IX,1)
50076 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50077 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50078 CAR=0D0
50079 ELSE
50080 IF(IFL.EQ.5) THEN
50081 XMF =XMBOT
50082 XMFP=XMTOP
50083 ELSEIF(IFL.LT.5) THEN
50084 XMF=0D0
50085 XMFP=0D0
50086 ENDIF
50087 CBL=UMIXC(IX,1)
50088 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50089 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50090 CAR=0D0
50091 ENDIF
50092
50093 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50094 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50095 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50096 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50097 CAL=CALP
50098 CBL=CBLP
50099 CAR=CARP
50100 CBR=CBRP
50101
50102C...F1 -> F` CHI
50103 IF(ILR.EQ.1) THEN
50104 CA=CAL
50105 CB=CBL
50106C...F2 -> F` CHI
50107 ELSE
50108 CA=CAR
50109 CB=CBR
50110 ENDIF
50111 LKNT=LKNT+1
50112 XL=PYLAMF(XMI2,XMA2,XMB2)
50113C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50114 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50115 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50116 IDLAM(LKNT,3)=0
50117 IF(IDU.EQ.1) THEN
50118 IDLAM(LKNT,1)=-KFCCHI(IX)
50119 IDLAM(LKNT,2)=IFL+1
50120 ELSE
50121 IDLAM(LKNT,1)=KFCCHI(IX)
50122 IDLAM(LKNT,2)=IFL-1
50123 ENDIF
50124 ENDIF
50125 140 CONTINUE
50126
50127C...NEUTRAL DECAYS
50128 DO 150 IX=1,4
50129C...DI -> D CHI10
50130 XMF=PMAS(IFL,1)
50131 XMJ=SMZ(IX)
50132 AXMJ=ABS(XMJ)
50133 IF(XMI.GE.AXMJ+XMF) THEN
50134 XMA2=XMJ**2
50135 XMB2=XMF**2
50136 IF(IDU.EQ.1) THEN
50137 IF(IFL.EQ.5) THEN
50138 XMF=XMBOT
50139 ELSEIF(IFL.LT.5) THEN
50140 XMF=0D0
50141 ENDIF
50142 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50143 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50144 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50145 CBR=CAL
50146 ELSE
50147 IF(IFL.EQ.6) THEN
50148 XMF=XMTOP
50149 ELSEIF(IFL.LT.5) THEN
50150 XMF=0D0
50151 ENDIF
50152 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50153 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50154 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50155 CBR=CAL
50156 ENDIF
50157
50158 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50159 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50160 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50161 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50162 CAL=CALP
50163 CBL=CBLP
50164 CAR=CARP
50165 CBR=CBRP
50166
50167C...F1 -> F CHI
50168 IF(ILR.EQ.1) THEN
50169 CA=CAL
50170 CB=CBL
50171C...F2 -> F CHI
50172 ELSE
50173 CA=CAR
50174 CB=CBR
50175 ENDIF
50176 LKNT=LKNT+1
50177 XL=PYLAMF(XMI2,XMA2,XMB2)
50178C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50179 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50180 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50181 IDLAM(LKNT,1)=KFNCHI(IX)
50182 IDLAM(LKNT,2)=IFL
50183 IDLAM(LKNT,3)=0
50184 ENDIF
50185 150 CONTINUE
50186
50187C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50188C...IG=23,25,35,36
50189 DO 160 II=1,4
50190 IG=IGG(II)
50191 IF(ILR.EQ.1) GOTO 160
50192 XMB=PMAS(IG,1)
50193 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50194 IF(XMI.LT.XMSF1+XMB) GOTO 160
50195 IF(IG.EQ.23) THEN
50196 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
50197 BR=EI*XW/CW
50198 BLR=0D0
50199 ELSEIF(IG.EQ.25) THEN
50200 IF(IFL.EQ.5) THEN
50201 XMF=XMBOT
50202 ELSEIF(IFL.EQ.6) THEN
50203 XMF=XMTOP
50204 ELSEIF(IFL.LT.5) THEN
50205 XMF=0D0
50206 ELSE
50207 XMF=PMAS(IFL,1)
50208 ENDIF
50209 IF(IDU.EQ.2) THEN
50210 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50211 & XMF**2/XMW*COSA/SBETA
50212 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50213 & XMF**2/XMW*COSA/SBETA
50214 ELSE
50215 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
50216 & XMF**2/XMW*(-SINA)/CBETA
50217 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
50218 & XMF**2/XMW*(-SINA)/CBETA
50219 ENDIF
50220 IF(IFL.EQ.5) THEN
50221 AT=ATRIB
50222 ELSEIF(IFL.EQ.6) THEN
50223 AT=ATRIT
50224 ELSEIF(IFL.EQ.15) THEN
50225 AT=ATRIL
50226 ELSE
50227 AT=0D0
50228 ENDIF
50229C.........need to complexify
50230 IF(IDU.EQ.2) THEN
50231 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
50232 & AT*COSA)
50233 ELSE
50234 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
50235 & AT*SINA)
50236 ENDIF
50237 BL=GHLL
50238 BR=GHRR
50239 BLR=-GHLR
50240 ELSEIF(IG.EQ.35) THEN
50241 IF(IFL.EQ.5) THEN
50242 XMF=XMBOT
50243 ELSEIF(IFL.EQ.6) THEN
50244 XMF=XMTOP
50245 ELSEIF(IFL.LT.5) THEN
50246 XMF=0D0
50247 ELSE
50248 XMF=PMAS(IFL,1)
50249 ENDIF
50250 IF(IDU.EQ.2) THEN
50251 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50252 & XMF**2/XMW*SINA/SBETA
50253 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50254 & XMF**2/XMW*SINA/SBETA
50255 ELSE
50256 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
50257 & XMF**2/XMW*COSA/CBETA
50258 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
50259 & XMF**2/XMW*COSA/CBETA
50260 ENDIF
50261 IF(IFL.EQ.5) THEN
50262 AT=ATRIB
50263 ELSEIF(IFL.EQ.6) THEN
50264 AT=ATRIT
50265 ELSEIF(IFL.EQ.15) THEN
50266 AT=ATRIL
50267 ELSE
50268 AT=0D0
50269 ENDIF
50270C.........Need to complexify
50271 IF(IDU.EQ.2) THEN
50272 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
50273 & AT*SINA)
50274 ELSE
50275 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
50276 & AT*COSA)
50277 ENDIF
50278 BL=GHLL
50279 BR=GHRR
50280 BLR=GHLR
50281 ELSEIF(IG.EQ.36) THEN
50282 GHLL=0D0
50283 GHRR=0D0
50284 IF(IFL.EQ.5) THEN
50285 XMF=XMBOT
50286 ELSEIF(IFL.EQ.6) THEN
50287 XMF=XMTOP
50288 ELSEIF(IFL.LT.5) THEN
50289 XMF=0D0
50290 ELSE
50291 XMF=PMAS(IFL,1)
50292 ENDIF
50293 IF(IFL.EQ.5) THEN
50294 AT=ATRIB
50295 ELSEIF(IFL.EQ.6) THEN
50296 AT=ATRIT
50297 ELSEIF(IFL.EQ.15) THEN
50298 AT=ATRIL
50299 ELSE
50300 AT=0D0
50301 ENDIF
50302C.........Need to complexify
50303 IF(IDU.EQ.2) THEN
50304 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
50305 ELSE
50306 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
50307 ENDIF
50308 BL=GHLL
50309 BR=GHRR
50310 BLR=GHLR
50311 ENDIF
50312 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
50313 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
50314 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
50315 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50316 LKNT=LKNT+1
50317 IF(IG.EQ.23) THEN
50318 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50319 ELSE
50320 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
50321 ENDIF
50322 IDLAM(LKNT,3)=0
50323 IDLAM(LKNT,1)=KFIN-KSUSY1
50324 IDLAM(LKNT,2)=IG
50325 160 CONTINUE
50326
50327C...SF -> SF' + W
50328 XMB=PMAS(24,1)
50329 IF(MOD(IFL,2).EQ.0) THEN
50330 KF1=KSUSY1+IFL-1
50331 ELSE
50332 KF1=KSUSY1+IFL+1
50333 ENDIF
50334 KF2=KF1+KSUSY1
50335 XMSF1=PMAS(PYCOMP(KF1),1)
50336 XMSF2=PMAS(PYCOMP(KF2),1)
50337 IF(XMI.GT.XMB+XMSF1) THEN
50338 IF(MOD(IFL,2).EQ.0) THEN
50339 IF(ILR.EQ.1) THEN
50340 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
50341 ELSE
50342 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
50343 ENDIF
50344 ELSE
50345 IF(ILR.EQ.1) THEN
50346 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
50347 ELSE
50348 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
50349 ENDIF
50350 ENDIF
50351 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50352 LKNT=LKNT+1
50353 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50354 IDLAM(LKNT,3)=0
50355 IDLAM(LKNT,1)=KF1
50356 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50357 ENDIF
50358 IF(XMI.GT.XMB+XMSF2) THEN
50359 IF(MOD(IFL,2).EQ.0) THEN
50360 IF(ILR.EQ.1) THEN
50361 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
50362 ELSE
50363 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
50364 ENDIF
50365 ELSE
50366 IF(ILR.EQ.1) THEN
50367 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
50368 ELSE
50369 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
50370 ENDIF
50371 ENDIF
50372 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
50373 LKNT=LKNT+1
50374 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
50375 IDLAM(LKNT,3)=0
50376 IDLAM(LKNT,1)=KF2
50377 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
50378 ENDIF
50379
50380C...SF -> SF' + HC
50381 XMB=PMAS(37,1)
50382 IF(MOD(IFL,2).EQ.0) THEN
50383 KF1=KSUSY1+IFL-1
50384 ELSE
50385 KF1=KSUSY1+IFL+1
50386 ENDIF
50387 KF2=KF1+KSUSY1
50388 XMSF1=PMAS(PYCOMP(KF1),1)
50389 XMSF2=PMAS(PYCOMP(KF2),1)
50390 IF(XMI.GT.XMB+XMSF1) THEN
50391 XMF=0D0
50392 XMFP=0D0
50393 AT=0D0
50394 AB=0D0
50395 IF(MOD(IFL,2).EQ.0) THEN
50396C...T1-> B1 HC
50397 IF(ILR.EQ.1) THEN
50398 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
50399 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
50400 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
50401 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
50402C...T2-> B1 HC
50403 ELSE
50404 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
50405 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
50406 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
50407 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
50408 ENDIF
50409 IF(IFL.EQ.6) THEN
50410 XMF=XMTOP
50411 XMFP=XMBOT
50412 AT=ATRIT
50413 AB=ATRIB
50414 ENDIF
50415 ELSE
50416C...B1 -> T1 HC
50417 IF(ILR.EQ.1) THEN
50418 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
50419 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
50420 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
50421 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
50422C...B2-> T1 HC
50423 ELSE
50424 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
50425 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
50426 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
50427 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
50428 ENDIF
50429 IF(IFL.EQ.5) THEN
50430 XMF=XMTOP
50431 XMFP=XMBOT
50432 AT=ATRIT
50433 AB=ATRIB
50434 ENDIF
50435 ENDIF
50436 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50437 LKNT=LKNT+1
50438C.......Need to complexify
50439 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50440 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50441 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50442 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50443 IDLAM(LKNT,3)=0
50444 IDLAM(LKNT,1)=KF1
50445 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50446 ENDIF
50447 IF(XMI.GT.XMB+XMSF2) THEN
50448 XMF=0D0
50449 XMFP=0D0
50450 AT=0D0
50451 AB=0D0
50452 IF(MOD(IFL,2).EQ.0) THEN
50453C...T1-> B2 HC
50454 IF(ILR.EQ.1) THEN
50455 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
50456 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
50457 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
50458 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
50459C...T2-> B2 HC
50460 ELSE
50461 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
50462 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
50463 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
50464 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
50465 ENDIF
50466 IF(IFL.EQ.6) THEN
50467 XMF=XMTOP
50468 XMFP=XMBOT
50469 AT=ATRIT
50470 AB=ATRIB
50471 ENDIF
50472 ELSE
50473C...B1 -> T2 HC
50474 IF(ILR.EQ.1) THEN
50475 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
50476 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
50477 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
50478 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
50479C...B2-> T2 HC
50480 ELSE
50481 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
50482 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
50483 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
50484 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
50485 ENDIF
50486 IF(IFL.EQ.5) THEN
50487 XMF=XMTOP
50488 XMFP=XMBOT
50489 AT=ATRIT
50490 AB=ATRIB
50491 ENDIF
50492 ENDIF
50493 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
50494 LKNT=LKNT+1
50495C.......Need to complexify
50496 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
50497 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
50498 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
50499 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
50500 IDLAM(LKNT,3)=0
50501 IDLAM(LKNT,1)=KF2
50502 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
50503 ENDIF
50504
50505C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
50506
50507 IF(IFL.LE.6) THEN
50508 XMFP=0D0
50509 XMF=0D0
50510 IF(IFL.EQ.6) XMF=PMAS(6,1)
50511 IF(IFL.EQ.5) XMF=PMAS(5,1)
50512 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
50513 AXMJ=ABS(XMJ)
50514 IF(XMI.GE.AXMJ+XMF) THEN
50515 AL=-SFMIX(IFL,3)
50516 BL=SFMIX(IFL,1)
50517 AR=-SFMIX(IFL,4)
50518 BR=SFMIX(IFL,2)
50519C...F1 -> F CHI
50520 IF(ILR.EQ.1) THEN
50521 XCA=AL
50522 XCB=BL
50523C...F2 -> F CHI
50524 ELSE
50525 XCA=AR
50526 XCB=BR
50527 ENDIF
50528 LKNT=LKNT+1
50529 XMA2=XMJ**2
50530 XMB2=XMF**2
50531 XL=PYLAMF(XMI2,XMA2,XMB2)
50532 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50533 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
50534 IDLAM(LKNT,1)=KSUSY1+21
50535 IDLAM(LKNT,2)=IFL
50536 IDLAM(LKNT,3)=0
50537 ENDIF
50538 ENDIF
50539
50540C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
50541 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
50542 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
50543C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
50544C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
50545C...M*M = C1**2 * G**2/(16PI**2)
50546C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
50547 LKNT=LKNT+1
50548 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
50549 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
50550 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
50551 IDLAM(LKNT,1)=KSUSY1+22
50552 IDLAM(LKNT,2)=4
50553 IDLAM(LKNT,3)=0
50554 ENDIF
50555
50556C...R-violating sfermion decays (SKANDS).
50557 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
50558
50559 IKNT=LKNT
50560 XLAM(0)=0D0
50561 DO 170 I=1,IKNT
50562 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50563 XLAM(0)=XLAM(0)+XLAM(I)
50564 170 CONTINUE
50565 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
50566
50567 RETURN
50568 END
50569
50570C*********************************************************************
50571
50572C...PYGLUI
50573C...Calculates gluino decay modes.
50574
50575 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
50576
50577C...Double precision and integer declarations.
50578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50579 IMPLICIT INTEGER(I-N)
50580 INTEGER PYK,PYCHGE,PYCOMP
50581C...Parameter statement to help give large particle numbers.
50582 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50583 &KEXCIT=4000000,KDIMEN=5000000)
50584C...Commonblocks.
50585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50587 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50588 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50589 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50590CC &SFMIX(16,4),
50591C COMMON/PYINTS/XXM(20)
50592 COMPLEX*16 CXC
50593 COMMON/PYINTC/XXC(10),CXC(8)
50594 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
50595
50596C...Local variables
50597 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
50598 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
50599 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50600 DOUBLE PRECISION PYLAMF,XL
50601 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
50602 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
50603 DOUBLE PRECISION XLAM(0:400)
50604 INTEGER IDLAM(400,3)
50605 INTEGER LKNT,IX,ILR,I,IKNT,IFL
50606 DOUBLE PRECISION SR2
50607 DOUBLE PRECISION GAM
50608 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
50609 EXTERNAL PYGAUS,PYXXZ6
50610 DOUBLE PRECISION PYGAUS,PYXXZ6
50611 DOUBLE PRECISION PREC
50612 INTEGER KFNCHI(4),KFCCHI(2)
50613 DATA PI/3.141592654D0/
50614 DATA SR2/1.4142136D0/
50615 DATA PREC/1D-2/
50616 DATA KFNCHI/1000022,1000023,1000025,1000035/
50617 DATA KFCCHI/1000024,1000037/
50618
50619C...COUNT THE NUMBER OF DECAY MODES
50620 LKNT=0
50621 IF(KFIN.NE.KSUSY1+21) RETURN
50622 KCIN=PYCOMP(KFIN)
50623
50624 XW=PARU(102)
50625 TANW = SQRT(XW/(1D0-XW))
50626
50627 XMI=PMAS(KCIN,1)
50628 AXMI=ABS(XMI)
50629 XMI2=XMI**2
50630 AEM=PYALEM(XMI2)
50631 AS =PYALPS(XMI2)
50632 C1=AEM/XW
50633 XMI3=AXMI**3
50634
50635 XMI=SIGN(XMI,RMSS(3))
50636
50637C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
50638
50639 IF(IMSS(11).EQ.1) THEN
50640 XMP=RMSS(29)
50641 IDG=39+KSUSY1
50642 XMGR=PMAS(PYCOMP(IDG),1)
50643 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
50644 IF(AXMI.GT.XMGR) THEN
50645 LKNT=LKNT+1
50646 IDLAM(LKNT,1)=IDG
50647 IDLAM(LKNT,2)=21
50648 IDLAM(LKNT,3)=0
50649 XLAM(LKNT)=XFAC
50650 ENDIF
50651 ENDIF
50652
50653C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
50654
50655 DO 110 IFL=1,6
50656 DO 100 ILR=1,2
50657 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
50658 AXMJ=ABS(XMJ)
50659 XMF=PMAS(IFL,1)
50660 IF(AXMI.GE.AXMJ+XMF) THEN
50661C...Minus sign difference from gluino-quark-squark feynman rules
50662 AL=SFMIX(IFL,1)
50663 BL=-SFMIX(IFL,3)
50664 AR=SFMIX(IFL,2)
50665 BR=-SFMIX(IFL,4)
50666C...F1 -> F CHI
50667 IF(ILR.EQ.1) THEN
50668 CA=AL
50669 CB=BL
50670C...F2 -> F CHI
50671 ELSE
50672 CA=AR
50673 CB=BR
50674 ENDIF
50675 LKNT=LKNT+1
50676 XMA2=XMJ**2
50677 XMB2=XMF**2
50678 XL=PYLAMF(XMI2,XMA2,XMB2)
50679 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
50680 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
50681 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
50682 IDLAM(LKNT,2)=-IFL
50683 IDLAM(LKNT,3)=0
50684 LKNT=LKNT+1
50685 XLAM(LKNT)=XLAM(LKNT-1)
50686 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50687 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50688 IDLAM(LKNT,3)=0
50689 ENDIF
50690 100 CONTINUE
50691 110 CONTINUE
50692
50693C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
50694C...GLUINO -> NI Q QBAR
50695 DO 170 IX=1,4
50696 XMJ=SMZ(IX)
50697 AXMJ=ABS(XMJ)
50698 IF(AXMI.GE.AXMJ) THEN
50699 DO 120 I=1,4
50700 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
50701 120 CONTINUE
50702 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
50703 ORPP=DCONJG(OLPP)
50704 XXC(1)=0D0
50705 XXC(2)=XMJ
50706 XXC(3)=0D0
50707 XXC(4)=XMI
50708 IA=1
50709 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50710 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50711 XXC(7)=XXC(5)
50712 XXC(8)=XXC(6)
50713 XXC(9)=1D6
50714 XXC(10)=0D0
50715 EI=KCHG(IA,1)/3D0
50716 T3I=SIGN(1D0,EI+1D-6)/2D0
50717 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50718 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50719 CXC(1)=0D0
50720 CXC(2)=-GLIJ
50721 CXC(3)=0D0
50722 CXC(4)=DCONJG(GLIJ)
50723 CXC(5)=0D0
50724 CXC(6)=GRIJ
50725 CXC(7)=0D0
50726 CXC(8)=-DCONJG(GRIJ)
50727 S12MIN=0D0
50728 S12MAX=(AXMI-AXMJ)**2
50729 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
50730 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
50731 LKNT=LKNT+1
50732 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50733 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50734 IDLAM(LKNT,1)=KFNCHI(IX)
50735 IDLAM(LKNT,2)=1
50736 IDLAM(LKNT,3)=-1
50737 ENDIF
50738 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
50739 LKNT=LKNT+1
50740 XLAM(LKNT)=XLAM(LKNT-1)
50741 IDLAM(LKNT,1)=KFNCHI(IX)
50742 IDLAM(LKNT,2)=3
50743 IDLAM(LKNT,3)=-3
50744 ENDIF
50745 130 CONTINUE
50746 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
50747 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
50748 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
50749 GOTO 140
50750 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
50751 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
50752 ENDIF
50753 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
50754 LKNT=LKNT+1
50755 XLAM(LKNT)=GAM
50756 IDLAM(LKNT,1)=KFNCHI(IX)
50757 IDLAM(LKNT,2)=5
50758 IDLAM(LKNT,3)=-5
50759 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
50760 ENDIF
50761C...U-TYPE QUARKS
50762 140 CONTINUE
50763 IA=2
50764 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
50765 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
50766C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
50767 XXC(7)=XXC(5)
50768 XXC(8)=XXC(6)
50769 EI=KCHG(IA,1)/3D0
50770 T3I=SIGN(1D0,EI+1D-6)/2D0
50771 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
50772 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
50773 CXC(2)=-GLIJ
50774 CXC(4)=DCONJG(GLIJ)
50775 CXC(6)=GRIJ
50776 CXC(8)=-DCONJG(GRIJ)
50777 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
50778 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
50779 LKNT=LKNT+1
50780 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
50781 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
50782 IDLAM(LKNT,1)=KFNCHI(IX)
50783 IDLAM(LKNT,2)=2
50784 IDLAM(LKNT,3)=-2
50785 ENDIF
50786 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
50787 LKNT=LKNT+1
50788 XLAM(LKNT)=XLAM(LKNT-1)
50789 IDLAM(LKNT,1)=KFNCHI(IX)
50790 IDLAM(LKNT,2)=4
50791 IDLAM(LKNT,3)=-4
50792 ENDIF
50793 150 CONTINUE
50794C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
50795C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
50796 XMF=PMAS(6,1)
50797 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
50798 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
50799 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
50800 GOTO 160
50801 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
50802 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
50803 ENDIF
50804 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
50805 LKNT=LKNT+1
50806 XLAM(LKNT)=GAM
50807 IDLAM(LKNT,1)=KFNCHI(IX)
50808 IDLAM(LKNT,2)=6
50809 IDLAM(LKNT,3)=-6
50810 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
50811 ENDIF
50812 160 CONTINUE
50813 ENDIF
50814 170 CONTINUE
50815
50816C...GLUINO -> CI Q QBAR'
50817 DO 210 IX=1,2
50818 XMJ=SMW(IX)
50819 AXMJ=ABS(XMJ)
50820 IF(AXMI.GE.AXMJ) THEN
50821 DO 180 I=1,2
50822 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
50823 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
50824 180 CONTINUE
50825 S12MIN=0D0
50826 S12MAX=(AXMI-AXMJ)**2
50827 XXC(1)=0D0
50828 XXC(2)=XMJ
50829 XXC(3)=0D0
50830 XXC(4)=XMI
50831 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
50832 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
50833 XXC(9)=1D6
50834 XXC(10)=0D0
50835 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
50836 ORPP=DCONJG(OLPP)
50837 CXC(1)=DCMPLX(0D0,0D0)
50838 CXC(3)=DCMPLX(0D0,0D0)
50839 CXC(5)=DCMPLX(0D0,0D0)
50840 CXC(7)=DCMPLX(0D0,0D0)
50841 CXC(2)=UMIXC(IX,1)*OLPP/SR2
50842 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
50843 CXC(6)=DCMPLX(0D0,0D0)
50844 CXC(8)=DCMPLX(0D0,0D0)
50845 IF(XXC(5).LT.AXMI) THEN
50846 XXC(5)=1D6
50847 ELSEIF(XXC(6).LT.AXMI) THEN
50848 XXC(6)=1D6
50849 ENDIF
50850 XXC(7)=XXC(6)
50851 XXC(8)=XXC(5)
50852 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
50853 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
50854 LKNT=LKNT+1
50855 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
50856 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
50857 IDLAM(LKNT,1)=KFCCHI(IX)
50858 IDLAM(LKNT,2)=1
50859 IDLAM(LKNT,3)=-2
50860 LKNT=LKNT+1
50861 XLAM(LKNT)=XLAM(LKNT-1)
50862 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50863 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50864 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50865 ENDIF
50866 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
50867 LKNT=LKNT+1
50868 XLAM(LKNT)=XLAM(LKNT-1)
50869 IDLAM(LKNT,1)=KFCCHI(IX)
50870 IDLAM(LKNT,2)=3
50871 IDLAM(LKNT,3)=-4
50872 LKNT=LKNT+1
50873 XLAM(LKNT)=XLAM(LKNT-1)
50874 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50875 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50876 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50877 ENDIF
50878 190 CONTINUE
50879
50880 XMF=PMAS(6,1)
50881 XMFP=PMAS(5,1)
50882 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
50883 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
50884 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
50885 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
50886 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
50887 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
50888 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
50889 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
50890 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
50891 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
50892 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
50893 CALL PYTBBC(IX,100,XMI,GAM)
50894 LKNT=LKNT+1
50895 XLAM(LKNT)=GAM
50896 IDLAM(LKNT,1)=KFCCHI(IX)
50897 IDLAM(LKNT,2)=5
50898 IDLAM(LKNT,3)=-6
50899 LKNT=LKNT+1
50900 XLAM(LKNT)=XLAM(LKNT-1)
50901 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
50902 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
50903 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
50904 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
50905 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
50906 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
50907 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
50908 ENDIF
50909 200 CONTINUE
50910 ENDIF
50911 210 CONTINUE
50912
50913C...R-parity violating (3-body) decays.
50914 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
50915
50916 IKNT=LKNT
50917 XLAM(0)=0D0
50918 DO 220 I=1,IKNT
50919 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
50920 XLAM(0)=XLAM(0)+XLAM(I)
50921 220 CONTINUE
50922 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
50923
50924 RETURN
50925 END
50926
50927
50928C*********************************************************************
50929
50930C...PYTBBN
50931C...Calculates the three-body decay of gluinos into
50932C...neutralinos and third generation fermions.
50933
50934 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
50935
50936C...Double precision and integer declarations.
50937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50938 IMPLICIT INTEGER(I-N)
50939 INTEGER PYK,PYCHGE,PYCOMP
50940C...Parameter statement to help give large particle numbers.
50941 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50942 &KEXCIT=4000000,KDIMEN=5000000)
50943C...Commonblocks.
50944 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50945 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50946 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50947 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50948 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50949 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50950
50951C...Local variables.
50952 EXTERNAL PYSIMP,PYLAMF
50953 DOUBLE PRECISION PYSIMP,PYLAMF
50954 INTEGER LIN,NN
50955 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
50956 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
50957 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
50958 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
50959 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
50960 DOUBLE PRECISION XLN1,XLN2,B1,B2
50961 DOUBLE PRECISION E,XMGLU,GAM
50962 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
50963 SAVE HRB,HLB,FLB,FRB
50964 DOUBLE PRECISION ALPHAW,ALPHAS
50965 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
50966 SAVE HLT,HRT,FLT,FRT
50967 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
50968 SAVE AMN,AN,ZN
50969 DOUBLE PRECISION AMBOT,SINC,COSC
50970 DOUBLE PRECISION AMTOP,SINA,COSA
50971 DOUBLE PRECISION SINW,COSW,TANW
50972 DOUBLE PRECISION ROT1(4,4)
50973 LOGICAL IFIRST
50974 SAVE IFIRST
50975 DATA IFIRST/.TRUE./
50976
50977 TANB=RMSS(5)
50978 SINB=TANB/SQRT(1D0+TANB**2)
50979 COSB=SINB/TANB
50980 XW=PARU(102)
50981 SINW=SQRT(XW)
50982 COSW=SQRT(1D0-XW)
50983 TANW=SINW/COSW
50984 AMW=PMAS(24,1)
50985 COSC=SFMIX(5,1)
50986 SINC=SFMIX(5,3)
50987 COSA=SFMIX(6,1)
50988 SINA=SFMIX(6,3)
50989 AMBOT=PYMRUN(5,XMGLU**2)
50990 AMTOP=PYMRUN(6,XMGLU**2)
50991 W2=SQRT(2D0)
50992 FAKT1=AMBOT/W2/AMW/COSB
50993 FAKT2=AMTOP/W2/AMW/SINB
50994 IF(IFIRST) THEN
50995 DO 110 II=1,4
50996 AMN(II)=SMZ(II)
50997 DO 100 J=1,4
50998 ROT1(II,J)=0D0
50999 AN(II,J)=0D0
51000 100 CONTINUE
51001 110 CONTINUE
51002 ROT1(1,1)=COSW
51003 ROT1(1,2)=-SINW
51004 ROT1(2,1)=-ROT1(1,2)
51005 ROT1(2,2)=ROT1(1,1)
51006 ROT1(3,3)=COSB
51007 ROT1(3,4)=SINB
51008 ROT1(4,3)=-ROT1(3,4)
51009 ROT1(4,4)=ROT1(3,3)
51010 DO 140 II=1,4
51011 DO 130 J=1,4
51012 DO 120 JJ=1,4
51013 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51014 120 CONTINUE
51015 130 CONTINUE
51016 140 CONTINUE
51017 DO 150 J=1,4
51018 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51019 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51020 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51021 & XW)*AN(J,2)/COSW
51022 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51023 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51024 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51025 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51026C FLU(J)=ZN(3)
51027C FRU(J)=ZN(2)
51028 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51029 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51030 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51031 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51032 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51033 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51034 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51035C FLD(J)=ZN(3)
51036C FRD(J)=ZN(2)
51037 150 CONTINUE
51038C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51039C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51040C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51041C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51042 IFIRST=.FALSE.
51043 ENDIF
51044
51045 IF(NINT(3D0*E).EQ.2) THEN
51046 HL=HLT(I)
51047 HR=HRT(I)
51048 FL=FLT(I)
51049 FR=FRT(I)
51050 COSD=SFMIX(6,1)
51051 SIND=SFMIX(6,3)
51052 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51053 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51054 XM=PMAS(6,1)
51055 ELSE
51056 HL=HLB(I)
51057 HR=HRB(I)
51058 FL=FLB(I)
51059 FR=FRB(I)
51060 COSD=SFMIX(5,1)
51061 SIND=SFMIX(5,3)
51062 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51063 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51064 XM=PMAS(5,1)
51065 ENDIF
51066 COSD2=COSD*COSD
51067 SIND2=SIND*SIND
51068 COS2D=COSD2-SIND2
51069 SIN2D=SIND*COSD*2D0
51070 HL2=HL*HL
51071 HR2=HR*HR
51072 FL2=FL*FL
51073 FR2=FR*FR
51074 FF=FL*FR
51075 HH=HL*HR
51076 HFL=HL*FL
51077 HFR=HR*FR
51078 HRFL=HR*FL
51079 HLFR=HL*FR
51080 XM2=XM*XM
51081 XMG=XMGLU
51082 XMG2=XMG*XMG
51083 ALPHAW=PYALEM(XMG2)
51084 ALPHAS=PYALPS(XMG2)
51085 XMR=AMN(I)
51086 XMR2=XMR*XMR
51087 XMQ4=XMG*XM2*XMR
51088 XM24=(XMG2+XM2)*(XM2+XMR2)
51089 SMIN=4D0*XM2
51090 SMAX=(XMG-ABS(XMR))**2
51091 XMQA=XMG2+2D0*XM2+XMR2
51092 DO 170 LIN=1,NN-1
51093 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51094 GRS=SBAR-XMQA
51095 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51096 W=DSQRT(W)
51097 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51098 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51099 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51100 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51101 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51102 & +2D0*(FF*SIND2-HH*COSD2))*W
51103 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51104 & +4D0*HFL*XM*XMR)*XLN1
51105 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51106 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51107 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51108 & +8D0*HFL*XMQ4*SIN2D)*B1
51109 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51110 & +4D0*HFR*XMR*XM)*XLN2
51111 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51112 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51113 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51114 & -8D0*HFR*XMQ4*SIN2D)*B2
51115 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51116 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51117 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51118 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51119 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51120 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51121 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51122 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51123 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51124 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51125 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51126 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51127 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51128 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51129 & +COS2D*XM*(SBAR+XMG2-XMR2))
51130 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51131 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51132 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51133 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51134 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51135 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51136 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51137 SUMME(LIN)=0D0
51138 DO 160 J=0,6
51139 SUMME(LIN)=SUMME(LIN)+G(J)
51140 160 CONTINUE
51141 170 CONTINUE
51142 SUMME(0)=0D0
51143 SUMME(NN)=0D0
51144 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51145 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51146
51147 RETURN
51148 END
51149
51150C*********************************************************************
51151
51152C...PYTBBC
51153C...Calculates the three-body decay of gluinos into
51154C...charginos and third generation fermions.
51155
51156 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51157
51158C...Double precision and integer declarations.
51159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51160 IMPLICIT INTEGER(I-N)
51161 INTEGER PYK,PYCHGE,PYCOMP
51162C...Parameter statement to help give large particle numbers.
51163 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51164 &KEXCIT=4000000,KDIMEN=5000000)
51165C...Commonblocks.
51166 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51167 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51168 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51169 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51170 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51171 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51172
51173C...Local variables.
51174 EXTERNAL PYSIMP,PYLAMF
51175 DOUBLE PRECISION PYSIMP,PYLAMF
51176 INTEGER I,NN,LIN
51177 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51178 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51179 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51180 DOUBLE PRECISION SUMME(0:100),A(4,8)
51181 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51182 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51183 DOUBLE PRECISION XMGLU,GAM
51184 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51185 &DDD(2),EEE(2),FFF(2)
51186 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51187 DOUBLE PRECISION ALPHAW,ALPHAS
51188 DOUBLE PRECISION AMC(2)
51189 SAVE AMC
51190 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51191 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51192 SAVE AMSB,AMST
51193 LOGICAL IFIRST
51194 SAVE IFIRST
51195 DATA IFIRST/.TRUE./
51196
51197 TANB=RMSS(5)
51198 SINB=TANB/SQRT(1D0+TANB**2)
51199 COSB=SINB/TANB
51200 XW=PARU(102)
51201 AMW=PMAS(24,1)
51202 COSC=SFMIX(5,1)
51203 SINC=SFMIX(5,3)
51204 COSA=SFMIX(6,1)
51205 SINA=SFMIX(6,3)
51206 AMBOT=PYMRUN(5,XMGLU**2)
51207 AMTOP=PYMRUN(6,XMGLU**2)
51208 W2=SQRT(2D0)
51209 AMW=PMAS(24,1)
51210 FAKT1=AMBOT/W2/AMW/COSB
51211 FAKT2=AMTOP/W2/AMW/SINB
51212 IF(IFIRST) THEN
51213 AMC(1)=SMW(1)
51214 AMC(2)=SMW(2)
51215 DO 100 JJ=1,2
51216 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
51217 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
51218 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
51219 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
51220 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
51221 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
51222 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
51223 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
51224 100 CONTINUE
51225 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51226 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51227 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51228 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51229 IFIRST=.FALSE.
51230 ENDIF
51231
51232 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
51233 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
51234 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
51235 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
51236
51237 COS2A=COSA**2-SINA**2
51238 SIN2A=SINA*COSA*2D0
51239 COS2C=COSC**2-SINC**2
51240 SIN2C=SINC*COSC*2D0
51241
51242 XMG=XMGLU
51243 XMT=PMAS(6,1)
51244 XMB=PMAS(5,1)
51245 XMR=AMC(I)
51246 XMG2=XMG*XMG
51247 ALPHAW=PYALEM(XMG2)
51248 ALPHAS=PYALPS(XMG2)
51249 XMT2=XMT*XMT
51250 XMB2=XMB*XMB
51251 XMR2=XMR*XMR
51252 XMQ2=XMG2+XMT2+XMB2+XMR2
51253 XMQ4=XMG*XMT*XMB*XMR
51254 XMQ3=XMG2*XMR2+XMT2*XMB2
51255 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
51256 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
51257
51258 XMST(1)=AMST(1)*AMST(1)
51259 XMST(2)=AMST(1)*AMST(1)
51260 XMST(3)=AMST(2)*AMST(2)
51261 XMST(4)=AMST(2)*AMST(2)
51262 XMSB(1)=AMSB(1)*AMSB(1)
51263 XMSB(2)=AMSB(2)*AMSB(2)
51264 XMSB(3)=AMSB(1)*AMSB(1)
51265 XMSB(4)=AMSB(2)*AMSB(2)
51266
51267 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
51268 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
51269 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
51270 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
51271 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
51272 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
51273 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
51274 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
51275
51276 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
51277 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
51278 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
51279 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
51280 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
51281 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
51282 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
51283 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
51284
51285 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
51286 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
51287 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
51288 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
51289 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
51290 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
51291 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
51292 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
51293
51294 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
51295 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
51296 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
51297 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
51298 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
51299 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
51300 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
51301 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
51302
51303 SMAX=(XMG-ABS(XMR))**2
51304 SMIN=(XMB+XMT)**2+0.1D0
51305
51306 DO 120 LIN=0,NN-1
51307 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51308 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
51309 GRS=SBAR-XMQ2
51310 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
51311 W=DSQRT(W)/2D0/SBAR
51312 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
51313 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
51314 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
51315 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
51316 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
51317 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
51318 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
51319 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
51320 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
51321 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
51322 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
51323 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
51324 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
51325 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
51326 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
51327 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
51328 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
51329 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
51330 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
51331 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
51332 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
51333 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
51334 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
51335 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
51336 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
51337 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
51338 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
51339 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
51340 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
51341 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
51342 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
51343 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
51344 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
51345 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
51346 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
51347 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
51348 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
51349 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
51350 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
51351 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
51352 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
51353 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
51354 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
51355 DO 110 J=1,4
51356 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
51357 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
51358 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
51359 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
51360 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
51361 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
51362 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
51363 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
51364 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
51365 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
51366 & -A(J,6)*(XMG2+XMR2-SBAR)
51367 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
51368 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
51369 & /(GRS+XMSB(J)+XMST(J))
51370 110 CONTINUE
51371 120 CONTINUE
51372 SUMME(NN)=0D0
51373 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51374 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51375
51376 RETURN
51377 END
51378
51379C*********************************************************************
51380
51381C...PYNJDC
51382C...Calculates decay widths for the neutralinos (admixtures of
51383C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
51384
51385C...Input: KCIN = KF code for particle
51386C...Output: XLAM = widths
51387C... IDLAM = KF codes for decay particles
51388C... IKNT = number of decay channels defined
51389C...AUTHOR: STEPHEN MRENNA
51390C...Last change:
51391C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
51392C...when CHIGAMMA .NE. 0
51393C...10 FEB 96: Calculate this decay for small tan(beta)
51394
51395 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
51396
51397C...Double precision and integer declarations.
51398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51399 IMPLICIT INTEGER(I-N)
51400 INTEGER PYK,PYCHGE,PYCOMP
51401C...Parameter statement to help give large particle numbers.
51402 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51403 &KEXCIT=4000000,KDIMEN=5000000)
51404C...Commonblocks.
51405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51406 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51407 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51408c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51409c &SFMIX(16,4)
51410 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51411 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51412C COMMON/PYINTS/XXM(20)
51413 COMPLEX*16 CXC
51414 COMMON/PYINTC/XXC(10),CXC(8)
51415 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51416
51417C...Local variables.
51418 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51419 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
51420 INTEGER KFIN
51421 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
51422 &XMZ,XMZ2,AXMJ,AXMI
51423 DOUBLE PRECISION S12MIN,S12MAX
51424 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
51425 DOUBLE PRECISION PYLAMF,XL
51426 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
51427 DOUBLE PRECISION PYX2XH,PYX2XG
51428 DOUBLE PRECISION XLAM(0:400)
51429 INTEGER IDLAM(400,3)
51430 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
51431 INTEGER ITH(3),KF1,KF2
51432 INTEGER ITHC
51433 DOUBLE PRECISION DH(3),EH(3)
51434 DOUBLE PRECISION SR2
51435 DOUBLE PRECISION CBETA,SBETA
51436 DOUBLE PRECISION GAMCON,XMT1,XMT2
51437 DOUBLE PRECISION PYALEM,PI,PYALPS
51438 DOUBLE PRECISION RAT1,RAT2
51439 DOUBLE PRECISION T3T,FCOL
51440 DOUBLE PRECISION ALFA,BETA,TANB
51441 DOUBLE PRECISION PYXXGA
51442 EXTERNAL PYGAUS,PYXXZ6
51443 DOUBLE PRECISION PYGAUS,PYXXZ6
51444 DOUBLE PRECISION PREC
51445 INTEGER KFNCHI(4),KFCCHI(2)
51446 DATA ITH/25,35,36/
51447 DATA ITHC/37/
51448 DATA PREC/1D-2/
51449 DATA PI/3.141592654D0/
51450 DATA SR2/1.4142136D0/
51451 DATA KFNCHI/1000022,1000023,1000025,1000035/
51452 DATA KFCCHI/1000024,1000037/
51453
51454C...COUNT THE NUMBER OF DECAY MODES
51455 LKNT=0
51456
51457 XMW=PMAS(24,1)
51458 XMW2=XMW**2
51459 XMZ=PMAS(23,1)
51460 XMZ2=XMZ**2
51461 XW=1D0-XMW2/XMZ2
51462 XW1=1D0-XW
51463 TANW = SQRT(XW/XW1)
51464
51465C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
51466 IX=1
51467 IF(KFIN.EQ.KFNCHI(2)) IX=2
51468 IF(KFIN.EQ.KFNCHI(3)) IX=3
51469 IF(KFIN.EQ.KFNCHI(4)) IX=4
51470
51471 XMI=SMZ(IX)
51472 XMI2=XMI**2
51473 AXMI=ABS(XMI)
51474 AEM=PYALEM(XMI2)
51475 AS =PYALPS(XMI2)
51476 C1=AEM/XW
51477 XMI3=ABS(XMI**3)
51478
51479 TANB=RMSS(5)
51480 BETA=ATAN(TANB)
51481 ALFA=RMSS(18)
51482 CBETA=COS(BETA)
51483 SBETA=TANB*CBETA
51484 CALFA=COS(ALFA)
51485 SALFA=SIN(ALFA)
51486
51487 DO 110 I=1,4
51488 DO 100 J=1,4
51489 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
51490 100 CONTINUE
51491 110 CONTINUE
51492 DO 130 I=1,2
51493 DO 120 J=1,2
51494 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
51495 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
51496 120 CONTINUE
51497 130 CONTINUE
51498
51499C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
51500 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
51501
51502C...FORCE CHI0_2 -> CHI0_1 + GAMMA
51503 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
51504 XMJ=SMZ(1)
51505 AXMJ=ABS(XMJ)
51506 LKNT=LKNT+1
51507 GAMCON=AEM**3/8D0/PI/XMW2/XW
51508 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51509 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51510 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51511 IDLAM(LKNT,1)=KSUSY1+22
51512 IDLAM(LKNT,2)=22
51513 IDLAM(LKNT,3)=0
51514 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
51515 GOTO 340
51516 ENDIF
51517
51518C...GRAVITINO DECAY MODES
51519
51520 IF(IMSS(11).EQ.1) THEN
51521 XMP=RMSS(29)
51522 IDG=39+KSUSY1
51523 XMGR=PMAS(PYCOMP(IDG),1)
51524 SINW=SQRT(XW)
51525 COSW=SQRT(1D0-XW)
51526 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51527 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
51528 LKNT=LKNT+1
51529 IDLAM(LKNT,1)=IDG
51530 IDLAM(LKNT,2)=22
51531 IDLAM(LKNT,3)=0
51532 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
51533 ENDIF
51534 IF(AXMI.GT.XMGR+XMZ) THEN
51535 LKNT=LKNT+1
51536 IDLAM(LKNT,1)=IDG
51537 IDLAM(LKNT,2)=23
51538 IDLAM(LKNT,3)=0
51539 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
51540 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
51541 & (1D0-XMZ2/XMI2)**4
51542 ENDIF
51543 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
51544 LKNT=LKNT+1
51545 IDLAM(LKNT,1)=IDG
51546 IDLAM(LKNT,2)=25
51547 IDLAM(LKNT,3)=0
51548 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
51549 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
51550 ENDIF
51551 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
51552 LKNT=LKNT+1
51553 IDLAM(LKNT,1)=IDG
51554 IDLAM(LKNT,2)=35
51555 IDLAM(LKNT,3)=0
51556 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
51557 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
51558 ENDIF
51559 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
51560 LKNT=LKNT+1
51561 IDLAM(LKNT,1)=IDG
51562 IDLAM(LKNT,2)=36
51563 IDLAM(LKNT,3)=0
51564 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
51565 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
51566 ENDIF
51567 IF(IX.EQ.1) GOTO 300
51568 ENDIF
51569
51570 DO 220 IJ=1,IX-1
51571 XMJ=SMZ(IJ)
51572 AXMJ=ABS(XMJ)
51573 XMJ2=XMJ**2
51574
51575C...CHI0_I -> CHI0_J + GAMMA
51576 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
51577 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
51578 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
51579 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
51580 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
51581 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
51582 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
51583 LKNT=LKNT+1
51584 IDLAM(LKNT,1)=KFNCHI(IJ)
51585 IDLAM(LKNT,2)=22
51586 IDLAM(LKNT,3)=0
51587 GAMCON=AEM**3/8D0/PI/XMW2/XW
51588 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
51589 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
51590 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
51591 ENDIF
51592 ENDIF
51593
51594C...CHI0_I -> CHI0_J + Z0
51595 IF(AXMI.GE.AXMJ+XMZ) THEN
51596 LKNT=LKNT+1
51597 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51598 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51599 ORPP=-DCONJG(OLPP)
51600 GX2=ABS(OLPP)**2+ABS(ORPP)**2
51601 GLR=DBLE(OLPP*DCONJG(ORPP))
51602 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
51603 IDLAM(LKNT,1)=KFNCHI(IJ)
51604 IDLAM(LKNT,2)=23
51605 IDLAM(LKNT,3)=0
51606 ELSEIF(AXMI.GE.AXMJ) THEN
51607 XXC(1)=0D0
51608 XXC(2)=XMJ
51609 XXC(3)=0D0
51610 XXC(4)=XMI
51611 XXC(9)=XMZ
51612 XXC(10)=PMAS(23,2)
51613 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
51614 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
51615 ORPP=DCONJG(OLPP)
51616C...CHARGED LEPTONS
51617 FID=11
51618 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51619 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51620 EI=KCHG(FID,1)/3D0
51621 T3I=SIGN(1D0,EI+1D-6)/2D0
51622 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51623 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51624 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51625 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51626 CXC(2)=-GLIJ
51627 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51628 CXC(4)=DCONJG(GLIJ)
51629 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51630 CXC(6)=GRIJ
51631 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51632 CXC(8)=-DCONJG(GRIJ)
51633 S12MIN=0D0
51634 S12MAX=(AXMI-AXMJ)**2
51635 IF( XXC(5).LT.AXMI ) THEN
51636 XXC(5)=1D6
51637 ENDIF
51638 IF(XXC(6).LT.AXMI ) THEN
51639 XXC(6)=1D6
51640 ENDIF
51641 XXC(7)=XXC(5)
51642 XXC(8)=XXC(6)
51643
51644 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
51645 LKNT=LKNT+1
51646 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51647 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51648 IDLAM(LKNT,1)=KFNCHI(IJ)
51649 IDLAM(LKNT,2)=FID
51650 IDLAM(LKNT,3)=-FID
51651 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
51652 LKNT=LKNT+1
51653 XLAM(LKNT)=XLAM(LKNT-1)
51654 IDLAM(LKNT,1)=KFNCHI(IJ)
51655 IDLAM(LKNT,2)=13
51656 IDLAM(LKNT,3)=-13
51657 ENDIF
51658 ENDIF
51659 140 CONTINUE
51660 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51661 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51662 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
51663 ELSE
51664 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
51665 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51666 ENDIF
51667 IF( XXC(5).LT.AXMI ) THEN
51668 XXC(5)=1D6
51669 ENDIF
51670 IF(XXC(6).LT.AXMI ) THEN
51671 XXC(6)=1D6
51672 ENDIF
51673 XXC(7)=XXC(5)
51674 XXC(8)=XXC(6)
51675
51676 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
51677 LKNT=LKNT+1
51678 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51679 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51680 IDLAM(LKNT,1)=KFNCHI(IJ)
51681 IDLAM(LKNT,2)=15
51682 IDLAM(LKNT,3)=-15
51683 ENDIF
51684
51685C...NEUTRINOS
51686 150 CONTINUE
51687 FID=12
51688 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51689 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51690 EI=KCHG(FID,1)/3D0
51691 T3I=SIGN(1D0,EI+1D-6)/2D0
51692 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51693 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51694 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51695 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51696 CXC(2)=-GLIJ
51697 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51698 CXC(4)=DCONJG(GLIJ)
51699 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51700 CXC(6)=GRIJ
51701 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51702 CXC(8)=-DCONJG(GRIJ)
51703 S12MIN=0D0
51704 S12MAX=(AXMI-AXMJ)**2
51705 IF( XXC(5).LT.AXMI ) THEN
51706 XXC(5)=1D6
51707 ENDIF
51708 IF( XXC(6).LT.AXMI ) THEN
51709 XXC(6)=1D6
51710 ENDIF
51711 XXC(7)=XXC(5)
51712 XXC(8)=XXC(6)
51713
51714 LKNT=LKNT+1
51715 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51716 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51717 IDLAM(LKNT,1)=KFNCHI(IJ)
51718 IDLAM(LKNT,2)=12
51719 IDLAM(LKNT,3)=-12
51720 LKNT=LKNT+1
51721 XLAM(LKNT)=XLAM(LKNT-1)
51722 IDLAM(LKNT,1)=KFNCHI(IJ)
51723 IDLAM(LKNT,2)=14
51724 IDLAM(LKNT,3)=-14
51725 160 CONTINUE
51726
51727 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
51728 & THEN
51729 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
51730 IF( XXC(5).LT.AXMI ) THEN
51731 XXC(5)=1D6
51732 ENDIF
51733 XXC(7)=XXC(5)
51734 LKNT=LKNT+1
51735 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51736 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
51737 ELSE
51738 LKNT=LKNT+1
51739 XLAM(LKNT)=XLAM(LKNT-1)
51740 ENDIF
51741 IDLAM(LKNT,1)=KFNCHI(IJ)
51742 IDLAM(LKNT,2)=16
51743 IDLAM(LKNT,3)=-16
51744C...D-TYPE QUARKS
51745 170 CONTINUE
51746 FID=1
51747 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51748 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51749 EI=KCHG(FID,1)/3D0
51750 T3I=SIGN(1D0,EI+1D-6)/2D0
51751 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51752 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51753 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51754 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51755 CXC(2)=-GLIJ
51756 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51757 CXC(4)=DCONJG(GLIJ)
51758 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51759 CXC(6)=GRIJ
51760 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51761 CXC(8)=-DCONJG(GRIJ)
51762 S12MIN=0D0
51763 S12MAX=(AXMI-AXMJ)**2
51764 IF( XXC(5).LT.AXMI ) THEN
51765 XXC(5)=1D6
51766 ENDIF
51767 IF( XXC(6).LT.AXMI ) THEN
51768 XXC(6)=1D6
51769 ENDIF
51770 XXC(7)=XXC(5)
51771 XXC(8)=XXC(6)
51772
51773 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51774 LKNT=LKNT+1
51775 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51776 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51777 IDLAM(LKNT,1)=KFNCHI(IJ)
51778 IDLAM(LKNT,2)=1
51779 IDLAM(LKNT,3)=-1
51780 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51781 LKNT=LKNT+1
51782 XLAM(LKNT)=XLAM(LKNT-1)
51783 IDLAM(LKNT,1)=KFNCHI(IJ)
51784 IDLAM(LKNT,2)=3
51785 IDLAM(LKNT,3)=-3
51786 ENDIF
51787 ENDIF
51788 180 CONTINUE
51789 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
51790 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
51791 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
51792 ELSE
51793 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
51794 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
51795 ENDIF
51796 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
51797 IF(XXC(5).LT.AXMI) THEN
51798 XXC(5)=1D6
51799 ELSEIF(XXC(6).LT.AXMI) THEN
51800 XXC(6)=1D6
51801 ENDIF
51802 XXC(7)=XXC(5)
51803 XXC(8)=XXC(6)
51804 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51805 LKNT=LKNT+1
51806 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51807 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51808 IDLAM(LKNT,1)=KFNCHI(IJ)
51809 IDLAM(LKNT,2)=5
51810 IDLAM(LKNT,3)=-5
51811 ENDIF
51812
51813C...U-TYPE QUARKS
51814 190 CONTINUE
51815 FID=2
51816 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
51817 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
51818 EI=KCHG(FID,1)/3D0
51819 T3I=SIGN(1D0,EI+1D-6)/2D0
51820 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
51821 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
51822 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
51823 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
51824 CXC(2)=-GLIJ
51825 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
51826 CXC(4)=DCONJG(GLIJ)
51827 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
51828 CXC(6)=GRIJ
51829 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
51830 CXC(8)=-DCONJG(GRIJ)
51831
51832 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
51833 IF(XXC(5).LT.AXMI) THEN
51834 XXC(5)=1D6
51835 ELSEIF(XXC(6).LT.AXMI) THEN
51836 XXC(6)=1D6
51837 ENDIF
51838 XXC(7)=XXC(5)
51839 XXC(8)=XXC(6)
51840
51841 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51842 LKNT=LKNT+1
51843 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51844 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
51845 IDLAM(LKNT,1)=KFNCHI(IJ)
51846 IDLAM(LKNT,2)=2
51847 IDLAM(LKNT,3)=-2
51848 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51849 LKNT=LKNT+1
51850 XLAM(LKNT)=XLAM(LKNT-1)
51851 IDLAM(LKNT,1)=KFNCHI(IJ)
51852 IDLAM(LKNT,2)=4
51853 IDLAM(LKNT,3)=-4
51854 ENDIF
51855 ENDIF
51856 200 CONTINUE
51857 ENDIF
51858
51859C...CHI0_I -> CHI0_J + H0_K
51860 EH(1)=SIN(ALFA)
51861 EH(2)=COS(ALFA)
51862 EH(3)=-SIN(BETA)
51863 DH(1)=COS(ALFA)
51864 DH(2)=-SIN(ALFA)
51865 DH(3)=COS(BETA)
51866 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
51867 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
51868 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
51869 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
51870 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
51871 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
51872 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
51873 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
51874 DO 210 IH=1,3
51875 XMH=PMAS(ITH(IH),1)
51876 XMH2=XMH**2
51877 IF(AXMI.GE.AXMJ+XMH) THEN
51878 LKNT=LKNT+1
51879 XL=PYLAMF(XMI2,XMJ2,XMH2)
51880 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
51881 F12K=F21K
51882C...SIGN OF MASSES I,J
51883 XMK=XMJ
51884 IF(IH.EQ.3) XMK=-XMK
51885 GX2=ABS(F21K)**2+ABS(F12K)**2
51886 GLR=DBLE(F21K*DCONJG(F12K))
51887 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
51888 IDLAM(LKNT,1)=KFNCHI(IJ)
51889 IDLAM(LKNT,2)=ITH(IH)
51890 IDLAM(LKNT,3)=0
51891 ENDIF
51892 210 CONTINUE
51893 220 CONTINUE
51894
51895C...CHI0_I -> CHI+_J + W-
51896 DO 260 IJ=1,2
51897 XMJ=SMW(IJ)
51898 AXMJ=ABS(XMJ)
51899 XMJ2=XMJ**2
51900 IF(AXMI.GE.AXMJ+XMW) THEN
51901 LKNT=LKNT+1
51902 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51903 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
51904 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51905 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
51906 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
51907 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
51908 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
51909 IDLAM(LKNT,1)=KFCCHI(IJ)
51910 IDLAM(LKNT,2)=-24
51911 IDLAM(LKNT,3)=0
51912 LKNT=LKNT+1
51913 XLAM(LKNT)=XLAM(LKNT-1)
51914 IDLAM(LKNT,1)=-KFCCHI(IJ)
51915 IDLAM(LKNT,2)=24
51916 IDLAM(LKNT,3)=0
51917 ELSEIF(AXMI.GE.AXMJ) THEN
51918 S12MIN=0D0
51919 S12MAX=(AXMI-AXMJ)**2
51920 RT2I = 1D0/SQRT(2D0)
51921 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
51922 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
51923 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
51924 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
51925 CXC(5)=DCMPLX(0D0,0D0)
51926 CXC(7)=DCMPLX(0D0,0D0)
51927 IA=11
51928 JA=12
51929 EI=KCHG(IA,1)/3D0
51930 T3I=SIGN(1D0,EI+1D-6)/2D0
51931 EJ=KCHG(JA,1)/3D0
51932 T3J=SIGN(1D0,EJ+1D-6)/2D0
51933 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
51934 & TANW+ZMIXC(IX,2)*T3J)*RT2I
51935 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
51936 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
51937 CXC(6)=DCMPLX(0D0,0D0)
51938 CXC(8)=DCMPLX(0D0,0D0)
51939 XXC(1)=0D0
51940 XXC(2)=XMJ
51941 XXC(3)=0D0
51942 XXC(4)=XMI
51943 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
51944 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
51945 XXC(9)=PMAS(24,1)
51946 XXC(10)=PMAS(24,2)
51947 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
51948 IF(XXC(5).LT.AXMI) THEN
51949 XXC(5)=1D6
51950 ELSEIF(XXC(6).LT.AXMI) THEN
51951 XXC(6)=1D6
51952 ENDIF
51953 XXC(7)=XXC(6)
51954 XXC(8)=XXC(5)
51955 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
51956 LKNT=LKNT+1
51957 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51958 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51959 IDLAM(LKNT,1)=KFCCHI(IJ)
51960 IDLAM(LKNT,2)=11
51961 IDLAM(LKNT,3)=-12
51962 LKNT=LKNT+1
51963 XLAM(LKNT)=XLAM(LKNT-1)
51964 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51965 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51966 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51967 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
51968 LKNT=LKNT+1
51969 XLAM(LKNT)=XLAM(LKNT-1)
51970 IDLAM(LKNT,1)=KFCCHI(IJ)
51971 IDLAM(LKNT,2)=13
51972 IDLAM(LKNT,3)=-14
51973 LKNT=LKNT+1
51974 XLAM(LKNT)=XLAM(LKNT-1)
51975 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51976 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51977 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51978 ENDIF
51979 ENDIF
51980 230 CONTINUE
51981 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
51982 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
51983 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51984 ELSE
51985 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
51986 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
51987 ENDIF
51988 IF(XXC(5).LT.AXMI) THEN
51989 XXC(5)=1D6
51990 ENDIF
51991 IF(XXC(6).LT.AXMI) THEN
51992 XXC(6)=1D6
51993 ENDIF
51994 XXC(7)=XXC(6)
51995 XXC(8)=XXC(5)
51996 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
51997 LKNT=LKNT+1
51998 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
51999 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52000 XLAM(LKNT)=XLAM(LKNT-1)
52001 IDLAM(LKNT,1)=KFCCHI(IJ)
52002 IDLAM(LKNT,2)=15
52003 IDLAM(LKNT,3)=-16
52004 LKNT=LKNT+1
52005 XLAM(LKNT)=XLAM(LKNT-1)
52006 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52007 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52008 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52009 ENDIF
52010
52011C...NOW, DO THE QUARKS
52012 240 CONTINUE
52013 IA=1
52014 JA=2
52015 EI=KCHG(IA,1)/3D0
52016 T3I=SIGN(1D0,EI+1D-6)/2D0
52017 EJ=KCHG(JA,1)/3D0
52018 T3J=SIGN(1D0,EJ+1D-6)/2D0
52019 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52020 & TANW+ZMIXC(IX,2)*T3J)
52021 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52022 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52023 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52024 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52025 IF(XXC(5).LT.AXMI) THEN
52026 XXC(5)=1D6
52027 ENDIF
52028 IF(XXC(6).LT.AXMI) THEN
52029 XXC(6)=1D6
52030 ENDIF
52031 XXC(7)=XXC(6)
52032 XXC(8)=XXC(5)
52033 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52034 LKNT=LKNT+1
52035 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52036 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52037 IDLAM(LKNT,1)=KFCCHI(IJ)
52038 IDLAM(LKNT,2)=1
52039 IDLAM(LKNT,3)=-2
52040 LKNT=LKNT+1
52041 XLAM(LKNT)=XLAM(LKNT-1)
52042 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52043 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52044 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52045 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52046 LKNT=LKNT+1
52047 XLAM(LKNT)=XLAM(LKNT-1)
52048 IDLAM(LKNT,1)=KFCCHI(IJ)
52049 IDLAM(LKNT,2)=3
52050 IDLAM(LKNT,3)=-4
52051 LKNT=LKNT+1
52052 XLAM(LKNT)=XLAM(LKNT-1)
52053 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52054 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52055 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52056 ENDIF
52057 ENDIF
52058 250 CONTINUE
52059 ENDIF
52060 260 CONTINUE
52061 270 CONTINUE
52062
52063C...CHI0_I -> CHI+_I + H-
52064 DO 280 IJ=1,2
52065 XMJ=SMW(IJ)
52066 AXMJ=ABS(XMJ)
52067 XMJ2=XMJ**2
52068 XMHP=PMAS(ITHC,1)
52069 IF(AXMI.GE.AXMJ+XMHP) THEN
52070 LKNT=LKNT+1
52071 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52072 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52073 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52074 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52075 & UMIXC(IJ,2)/SR2)
52076 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52077 GLR=DBLE(OLPP*DCONJG(ORPP))
52078 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52079 IDLAM(LKNT,1)=KFCCHI(IJ)
52080 IDLAM(LKNT,2)=-ITHC
52081 IDLAM(LKNT,3)=0
52082 LKNT=LKNT+1
52083 XLAM(LKNT)=XLAM(LKNT-1)
52084 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52085 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52086 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52087 ELSE
52088
52089 ENDIF
52090 280 CONTINUE
52091
52092C...2-BODY DECAYS TO FERMION SFERMION
52093 DO 290 J=1,16
52094 IF(J.GE.7.AND.J.LE.10) GOTO 290
52095 KF1=KSUSY1+J
52096 KF2=KSUSY2+J
52097 XMSF1=PMAS(PYCOMP(KF1),1)
52098 XMSF2=PMAS(PYCOMP(KF2),1)
52099 XMF=PMAS(J,1)
52100 IF(J.LE.6) THEN
52101 FCOL=3D0
52102 ELSE
52103 FCOL=1D0
52104 ENDIF
52105
52106 EI=KCHG(J,1)/3D0
52107 T3T=SIGN(1D0,EI)
52108 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52109 IF(MOD(J,2).EQ.0) THEN
52110 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52111 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52112 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52113 CBR=CAL
52114 ELSE
52115 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52116 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52117 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52118 CBR=CAL
52119 ENDIF
52120
52121C...D~ D_L
52122 IF(AXMI.GE.XMF+XMSF1) THEN
52123 LKNT=LKNT+1
52124 XMA2=XMSF1**2
52125 XMB2=XMF**2
52126 XL=PYLAMF(XMI2,XMA2,XMB2)
52127 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52128 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52129 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52130 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52131 IDLAM(LKNT,1)=KF1
52132 IDLAM(LKNT,2)=-J
52133 IDLAM(LKNT,3)=0
52134 LKNT=LKNT+1
52135 XLAM(LKNT)=XLAM(LKNT-1)
52136 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52137 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52138 IDLAM(LKNT,3)=0
52139 ENDIF
52140
52141C...D~ D_R
52142 IF(AXMI.GE.XMF+XMSF2) THEN
52143 LKNT=LKNT+1
52144 XMA2=XMSF2**2
52145 XMB2=XMF**2
52146 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52147 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52148 XL=PYLAMF(XMI2,XMA2,XMB2)
52149 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52150 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52151 IDLAM(LKNT,1)=KF2
52152 IDLAM(LKNT,2)=-J
52153 IDLAM(LKNT,3)=0
52154 LKNT=LKNT+1
52155 XLAM(LKNT)=XLAM(LKNT-1)
52156 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52157 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52158 IDLAM(LKNT,3)=0
52159 ENDIF
52160 290 CONTINUE
52161 300 CONTINUE
52162C...3-BODY DECAY TO Q Q~ GLUINO
52163 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52164 IF(AXMI.GE.XMJ) THEN
52165 RT2I = 1D0/SQRT(2D0)
52166 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52167 ORPP=DCONJG(OLPP)
52168 AXMJ=ABS(XMJ)
52169 XXC(1)=0D0
52170 XXC(2)=XMJ
52171 XXC(3)=0D0
52172 XXC(4)=XMI
52173 FID=1
52174 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52175 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52176 XXC(7)=XXC(5)
52177 XXC(8)=XXC(6)
52178 XXC(9)=1D6
52179 XXC(10)=0D0
52180 EI=KCHG(FID,1)/3D0
52181 T3I=SIGN(1D0,EI+1D-6)/2D0
52182 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52183 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52184 CXC(1)=0D0
52185 CXC(2)=-GLIJ
52186 CXC(3)=0D0
52187 CXC(4)=DCONJG(GLIJ)
52188 CXC(5)=0D0
52189 CXC(6)=GRIJ
52190 CXC(7)=0D0
52191 CXC(8)=-DCONJG(GRIJ)
52192 S12MIN=0D0
52193 S12MAX=(AXMI-AXMJ)**2
52194CMRENNA.This statement must be here to define S12MAX
52195 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
52196C...ALL QUARKS BUT T
52197 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52198 LKNT=LKNT+1
52199 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52200 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52201 IDLAM(LKNT,1)=KSUSY1+21
52202 IDLAM(LKNT,2)=1
52203 IDLAM(LKNT,3)=-1
52204 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52205 LKNT=LKNT+1
52206 XLAM(LKNT)=XLAM(LKNT-1)
52207 IDLAM(LKNT,1)=KSUSY1+21
52208 IDLAM(LKNT,2)=3
52209 IDLAM(LKNT,3)=-3
52210 ENDIF
52211 ENDIF
52212 310 CONTINUE
52213 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52214 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52215 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52216 ELSE
52217 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52218 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52219 ENDIF
52220 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
52221 XXC(7)=XXC(5)
52222 XXC(8)=XXC(6)
52223 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52224 LKNT=LKNT+1
52225 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52226 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52227 IDLAM(LKNT,1)=KSUSY1+21
52228 IDLAM(LKNT,2)=5
52229 IDLAM(LKNT,3)=-5
52230 ENDIF
52231C...U-TYPE QUARKS
52232 320 CONTINUE
52233 FID=2
52234 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52235 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52236 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
52237 XXC(7)=XXC(5)
52238 XXC(8)=XXC(6)
52239 EI=KCHG(FID,1)/3D0
52240 T3I=SIGN(1D0,EI+1D-6)/2D0
52241 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52242 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52243 CXC(2)=-GLIJ
52244 CXC(4)=DCONJG(GLIJ)
52245 CXC(6)=GRIJ
52246 CXC(8)=-DCONJG(GRIJ)
52247 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52248 LKNT=LKNT+1
52249 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
52250 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52251 IDLAM(LKNT,1)=KSUSY1+21
52252 IDLAM(LKNT,2)=2
52253 IDLAM(LKNT,3)=-2
52254 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52255 LKNT=LKNT+1
52256 XLAM(LKNT)=XLAM(LKNT-1)
52257 IDLAM(LKNT,1)=KSUSY1+21
52258 IDLAM(LKNT,2)=4
52259 IDLAM(LKNT,3)=-4
52260 ENDIF
52261 ENDIF
52262 330 CONTINUE
52263 ENDIF
52264
52265C...R-violating decay modes (SKANDS).
52266 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
52267
52268 340 IKNT=LKNT
52269 XLAM(0)=0D0
52270 DO 350 I=1,IKNT
52271 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
52272 XLAM(0)=XLAM(0)+XLAM(I)
52273 350 CONTINUE
52274 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
52275
52276 RETURN
52277 END
52278
52279C*********************************************************************
52280
52281C...PYCJDC
52282C...Calculate decay widths for the charginos (admixtures of
52283C...charged Wino and charged Higgsino.
52284
52285C...Input: KCIN = KF code for particle
52286C...Output: XLAM = widths
52287C... IDLAM = KF codes for decay particles
52288C... IKNT = number of decay channels defined
52289C...AUTHOR: STEPHEN MRENNA
52290C...Last change:
52291C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
52292C...when CHIENU .NE. 0
52293
52294 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
52295
52296C...Double precision and integer declarations.
52297 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52298 IMPLICIT INTEGER(I-N)
52299 INTEGER PYK,PYCHGE,PYCOMP
52300C...Parameter statement to help give large particle numbers.
52301 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52302 &KEXCIT=4000000,KDIMEN=5000000)
52303C...Commonblocks.
52304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52306 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52307 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52308 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52309CC &SFMIX(16,4),
52310C COMMON/PYINTS/XXM(20)
52311 COMPLEX*16 CXC
52312 COMMON/PYINTC/XXC(10),CXC(8)
52313 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52314
52315C...Local variables
52316 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
52317 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
52318 INTEGER KFIN,KCIN
52319 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52320 &XMZ,XMZ2,AXMJ,AXMI
52321 DOUBLE PRECISION S12MIN,S12MAX
52322 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
52323 DOUBLE PRECISION PYLAMF,XL
52324 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
52325 DOUBLE PRECISION PYX2XH,PYX2XG
52326 DOUBLE PRECISION XLAM(0:400)
52327 INTEGER IDLAM(400,3)
52328 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
52329 INTEGER ITH(3)
52330 INTEGER ITHC
52331 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
52332 DOUBLE PRECISION SR2
52333 DOUBLE PRECISION CBETA,SBETA,TANB
52334
52335 DOUBLE PRECISION PYALEM,PI,PYALPS
52336 DOUBLE PRECISION FCOL
52337 INTEGER KF1,KF2,ISF
52338 INTEGER KFNCHI(4),KFCCHI(2)
52339
52340 DOUBLE PRECISION TEMP
52341 EXTERNAL PYGAUS,PYXXZ6
52342 DOUBLE PRECISION PYGAUS,PYXXZ6
52343 DOUBLE PRECISION PREC
52344 DATA ITH/25,35,36/
52345 DATA ITHC/37/
52346 DATA ETAH/1D0,1D0,-1D0/
52347 DATA SR2/1.4142136D0/
52348 DATA PI/3.141592654D0/
52349 DATA PREC/1D-2/
52350 DATA KFNCHI/1000022,1000023,1000025,1000035/
52351 DATA KFCCHI/1000024,1000037/
52352
52353C...COUNT THE NUMBER OF DECAY MODES
52354 LKNT=0
52355 XMW=PMAS(24,1)
52356 XMW2=XMW**2
52357 XMZ=PMAS(23,1)
52358 XMZ2=XMZ**2
52359 XW=1D0-XMW2/XMZ2
52360 XW1=1D0-XW
52361 TANW = SQRT(XW/XW1)
52362
52363C...1 OR 2 DEPENDING ON CHARGINO TYPE
52364 IX=1
52365 IF(KFIN.EQ.KFCCHI(2)) IX=2
52366 KCIN=PYCOMP(KFIN)
52367
52368 XMI=SMW(IX)
52369 XMI2=XMI**2
52370 AXMI=ABS(XMI)
52371 AEM=PYALEM(XMI2)
52372 AS =PYALPS(XMI2)
52373 C1=AEM/XW
52374 XMI3=ABS(XMI**3)
52375 TANB=RMSS(5)
52376 BETA=ATAN(TANB)
52377 CBETA=COS(BETA)
52378 SBETA=TANB*CBETA
52379 ALFA=RMSS(18)
52380
52381 DO 110 I=1,2
52382 DO 100 J=1,2
52383 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52384 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52385 100 CONTINUE
52386 110 CONTINUE
52387
52388C...GRAVITINO DECAY MODES
52389
52390 IF(IMSS(11).EQ.1) THEN
52391 XMP=RMSS(29)
52392 IDG=39+KSUSY1
52393 XMGR=PMAS(PYCOMP(IDG),1)
52394C SINW=SQRT(XW)
52395C COSW=SQRT(1D0-XW)
52396 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52397 IF(AXMI.GT.XMGR+XMW) THEN
52398 LKNT=LKNT+1
52399 IDLAM(LKNT,1)=IDG
52400 IDLAM(LKNT,2)=24
52401 IDLAM(LKNT,3)=0
52402 XLAM(LKNT)=XFAC*(
52403 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
52404 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
52405 & (1D0-XMW2/XMI2)**4
52406 ENDIF
52407 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
52408 LKNT=LKNT+1
52409 IDLAM(LKNT,1)=IDG
52410 IDLAM(LKNT,2)=37
52411 IDLAM(LKNT,3)=0
52412 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
52413 & (ABS(UMIXC(IX,2))*SBETA)**2))
52414 & *(1D0-PMAS(37,1)**2/XMI2)**4
52415 ENDIF
52416 ENDIF
52417
52418C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52419 IF(IX.EQ.1) GOTO 170
52420 XMJ=SMW(1)
52421 AXMJ=ABS(XMJ)
52422 XMJ2=XMJ**2
52423
52424C...CHI_2+ -> CHI_1+ + Z0
52425 IF(AXMI.GE.AXMJ+XMZ) THEN
52426 LKNT=LKNT+1
52427 IJ=1
52428 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52429 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52430 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52431 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52432 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52433 GLR=DBLE(OLPP*DCONJG(ORPP))
52434 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52435 IDLAM(LKNT,1)=KFCCHI(1)
52436 IDLAM(LKNT,2)=23
52437 IDLAM(LKNT,3)=0
52438
52439C...CHARGED LEPTONS
52440 ELSEIF(AXMI.GE.AXMJ) THEN
52441 S12MIN=0D0
52442 S12MAX=(AXMI-AXMJ)**2
52443 IA=11
52444 JA=12
52445 EI=KCHG(IABS(IA),1)/3D0
52446 T3I=SIGN(1D0,EI+1D-6)/2D0
52447 XXC(1)=0D0
52448 XXC(2)=XMJ
52449 XXC(3)=0D0
52450 XXC(4)=XMI
52451 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52452 XXC(6)=1D6
52453 XXC(9)=PMAS(23,1)
52454 XXC(10)=PMAS(23,2)
52455 IJ=1
52456 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
52457 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
52458 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
52459 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
52460 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52461 CXC(2)=DCMPLX(0D0,0D0)
52462 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52463 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52464 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52465 CXC(6)=DCMPLX(0D0,0D0)
52466 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52467 CXC(8)=DCMPLX(0D0,0D0)
52468 IF( XXC(5).LT.AXMI ) THEN
52469 XXC(5)=1D6
52470 ENDIF
52471 XXC(7)=XXC(5)
52472 XXC(8)=XXC(6)
52473 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52474 LKNT=LKNT+1
52475 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52476 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52477 IDLAM(LKNT,1)=KFCCHI(1)
52478 IDLAM(LKNT,2)=11
52479 IDLAM(LKNT,3)=-11
52480 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52481 LKNT=LKNT+1
52482 XLAM(LKNT)=XLAM(LKNT-1)
52483 IDLAM(LKNT,1)=KFCCHI(1)
52484 IDLAM(LKNT,2)=13
52485 IDLAM(LKNT,3)=-13
52486 ENDIF
52487 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52488 LKNT=LKNT+1
52489 XLAM(LKNT)=XLAM(LKNT-1)
52490 IDLAM(LKNT,1)=KFCCHI(1)
52491 IDLAM(LKNT,2)=15
52492 IDLAM(LKNT,3)=-15
52493 ENDIF
52494 ENDIF
52495
52496C...NEUTRINOS
52497 120 CONTINUE
52498 IA=12
52499 JA=11
52500 EI=KCHG(IABS(IA),1)/3D0
52501 T3I=SIGN(1D0,EI+1D-6)/2D0
52502 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52503 XXC(6)=1D6
52504 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52505 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52506 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52507 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52508 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52509 IF( XXC(5).LT.AXMI ) THEN
52510 XXC(5)=1D6
52511 ENDIF
52512 XXC(7)=XXC(5)
52513 XXC(8)=XXC(6)
52514 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
52515 LKNT=LKNT+1
52516 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52517 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52518 IDLAM(LKNT,1)=KFCCHI(1)
52519 IDLAM(LKNT,2)=12
52520 IDLAM(LKNT,3)=-12
52521 LKNT=LKNT+1
52522 XLAM(LKNT)=XLAM(LKNT-1)
52523 IDLAM(LKNT,1)=KFCCHI(1)
52524 IDLAM(LKNT,2)=14
52525 IDLAM(LKNT,3)=-14
52526 ENDIF
52527 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
52528 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52529 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52530 ELSE
52531 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52532 ENDIF
52533 IF( XXC(5).LT.AXMI ) THEN
52534 XXC(5)=1D6
52535 ENDIF
52536 XXC(7)=XXC(5)
52537 LKNT=LKNT+1
52538 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52539 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52540 IDLAM(LKNT,1)=KFCCHI(1)
52541 IDLAM(LKNT,2)=16
52542 IDLAM(LKNT,3)=-16
52543 ENDIF
52544
52545C...D-TYPE QUARKS
52546 130 CONTINUE
52547 IA=1
52548 JA=2
52549 EI=KCHG(IABS(IA),1)/3D0
52550 T3I=SIGN(1D0,EI+1D-6)/2D0
52551 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52552 XXC(6)=1D6
52553 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52554 CXC(2)=DCMPLX(0D0,0D0)
52555 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52556 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
52557 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52558 CXC(6)=DCMPLX(0D0,0D0)
52559 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52560 CXC(8)=DCMPLX(0D0,0D0)
52561 IF( XXC(5).LT.AXMI ) THEN
52562 XXC(5)=1D6
52563 ENDIF
52564 XXC(7)=XXC(5)
52565 XXC(8)=XXC(6)
52566 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52567 LKNT=LKNT+1
52568 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52569 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52570 IDLAM(LKNT,1)=KFCCHI(1)
52571 IDLAM(LKNT,2)=1
52572 IDLAM(LKNT,3)=-1
52573 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52574 LKNT=LKNT+1
52575 XLAM(LKNT)=XLAM(LKNT-1)
52576 IDLAM(LKNT,1)=KFCCHI(1)
52577 IDLAM(LKNT,2)=3
52578 IDLAM(LKNT,3)=-3
52579 ENDIF
52580 ENDIF
52581 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52582 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52583 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52584 ELSE
52585 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52586 ENDIF
52587 IF( XXC(5).LT.AXMI ) THEN
52588 XXC(5)=1D6
52589 ENDIF
52590 XXC(7)=XXC(5)
52591 LKNT=LKNT+1
52592 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52593 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52594 IDLAM(LKNT,1)=KFCCHI(1)
52595 IDLAM(LKNT,2)=5
52596 IDLAM(LKNT,3)=-5
52597 ENDIF
52598
52599C...U-TYPE QUARKS
52600 140 CONTINUE
52601 IA=2
52602 JA=1
52603 EI=KCHG(IABS(IA),1)/3D0
52604 T3I=SIGN(1D0,EI+1D-6)/2D0
52605 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52606 XXC(6)=1D6
52607 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
52608 CXC(2)=DCMPLX(0D0,0D0)
52609 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
52610 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
52611 CXC(5)=-DCMPLX(EI/XW1)*ORPP
52612 CXC(6)=DCMPLX(0D0,0D0)
52613 CXC(7)=-DCMPLX(EI/XW1)*OLPP
52614 CXC(8)=DCMPLX(0D0,0D0)
52615 IF( XXC(5).LT.AXMI ) THEN
52616 XXC(5)=1D6
52617 ENDIF
52618 XXC(7)=XXC(5)
52619 XXC(8)=XXC(6)
52620 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52621 LKNT=LKNT+1
52622 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52623 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52624 IDLAM(LKNT,1)=KFCCHI(1)
52625 IDLAM(LKNT,2)=2
52626 IDLAM(LKNT,3)=-2
52627 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52628 LKNT=LKNT+1
52629 XLAM(LKNT)=XLAM(LKNT-1)
52630 IDLAM(LKNT,1)=KFCCHI(1)
52631 IDLAM(LKNT,2)=4
52632 IDLAM(LKNT,3)=-4
52633 ENDIF
52634 ENDIF
52635 150 CONTINUE
52636 ENDIF
52637
52638C...CHI_2+ -> CHI_1+ + H0_K
52639 EH(2)=COS(ALFA)
52640 EH(1)=SIN(ALFA)
52641 EH(3)=-SBETA
52642 DH(2)=-SIN(ALFA)
52643 DH(1)=COS(ALFA)
52644 DH(3)=COS(BETA)
52645 DO 160 IH=1,3
52646 XMH=PMAS(ITH(IH),1)
52647 XMH2=XMH**2
52648C...NO 3-BODY OPTION
52649 IF(AXMI.GE.AXMJ+XMH) THEN
52650 LKNT=LKNT+1
52651 XL=PYLAMF(XMI2,XMJ2,XMH2)
52652 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
52653 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
52654 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
52655 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
52656 XMK=XMJ*ETAH(IH)
52657 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52658 GLR=DBLE(OLPP*DCONJG(ORPP))
52659 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52660 IDLAM(LKNT,1)=KFCCHI(1)
52661 IDLAM(LKNT,2)=ITH(IH)
52662 IDLAM(LKNT,3)=0
52663 ENDIF
52664 160 CONTINUE
52665
52666C...CHI1 JUMPS TO HERE
52667 170 CONTINUE
52668
52669C...CHI+_I -> CHI0_J + W+
52670 DO 220 IJ=1,4
52671 XMJ=SMZ(IJ)
52672 AXMJ=ABS(XMJ)
52673 XMJ2=XMJ**2
52674 IF(AXMI.GE.AXMJ+XMW) THEN
52675 LKNT=LKNT+1
52676 DO 180 I=1,4
52677 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52678 180 CONTINUE
52679 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52680 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
52681 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52682 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
52683 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52684 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52685 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52686 IDLAM(LKNT,1)=KFNCHI(IJ)
52687 IDLAM(LKNT,2)=24
52688 IDLAM(LKNT,3)=0
52689C...LEPTONS
52690 ELSEIF(AXMI.GE.AXMJ) THEN
52691 S12MIN=0D0
52692 S12MAX=(AXMI-AXMJ)**2
52693 DO 190 I=1,4
52694 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
52695 190 CONTINUE
52696 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
52697 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
52698 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
52699 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
52700 CXC(5)=DCMPLX(0D0,0D0)
52701 CXC(7)=DCMPLX(0D0,0D0)
52702 IA=11
52703 JA=12
52704 EI=KCHG(IA,1)/3D0
52705 T3I=SIGN(1D0,EI+1D-6)/2D0
52706 EJ=KCHG(JA,1)/3D0
52707 T3J=SIGN(1D0,EJ+1D-6)/2D0
52708 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52709 & TANW+ZMIXC(IJ,2)*T3J)/SR2
52710 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52711 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
52712 CXC(6)=DCMPLX(0D0,0D0)
52713 CXC(8)=DCMPLX(0D0,0D0)
52714 XXC(1)=0D0
52715 XXC(2)=XMJ
52716 XXC(3)=0D0
52717 XXC(4)=XMI
52718 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52719 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52720 XXC(9)=PMAS(24,1)
52721 XXC(10)=PMAS(24,2)
52722CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52723 IF(XXC(5).LT.AXMI) THEN
52724 XXC(5)=1D6
52725 ELSEIF(XXC(6).LT.AXMI) THEN
52726 XXC(6)=1D6
52727 ENDIF
52728 XXC(7)=XXC(6)
52729 XXC(8)=XXC(5)
52730C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
52731C...--> 1/(16PI)/M**3*(AEM/XW)**2
52732 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52733 LKNT=LKNT+1
52734 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52735 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52736 IDLAM(LKNT,1)=KFNCHI(IJ)
52737 IDLAM(LKNT,2)=-11
52738 IDLAM(LKNT,3)=12
52739C...ONLY DECAY CHI+1 -> E+ NU_E
52740 IF( IMSS(12).NE. 0 ) GOTO 260
52741 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52742 LKNT=LKNT+1
52743 XLAM(LKNT)=XLAM(LKNT-1)
52744 IDLAM(LKNT,1)=KFNCHI(IJ)
52745 IDLAM(LKNT,2)=-13
52746 IDLAM(LKNT,3)=14
52747 ENDIF
52748 ENDIF
52749 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52750 LKNT=LKNT+1
52751 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52752 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52753 ELSE
52754 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52755 ENDIF
52756 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52757 IF(XXC(5).LT.AXMI) THEN
52758 XXC(5)=1D6
52759 ELSEIF(XXC(6).LT.AXMI) THEN
52760 XXC(6)=1D6
52761 ENDIF
52762 XXC(7)=XXC(6)
52763 XXC(8)=XXC(5)
52764 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52765 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
52766 IDLAM(LKNT,1)=KFNCHI(IJ)
52767 IDLAM(LKNT,2)=-15
52768 IDLAM(LKNT,3)=16
52769 ENDIF
52770
52771C...NOW, DO THE QUARKS
52772 200 CONTINUE
52773 IA=1
52774 JA=2
52775 EI=KCHG(IA,1)/3D0
52776 T3I=SIGN(1D0,EI+1D-6)/2D0
52777 EJ=KCHG(JA,1)/3D0
52778 T3J=SIGN(1D0,EJ+1D-6)/2D0
52779 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
52780 & TANW+ZMIXC(IJ,2)*T3J)
52781 CXC(4)=-DCONJG(UMIXC(IX,1))*(
52782 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
52783 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52784 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52785 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
52786 IF(XXC(5).LT.AXMI) THEN
52787 XXC(5)=1D6
52788 ENDIF
52789 IF(XXC(6).LT.AXMI) THEN
52790 XXC(6)=1D6
52791 ENDIF
52792 XXC(7)=XXC(6)
52793 XXC(8)=XXC(5)
52794 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52795 LKNT=LKNT+1
52796 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52797 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52798 IDLAM(LKNT,1)=KFNCHI(IJ)
52799 IDLAM(LKNT,2)=-1
52800 IDLAM(LKNT,3)=2
52801 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52802 LKNT=LKNT+1
52803 XLAM(LKNT)=XLAM(LKNT-1)
52804 IDLAM(LKNT,1)=KFNCHI(IJ)
52805 IDLAM(LKNT,2)=-3
52806 IDLAM(LKNT,3)=4
52807 ENDIF
52808 ENDIF
52809 210 CONTINUE
52810 ENDIF
52811 220 CONTINUE
52812
52813C...CHI+_I -> CHI0_J + H+
52814 DO 230 IJ=1,4
52815 XMJ=SMZ(IJ)
52816 AXMJ=ABS(XMJ)
52817 XMJ2=XMJ**2
52818 XMHP=PMAS(ITHC,1)
52819 IF(AXMI.GE.AXMJ+XMHP) THEN
52820 LKNT=LKNT+1
52821 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
52822 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
52823 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
52824 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
52825 & UMIXC(IX,2)/SR2)
52826 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52827 GLR=DBLE(OLPP*DCONJG(ORPP))
52828 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52829 IDLAM(LKNT,1)=KFNCHI(IJ)
52830 IDLAM(LKNT,2)=ITHC
52831 IDLAM(LKNT,3)=0
52832 ELSE
52833
52834 ENDIF
52835 230 CONTINUE
52836
52837C...2-BODY DECAYS TO FERMION SFERMION
52838 DO 240 J=1,16
52839 IF(J.GE.7.AND.J.LE.10) GOTO 240
52840 IF(MOD(J,2).EQ.0) THEN
52841 KF1=KSUSY1+J-1
52842 ELSE
52843 KF1=KSUSY1+J+1
52844 ENDIF
52845 KF2=KF1+KSUSY1
52846 XMSF1=PMAS(PYCOMP(KF1),1)
52847 XMSF2=PMAS(PYCOMP(KF2),1)
52848 XMF=PMAS(J,1)
52849 IF(J.LE.6) THEN
52850 FCOL=3D0
52851 ELSE
52852 FCOL=1D0
52853 ENDIF
52854
52855C...U~ D_L
52856 IF(MOD(J,2).EQ.0) THEN
52857 XMFP=PMAS(J-1,1)
52858 CAL=UMIXC(IX,1)
52859 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
52860 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
52861 CBR=0D0
52862 ISF=J-1
52863 ELSE
52864 XMFP=PMAS(J+1,1)
52865 CAL=VMIXC(IX,1)
52866 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
52867 CBR=0D0
52868 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
52869 ISF=J+1
52870 ENDIF
52871
52872C...~U_L D
52873 IF(AXMI.GE.XMF+XMSF1) THEN
52874 LKNT=LKNT+1
52875 XMA2=XMSF1**2
52876 XMB2=XMF**2
52877 XL=PYLAMF(XMI2,XMA2,XMB2)
52878 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
52879 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
52880 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52881 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52882 IDLAM(LKNT,3)=0
52883 IF(MOD(J,2).EQ.0) THEN
52884 IDLAM(LKNT,1)=-KF1
52885 IDLAM(LKNT,2)=J
52886 ELSE
52887 IDLAM(LKNT,1)=KF1
52888 IDLAM(LKNT,2)=-J
52889 ENDIF
52890 ENDIF
52891
52892C...U~ D_R
52893 IF(AXMI.GE.XMF+XMSF2) THEN
52894 LKNT=LKNT+1
52895 XMA2=XMSF2**2
52896 XMB2=XMF**2
52897 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
52898 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
52899 XL=PYLAMF(XMI2,XMA2,XMB2)
52900 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52901 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52902 IDLAM(LKNT,3)=0
52903 IF(MOD(J,2).EQ.0) THEN
52904 IDLAM(LKNT,1)=-KF2
52905 IDLAM(LKNT,2)=J
52906 ELSE
52907 IDLAM(LKNT,1)=KF2
52908 IDLAM(LKNT,2)=-J
52909 ENDIF
52910 ENDIF
52911 240 CONTINUE
52912
52913C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
52914C...A 2-BODY -- 2-BODY CHAIN
52915 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52916 IF(AXMI.GE.XMJ) THEN
52917 AXMJ=ABS(XMJ)
52918 S12MIN=0D0
52919 S12MAX=(AXMI-AXMJ)**2
52920 XXC(1)=0D0
52921 XXC(2)=XMJ
52922 XXC(3)=0D0
52923 XXC(4)=XMI
52924 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
52925 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
52926 XXC(9)=1D6
52927 XXC(10)=0D0
52928 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
52929 ORPP=DCONJG(OLPP)
52930 CXC(1)=DCMPLX(0D0,0D0)
52931 CXC(3)=DCMPLX(0D0,0D0)
52932 CXC(5)=DCMPLX(0D0,0D0)
52933 CXC(7)=DCMPLX(0D0,0D0)
52934 CXC(2)=UMIXC(IX,1)*OLPP/SR2
52935 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
52936 CXC(6)=DCMPLX(0D0,0D0)
52937 CXC(8)=DCMPLX(0D0,0D0)
52938 IF(XXC(5).LT.AXMI) THEN
52939 XXC(5)=1D6
52940 ELSEIF(XXC(6).LT.AXMI) THEN
52941 XXC(6)=1D6
52942 ENDIF
52943 XXC(7)=XXC(6)
52944 XXC(8)=XXC(5)
52945 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
52946 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
52947 LKNT=LKNT+1
52948 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
52949 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52950 IDLAM(LKNT,1)=KSUSY1+21
52951 IDLAM(LKNT,2)=-1
52952 IDLAM(LKNT,3)=2
52953 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52954 LKNT=LKNT+1
52955 XLAM(LKNT)=XLAM(LKNT-1)
52956 IDLAM(LKNT,1)=KSUSY1+21
52957 IDLAM(LKNT,2)=-3
52958 IDLAM(LKNT,3)=4
52959 ENDIF
52960 ENDIF
52961 250 CONTINUE
52962 ENDIF
52963
52964C...R-violating decay modes (SKANDS).
52965 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
52966
52967 260 IKNT=LKNT
52968 XLAM(0)=0D0
52969 DO 270 I=1,IKNT
52970 XLAM(0)=XLAM(0)+XLAM(I)
52971 IF(XLAM(I).LT.0D0) THEN
52972 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
52973 & (IDLAM(I,J),J=1,3)
52974 XLAM(I)=0D0
52975 ENDIF
52976 270 CONTINUE
52977 IF(XLAM(0).EQ.0D0) THEN
52978 XLAM(0)=1D-6
52979 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
52980 WRITE(MSTU(11),*) LKNT
52981 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
52982 ENDIF
52983
52984 RETURN
52985 END
52986
52987C*********************************************************************
52988
52989C...PYXXZ6
52990C...Used in the calculation of inoi -> inoj + f + ~f.
52991
52992 FUNCTION PYXXZ6(X)
52993
52994C...Double precision and integer declarations.
52995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52996 IMPLICIT INTEGER(I-N)
52997 INTEGER PYK,PYCHGE,PYCOMP
52998C...Parameter statement to help give large particle numbers.
52999 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53000 &KEXCIT=4000000,KDIMEN=5000000)
53001C...Commonblocks.
53002 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53003C COMMON/PYINTS/XXM(20)
53004 COMPLEX*16 CXC
53005 COMMON/PYINTC/XXC(10),CXC(8)
53006 SAVE /PYDAT1/,/PYINTC/
53007
53008C...Local variables.
53009 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53010 DOUBLE PRECISION PYXXZ6,X
53011 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53012 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53013 DOUBLE PRECISION SIJ
53014 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53015 DOUBLE PRECISION OL2
53016 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53017 INTEGER I
53018
53019C...Statement functions.
53020C...Integral from x to y of (t-a)(b-t) dt.
53021 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53022C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53023 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53024 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53025C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53026 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53027 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53028C...Integral from x to y of (t-a)/(b-t) dt.
53029 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53030C...Integral from x to y of 1/(t-a) dt.
53031 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53032
53033 XM12=XXC(1)**2
53034 XM22=XXC(2)**2
53035 XM32=XXC(3)**2
53036 S=XXC(4)**2
53037 S13=X
53038
53039 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53040 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53041 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53042
53043 S23MIN=(S23AVE-S23DEL)
53044 S23MAX=(S23AVE+S23DEL)
53045
53046 XMSD1=XXC(5)**2
53047 XMSD2=XXC(7)**2
53048 XMSU1=XXC(6)**2
53049 XMSU2=XXC(8)**2
53050
53051 XMV=XXC(9)
53052 XMG=XXC(10)
53053 QLLS=CXC(1)
53054 QLLU=CXC(2)
53055 QLRS=CXC(3)
53056 QLRT=CXC(4)
53057 QRLS=CXC(5)
53058 QRLT=CXC(6)
53059 QRRS=CXC(7)
53060 QRRU=CXC(8)
53061 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53062 SIJ=2D0*XXC(2)*XXC(4)*S13
53063 IF(XMV.LE.1000D0) THEN
53064 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53065 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53066 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53067 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53068 IF(XXC(5).LE.10000D0) THEN
53069 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53070 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53071 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53072 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53073 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53074 & *(S13-XMV**2)/WPROP2
53075 ELSE
53076 WFL1=0D0
53077 ENDIF
53078
53079 IF(XXC(6).LE.10000D0) THEN
53080 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53081 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53082 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53083 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53084 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53085 & *(S13-XMV**2)/WPROP2
53086 ELSE
53087 WFL2=0D0
53088 ENDIF
53089 ELSE
53090 WW=0D0
53091 WFL1=0D0
53092 WFL2=0D0
53093 ENDIF
53094 IF(XXC(5).LE.10000D0) THEN
53095 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53096 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53097 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53098 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53099 ELSE
53100 WF1=0D0
53101 ENDIF
53102 IF(XXC(6).LE.10000D0) THEN
53103 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53104 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53105 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53106 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53107 ELSE
53108 WF2=0D0
53109 ENDIF
53110
53111 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53112
53113 IF(PYXXZ6.LT.0D0) THEN
53114 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53115 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53116 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53117 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53118 WRITE(MSTU(11),*) S23MIN,S23MAX
53119 PYXXZ6=0D0
53120 ENDIF
53121
53122 RETURN
53123 END
53124
53125
53126C*********************************************************************
53127
53128C...PYXXGA
53129C...Calculates chi0_i -> chi0_j + gamma.
53130
53131 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53132
53133C...Double precision and integer declarations.
53134 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53135 IMPLICIT INTEGER(I-N)
53136 INTEGER PYK,PYCHGE,PYCOMP
53137
53138C...Local variables.
53139 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53140 DOUBLE PRECISION F1,F2
53141
53142 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53143 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53144 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53145 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53146
53147 RETURN
53148 END
53149
53150C*********************************************************************
53151
53152C...PYX2XG
53153C...Calculates the decay rate for ino -> ino + gauge boson.
53154
53155 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53156
53157C...Double precision and integer declarations.
53158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53159 IMPLICIT INTEGER(I-N)
53160 INTEGER PYK,PYCHGE,PYCOMP
53161
53162C...Local variables.
53163 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53164 DOUBLE PRECISION XL,PYLAMF,C1
53165 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53166
53167 XMI2=XM1**2
53168 XMI3=ABS(XM1**3)
53169 XMJ2=XM2**2
53170 XMV2=XM3**2
53171 XL=PYLAMF(XMI2,XMJ2,XMV2)
53172 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53173 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53174 &12D0*GLR*XM1*XM2*XMV2)
53175
53176 RETURN
53177 END
53178
53179C*********************************************************************
53180
53181C...PYX2XH
53182C...Calculates the decay rate for ino -> ino + H.
53183
53184 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53185
53186C...Double precision and integer declarations.
53187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53188 IMPLICIT INTEGER(I-N)
53189 INTEGER PYK,PYCHGE,PYCOMP
53190
53191C...Local variables.
53192 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53193 DOUBLE PRECISION XL,PYLAMF,C1
53194 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53195
53196 XMI2=XM1**2
53197 XMI3=ABS(XM1**3)
53198 XMJ2=XM2**2
53199 XMV2=XM3**2
53200 XL=PYLAMF(XMI2,XMJ2,XMV2)
53201 PYX2XH=C1/8D0/XMI3*SQRT(XL)
53202 &*(GX2*(XMI2+XMJ2-XMV2)+
53203 &4D0*GLR*XM1*XM2)
53204
53205 RETURN
53206 END
53207
53208C*********************************************************************
53209
53210C...PYHEXT
53211C...Calculates the non-standard decay modes of the Higgs boson.
53212C...
53213C...Author: Stephen Mrenna
53214C...Last Update: April 2001
53215C......Allow complex values for Z,U, and V
53216
53217 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
53218
53219C...Double precision and integer declarations.
53220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53221 IMPLICIT INTEGER(I-N)
53222 INTEGER PYK,PYCHGE,PYCOMP
53223C...Parameter statement to help give large particle numbers.
53224 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53225 &KEXCIT=4000000,KDIMEN=5000000)
53226C...Commonblocks.
53227 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53228 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53229 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53231 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53232 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53233 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
53234
53235C...Local variables.
53236 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53237 COMPLEX*16 QIJ,RIJ,F21K,F12K
53238 INTEGER KFIN
53239 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
53240 DOUBLE PRECISION XMI2,XMI3,XMJ2
53241 DOUBLE PRECISION PYLAMF,XL,CF,EI
53242 INTEGER IDU,IFL
53243 DOUBLE PRECISION TANW,XW,AEM,C1,AS
53244 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
53245 DOUBLE PRECISION XLAM(0:400)
53246 INTEGER IDLAM(400,3)
53247 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
53248 INTEGER ITH(4)
53249 INTEGER KFNCHI(4),KFCCHI(2)
53250 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
53251 DOUBLE PRECISION SR2
53252 DOUBLE PRECISION BETA,ALFA
53253 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
53254 DOUBLE PRECISION PYALEM
53255 DOUBLE PRECISION AL,AR,ALR
53256 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
53257 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
53258 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
53259 DATA ITH/25,35,36,37/
53260 DATA ETAH/1D0,1D0,-1D0/
53261 DATA SR2/1.4142136D0/
53262 DATA KFNCHI/1000022,1000023,1000025,1000035/
53263 DATA KFCCHI/1000024,1000037/
53264
53265C...COUNT THE NUMBER OF DECAY MODES
53266 LKNT=IKNT
53267
53268 XMW=PMAS(24,1)
53269 XMW2=XMW**2
53270 XMZ=PMAS(23,1)
53271 XW=PARU(102)
53272 TANW = SQRT(XW/(1D0-XW))
53273 CW=SQRT(1D0-XW)
53274
53275C...1 - 4 DEPENDING ON Higgs species.
53276 IH=1
53277 IF(KFIN.EQ.ITH(2)) IH=2
53278 IF(KFIN.EQ.ITH(3)) IH=3
53279 IF(KFIN.EQ.ITH(4)) IH=4
53280
53281 XMI=PMAS(KFIN,1)
53282 XMI2=XMI**2
53283 AXMI=ABS(XMI)
53284 AEM=PYALEM(XMI2)
53285 C1=AEM/XW
53286 XMI3=ABS(XMI**3)
53287
53288 TANB=RMSS(5)
53289 BETA=ATAN(TANB)
53290 CBETA=COS(BETA)
53291 SBETA=TANB*CBETA
53292 ALFA=RMSS(18)
53293 COSA=COS(ALFA)
53294 SINA=SIN(ALFA)
53295 ATRIT=RMSS(16)
53296 ATRIB=RMSS(15)
53297 ATRIL=RMSS(17)
53298 XMUZ=-RMSS(4)
53299
53300 DO 110 I=1,4
53301 DO 100 J=1,4
53302 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
53303 100 CONTINUE
53304 110 CONTINUE
53305 DO 130 I=1,2
53306 DO 120 J=1,2
53307 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53308 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53309 120 CONTINUE
53310 130 CONTINUE
53311
53312
53313 IF(IH.EQ.4) GOTO 220
53314
53315C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53316C...H0_K -> CHI0_I + CHI0_J
53317 EH(2)=SINA
53318 EH(1)=COSA
53319 EH(3)=CBETA
53320 DH(2)=COSA
53321 DH(1)=-SINA
53322 DH(3)=SBETA
53323 DO 150 IJ=1,4
53324 XMJ=SMZ(IJ)
53325 AXMJ=ABS(XMJ)
53326 DO 140 IK=1,IJ
53327 XMK=SMZ(IK)
53328 AXMK=ABS(XMK)
53329 IF(AXMI.GE.AXMJ+AXMK) THEN
53330 LKNT=LKNT+1
53331 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
53332 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
53333 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
53334 & ZMIXC(IJ,3)*ZMIXC(IK,1))
53335 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
53336 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
53337 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
53338 & ZMIXC(IJ,4)*ZMIXC(IK,1))
53339 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
53340 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
53341C...SIGN OF MASSES I,J
53342 XML=XMK*ETAH(IH)
53343 GX2=ABS(F12K)**2+ABS(F21K)**2
53344 GLR=DBLE(F12K*DCONJG(F21K))
53345 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53346 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
53347 IDLAM(LKNT,1)=KFNCHI(IJ)
53348 IDLAM(LKNT,2)=KFNCHI(IK)
53349 IDLAM(LKNT,3)=0
53350 ENDIF
53351 140 CONTINUE
53352 150 CONTINUE
53353
53354C...H0_K -> CHI+_I CHI-_J
53355 DO 170 IJ=1,2
53356 XMJ=SMW(IJ)
53357 AXMJ=ABS(XMJ)
53358 DO 160 IK=1,2
53359 XMK=SMW(IK)
53360 AXMK=ABS(XMK)
53361 IF(AXMI.GE.AXMJ+AXMK) THEN
53362 LKNT=LKNT+1
53363 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
53364 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
53365 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
53366 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
53367 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53368 GLR=DBLE(OLPP*DCONJG(ORPP))
53369 XML=XMK*ETAH(IH)
53370 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
53371 IDLAM(LKNT,1)=KFCCHI(IJ)
53372 IDLAM(LKNT,2)=-KFCCHI(IK)
53373 IDLAM(LKNT,3)=0
53374 ENDIF
53375 160 CONTINUE
53376 170 CONTINUE
53377
53378C...HIGGS TO SFERMION SFERMION
53379 DO 200 IFL=1,16
53380 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
53381 IJ=KSUSY1+IFL
53382 XMJL=PMAS(PYCOMP(IJ),1)
53383 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
53384 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
53385 XMJ=XMJL
53386 XMJ2=XMJ**2
53387 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53388 XMF=PMAS(IFL,1)
53389 EI=KCHG(IFL,1)/3D0
53390 IDU=2-MOD(IFL,2)
53391
53392 IF(IH.EQ.1) THEN
53393 IF(IDU.EQ.1) THEN
53394 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
53395 & XMF**2/XMW*SINA/CBETA
53396 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
53397 & XMF**2/XMW*SINA/CBETA
53398 IF(IFL.EQ.5) THEN
53399 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53400 & ATRIB*SINA)
53401 ELSEIF(IFL.EQ.15) THEN
53402 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
53403 & ATRIL*SINA)
53404 ELSE
53405 GHLR=0D0
53406 ENDIF
53407 ELSE
53408 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
53409 & XMF**2/XMW*COSA/SBETA
53410 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
53411 & XMF**2/XMW*COSA/SBETA
53412 IF(IFL.EQ.6) THEN
53413 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
53414 & ATRIT*COSA)
53415 ELSE
53416 GHLR=0D0
53417 ENDIF
53418 ENDIF
53419
53420 ELSEIF(IH.EQ.2) THEN
53421 IF(IDU.EQ.1) THEN
53422 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
53423 & XMF**2/XMW*COSA/CBETA
53424 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53425 & XMF**2/XMW*COSA/CBETA
53426 IF(IFL.EQ.5) THEN
53427 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53428 & ATRIB*COSA)
53429 ELSEIF(IFL.EQ.15) THEN
53430 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
53431 & ATRIL*COSA)
53432 ELSE
53433 GHLR=0D0
53434 ENDIF
53435 ELSE
53436 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
53437 & XMF**2/XMW*SINA/SBETA
53438 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
53439 & XMF**2/XMW*SINA/SBETA
53440 IF(IFL.EQ.6) THEN
53441 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
53442 & ATRIT*SINA)
53443 ELSE
53444 GHLR=0D0
53445 ENDIF
53446 ENDIF
53447
53448 ELSEIF(IH.EQ.3) THEN
53449 GHLL=0D0
53450 GHRR=0D0
53451 GHLR=0D0
53452 IF(IDU.EQ.1) THEN
53453 IF(IFL.EQ.5) THEN
53454 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
53455 ELSEIF(IFL.EQ.15) THEN
53456 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
53457 ENDIF
53458 ELSE
53459 IF(IFL.EQ.6) THEN
53460 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
53461 ENDIF
53462 ENDIF
53463 ENDIF
53464 IF(IH.EQ.3) GOTO 180
53465
53466 AL=SFMIX(IFL,1)**2
53467 AR=SFMIX(IFL,2)**2
53468 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
53469 IF(IFL.LE.6) THEN
53470 CF=3D0
53471 ELSE
53472 CF=1D0
53473 ENDIF
53474
53475 IF(AXMI.GE.2D0*XMJ) THEN
53476 LKNT=LKNT+1
53477 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53478 & (GHLL*AL+GHRR*AR
53479 & +2D0*GHLR*ALR)**2
53480 IDLAM(LKNT,1)=IJ
53481 IDLAM(LKNT,2)=-IJ
53482 IDLAM(LKNT,3)=0
53483 ENDIF
53484
53485 IF(AXMI.GE.2D0*XMJR) THEN
53486 LKNT=LKNT+1
53487 AL=SFMIX(IFL,3)**2
53488 AR=SFMIX(IFL,4)**2
53489 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
53490 XMJ=XMJR
53491 XMJ2=XMJ**2
53492 XL=PYLAMF(XMI2,XMJ2,XMJ2)
53493 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53494 & (GHLL*AL+GHRR*AR
53495 & +2D0*GHLR*ALR)**2
53496 IDLAM(LKNT,1)=IJ+KSUSY1
53497 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53498 IDLAM(LKNT,3)=0
53499 ENDIF
53500 180 CONTINUE
53501
53502 IF(AXMI.GE.XMJL+XMJR) THEN
53503 LKNT=LKNT+1
53504 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
53505 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
53506 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
53507 XMJ=XMJR
53508 XMJ2=XMJ**2
53509 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
53510 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53511 & (GHLL*AL+GHRR*AR)**2
53512 IDLAM(LKNT,1)=IJ
53513 IDLAM(LKNT,2)=-(IJ+KSUSY1)
53514 IDLAM(LKNT,3)=0
53515 LKNT=LKNT+1
53516 IDLAM(LKNT,1)=-IJ
53517 IDLAM(LKNT,2)=IJ+KSUSY1
53518 IDLAM(LKNT,3)=0
53519 XLAM(LKNT)=XLAM(LKNT-1)
53520 ENDIF
53521 ENDIF
53522 190 CONTINUE
53523 200 CONTINUE
53524 210 CONTINUE
53525
53526 GOTO 270
53527 220 CONTINUE
53528
53529C...H+ -> CHI+_I + CHI0_J
53530 DO 240 IJ=1,4
53531 XMJ=SMZ(IJ)
53532 AXMJ=ABS(XMJ)
53533 XMJ2=XMJ**2
53534 DO 230 IK=1,2
53535 XMK=SMW(IK)
53536 AXMK=ABS(XMK)
53537 IF(AXMI.GE.AXMJ+AXMK) THEN
53538 LKNT=LKNT+1
53539 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
53540 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
53541 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
53542 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
53543 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53544 GLR=DBLE(OLPP*DCONJG(ORPP))
53545 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
53546 IDLAM(LKNT,1)=KFNCHI(IJ)
53547 IDLAM(LKNT,2)=KFCCHI(IK)
53548 IDLAM(LKNT,3)=0
53549 ENDIF
53550 230 CONTINUE
53551 240 CONTINUE
53552
53553 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
53554 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
53555 AL=0D0
53556 AR=0D0
53557 CF=3D0
53558
53559C...H+ -> T_1 B_1~
53560 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53561 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53562 IF(XMI.GE.XM1+XM2) THEN
53563 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53564 LKNT=LKNT+1
53565 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53566 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
53567 IDLAM(LKNT,1)=KSUSY1+6
53568 IDLAM(LKNT,2)=-(KSUSY1+5)
53569 IDLAM(LKNT,3)=0
53570 ENDIF
53571
53572C...H+ -> T_2 B_1~
53573 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53574 XM2=PMAS(PYCOMP(KSUSY1+5),1)
53575 IF(XMI.GE.XM1+XM2) THEN
53576 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53577 LKNT=LKNT+1
53578 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53579 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
53580 IDLAM(LKNT,1)=KSUSY2+6
53581 IDLAM(LKNT,2)=-(KSUSY1+5)
53582 IDLAM(LKNT,3)=0
53583 ENDIF
53584
53585C...H+ -> T_1 B_2~
53586 XM1=PMAS(PYCOMP(KSUSY1+6),1)
53587 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53588 IF(XMI.GE.XM1+XM2) THEN
53589 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53590 LKNT=LKNT+1
53591 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53592 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
53593 IDLAM(LKNT,1)=KSUSY1+6
53594 IDLAM(LKNT,2)=-(KSUSY2+5)
53595 IDLAM(LKNT,3)=0
53596 ENDIF
53597
53598C...H+ -> T_2 B_2~
53599 XM1=PMAS(PYCOMP(KSUSY2+6),1)
53600 XM2=PMAS(PYCOMP(KSUSY2+5),1)
53601 IF(XMI.GE.XM1+XM2) THEN
53602 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53603 LKNT=LKNT+1
53604 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
53605 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
53606 IDLAM(LKNT,1)=KSUSY2+6
53607 IDLAM(LKNT,2)=-(KSUSY2+5)
53608 IDLAM(LKNT,3)=0
53609 ENDIF
53610
53611C...H+ -> UL DL~
53612 GL=-XMW/SR2*SIN(2D0*BETA)
53613 DO 250 IJ=1,3,2
53614 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53615 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53616 IF(XMI.GE.XM1+XM2) THEN
53617 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53618 LKNT=LKNT+1
53619 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53620 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53621 IDLAM(LKNT,2)=KSUSY1+IJ+1
53622 IDLAM(LKNT,3)=0
53623 ENDIF
53624 250 CONTINUE
53625
53626C...H+ -> EL~ NUL
53627 CF=1D0
53628 DO 260 IJ=11,13,2
53629 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
53630 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
53631 IF(XMI.GE.XM1+XM2) THEN
53632 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53633 LKNT=LKNT+1
53634 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
53635 IDLAM(LKNT,1)=-(KSUSY1+IJ)
53636 IDLAM(LKNT,2)=KSUSY1+IJ+1
53637 IDLAM(LKNT,3)=0
53638 ENDIF
53639 260 CONTINUE
53640
53641C...H+ -> TAU1 NUTAUL
53642 XM1=PMAS(PYCOMP(KSUSY1+15),1)
53643 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53644 IF(XMI.GE.XM1+XM2) THEN
53645 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53646 LKNT=LKNT+1
53647 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
53648 IDLAM(LKNT,1)=-(KSUSY1+15)
53649 IDLAM(LKNT,2)= KSUSY1+16
53650 IDLAM(LKNT,3)=0
53651 ENDIF
53652
53653C...H+ -> TAU2 NUTAUL
53654 XM1=PMAS(PYCOMP(KSUSY2+15),1)
53655 XM2=PMAS(PYCOMP(KSUSY1+16),1)
53656 IF(XMI.GE.XM1+XM2) THEN
53657 XL=PYLAMF(XMI2,XM1**2,XM2**2)
53658 LKNT=LKNT+1
53659 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
53660 IDLAM(LKNT,1)=-(KSUSY2+15)
53661 IDLAM(LKNT,2)= KSUSY1+16
53662 IDLAM(LKNT,3)=0
53663 ENDIF
53664
53665 270 CONTINUE
53666 IKNT=LKNT
53667 XLAM(0)=0D0
53668 DO 280 I=1,IKNT
53669 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
53670 XLAM(0)=XLAM(0)+XLAM(I)
53671 280 CONTINUE
53672 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53673
53674 RETURN
53675 END
53676
53677C*********************************************************************
53678
53679C...PYH2XX
53680C...Calculates the decay rate for a Higgs to an ino pair.
53681
53682 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
53683
53684C...Double precision and integer declarations.
53685 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53686 IMPLICIT INTEGER(I-N)
53687 INTEGER PYK,PYCHGE,PYCOMP
53688C...Commonblocks.
53689 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53690 SAVE /PYDAT1/
53691
53692C...Local variables.
53693 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
53694 DOUBLE PRECISION XL,PYLAMF,C1
53695 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
53696
53697 XMI2=XM1**2
53698 XMI3=ABS(XM1**3)
53699 XMJ2=XM2**2
53700 XMK2=XM3**2
53701 XL=PYLAMF(XMI2,XMJ2,XMK2)
53702 PYH2XX=C1/4D0/XMI3*SQRT(XL)
53703 &*(GX2*(XMI2-XMJ2-XMK2)-
53704 &4D0*GLR*XM3*XM2)
53705 IF(PYH2XX.LT.0D0) PYH2XX=0D0
53706
53707 RETURN
53708 END
53709
53710C*********************************************************************
53711
53712C...PYGAUS
53713C...Integration by adaptive Gaussian quadrature.
53714C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53715
53716 FUNCTION PYGAUS(F, A, B, EPS)
53717
53718C...Double precision and integer declarations.
53719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53720 IMPLICIT INTEGER(I-N)
53721 INTEGER PYK,PYCHGE,PYCOMP
53722
53723C...Local declarations.
53724 EXTERNAL F
53725 DOUBLE PRECISION F,W(12), X(12)
53726 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53727 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53728 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53729 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53730 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53731 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53732 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53733 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53734 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53735 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53736 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53737 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53738
53739C...The Gaussian quadrature algorithm.
53740 H = 0D0
53741 IF(B .EQ. A) GOTO 140
53742 CONST = 5D-3 / ABS(B-A)
53743 BB = A
53744 100 CONTINUE
53745 AA = BB
53746 BB = B
53747 110 CONTINUE
53748 C1 = 0.5D0*(BB+AA)
53749 C2 = 0.5D0*(BB-AA)
53750 S8 = 0D0
53751 DO 120 I = 1, 4
53752 U = C2*X(I)
53753 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53754 120 CONTINUE
53755 S16 = 0D0
53756 DO 130 I = 5, 12
53757 U = C2*X(I)
53758 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53759 130 CONTINUE
53760 S16 = C2*S16
53761 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53762 H = H + S16
53763 IF(BB .NE. B) GOTO 100
53764 ELSE
53765 BB = C1
53766 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53767 H = 0D0
53768 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
53769 GOTO 140
53770 ENDIF
53771 140 CONTINUE
53772 PYGAUS = H
53773
53774 RETURN
53775 END
53776
53777C*********************************************************************
53778
53779C...PYGAU2
53780C...Integration by adaptive Gaussian quadrature.
53781C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
53782C...Carbon copy of PYGAUS, but avoids having to use it recursively.
53783
53784 FUNCTION PYGAU2(F, A, B, EPS)
53785
53786C...Double precision and integer declarations.
53787 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53788 IMPLICIT INTEGER(I-N)
53789 INTEGER PYK,PYCHGE,PYCOMP
53790
53791C...Local declarations.
53792 EXTERNAL F
53793 DOUBLE PRECISION F,W(12), X(12)
53794 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
53795 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
53796 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
53797 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
53798 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
53799 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
53800 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
53801 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
53802 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
53803 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
53804 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
53805 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
53806
53807C...The Gaussian quadrature algorithm.
53808 H = 0D0
53809 IF(B .EQ. A) GOTO 140
53810 CONST = 5D-3 / ABS(B-A)
53811 BB = A
53812 100 CONTINUE
53813 AA = BB
53814 BB = B
53815 110 CONTINUE
53816 C1 = 0.5D0*(BB+AA)
53817 C2 = 0.5D0*(BB-AA)
53818 S8 = 0D0
53819 DO 120 I = 1, 4
53820 U = C2*X(I)
53821 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
53822 120 CONTINUE
53823 S16 = 0D0
53824 DO 130 I = 5, 12
53825 U = C2*X(I)
53826 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
53827 130 CONTINUE
53828 S16 = C2*S16
53829 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
53830 H = H + S16
53831 IF(BB .NE. B) GOTO 100
53832 ELSE
53833 BB = C1
53834 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
53835 H = 0D0
53836 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
53837 GOTO 140
53838 ENDIF
53839 140 CONTINUE
53840 PYGAU2 = H
53841
53842 RETURN
53843 END
53844
53845C*********************************************************************
53846
53847C...PYSIMP
53848C...Simpson formula for an integral.
53849
53850 FUNCTION PYSIMP(Y,X0,X1,N)
53851
53852C...Double precision and integer declarations.
53853 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53854 IMPLICIT INTEGER(I-N)
53855 INTEGER PYK,PYCHGE,PYCOMP
53856
53857C...Local variables.
53858 DOUBLE PRECISION Y,X0,X1,H,S
53859 DIMENSION Y(0:N)
53860
53861 S=0D0
53862 H=(X1-X0)/N
53863 DO 100 I=0,N-2,2
53864 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
53865 100 CONTINUE
53866 PYSIMP=S*H/3D0
53867
53868 RETURN
53869 END
53870
53871C*********************************************************************
53872
53873C...PYLAMF
53874C...The standard lambda function.
53875
53876 FUNCTION PYLAMF(X,Y,Z)
53877
53878C...Double precision and integer declarations.
53879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53880 IMPLICIT INTEGER(I-N)
53881 INTEGER PYK,PYCHGE,PYCOMP
53882
53883C...Local variables.
53884 DOUBLE PRECISION PYLAMF,X,Y,Z
53885
53886 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
53887 IF(PYLAMF.LT.0D0) PYLAMF=0D0
53888
53889 RETURN
53890 END
53891
53892C*********************************************************************
53893
53894C...PYTBDY
53895C...Generates 3-body decays of gauginos.
53896
53897 SUBROUTINE PYTBDY(IDIN)
53898
53899C...Double precision and integer declarations.
53900 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53901 IMPLICIT INTEGER(I-N)
53902 INTEGER PYK,PYCHGE,PYCOMP
53903C...Parameter statement to help give large particle numbers.
53904 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53905 &KEXCIT=4000000,KDIMEN=5000000)
53906C...Commonblocks.
53907 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
53908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53909 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53910C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
53911C COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
53912 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53913 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53914C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
53915 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSSMT/
53916
53917C...Local variables.
53918 DOUBLE PRECISION XM(5)
53919 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
53920 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
53921 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
53922 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
53923 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
53924 DOUBLE PRECISION CPHI1,SPHI1
53925 DOUBLE PRECISION S23DEL,EPS
53926 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
53927 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
53928 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
53929 INTEGER INOID(4)
53930 DATA INOID/22,23,25,35/
53931 DATA EPS/1D-6/
53932
53933 ID=IDIN
53934 ISKIP=1
53935 XM(1)=P(N+1,5)
53936 XM(2)=P(N+2,5)
53937 XM(3)=P(N+3,5)
53938 XM(5)=P(ID,5)
53939
53940C...GENERATE S12
53941 S12MIN=(XM(1)+XM(2))**2
53942 S12MAX=(XM(5)-XM(3))**2
53943 YJACO1=S12MAX-S12MIN
53944
53945C...Initialize some parameters
53946 XW=PARU(102)
53947 XW1=1D0-XW
53948 TANW=SQRT(XW/XW1)
53949 IZID1=0
53950 IWID1=0
53951 IZID2=0
53952 IWID2=0
53953
53954 IA=K(N+2,2)
53955 JA=K(N+3,2)
53956
53957C...Mrenna: check that we are indeed decaying a SUSY particle
53958 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
53959
53960 ELSE
53961 DO 100 I1=1,4
53962 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
53963 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
53964 100 CONTINUE
53965 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
53966 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
53967 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
53968 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
53969 ZM12=XM(5)**2
53970 ZM22=XM(1)**2
53971 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
53972 T3I=SIGN(1D0,EI+1D-6)/2D0
53973 ENDIF
53974
53975 IF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
53976 ISKIP=0
53977 ELSEIF(IZID1*IZID2.NE.0) THEN
53978 SQMZ=PMAS(23,1)**2
53979 GMMZ=PMAS(23,1)*PMAS(23,2)
53980 DO 110 I=1,4
53981 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
53982 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
53983 110 CONTINUE
53984 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
53985 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
53986 ORPP=DCONJG(OLPP)
53987 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
53988 XLR2=XLL2
53989 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
53990 XRL2=XRR2
53991 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
53992 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
53993 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
53994 XM1M2=SMZ(IZID1)*SMZ(IZID2)
53995 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
53996 QLLU=-GLIJ
53997 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
53998 QLRT=DCONJG(GLIJ)
53999 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54000 QRLT=GRIJ
54001 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54002 QRRU=-DCONJG(GRIJ)
54003 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54004 IF(IZID1.NE.0) THEN
54005 XM1M2=SMZ(IZID1)*SMW(IWID2)
54006 IZID1=IWID2
54007 IZID2=IZID1
54008 ELSE
54009 XM1M2=SMZ(IZID2)*SMW(IWID1)
54010 IZID1=IWID1
54011 ENDIF
54012 RT2I = 1D0/SQRT(2D0)
54013 SQMZ=PMAS(24,1)**2
54014 GMMZ=PMAS(24,1)*PMAS(24,2)
54015 DO 120 I=1,2
54016 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54017 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54018 120 CONTINUE
54019 DO 130 I=1,4
54020 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54021 130 CONTINUE
54022 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54023 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54024 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54025 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54026 EJ=KCHG(IABS(JA),1)/3D0
54027 T3J=SIGN(1D0,EJ+1D-6)/2D0
54028 QRLS=DCMPLX(0D0,0D0)
54029 QRLT=QRLS
54030 QRRS=QRLS
54031 QRRU=QRLS
54032 XRR2=1D6**2
54033 XRL2=XRR2
54034 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54035 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54036 IF(MOD(IA,2).EQ.0) THEN
54037 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54038 & TANW+ZMIXC(IZID2,2)*T3I)
54039 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54040 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54041 ELSE
54042 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54043 & TANW+ZMIXC(IZID2,2)*T3J)
54044 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54045 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54046 ENDIF
54047 ELSEIF(IWID1*IWID2.NE.0) THEN
54048 IZID1=IWID1
54049 IZID2=IWID2
54050 XM1M2=SMW(IWID1)*SMW(IWID2)
54051 SQMZ=PMAS(23,1)**2
54052 GMMZ=PMAS(23,1)*PMAS(23,2)
54053 DO 140 I=1,2
54054 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54055 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54056 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54057 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54058 140 CONTINUE
54059 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54060 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54061 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54062 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54063 QRLS=-DCMPLX(EI/XW1)*ORPP
54064 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54065 QRRS=-DCMPLX(EI/XW1)*OLPP
54066 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54067 IF(MOD(IA,2).EQ.0) THEN
54068 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54069 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54070 ELSE
54071 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54072 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54073 ENDIF
54074 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54075 &THEN
54076 ISKIP=0
54077 ELSE
54078 ISKIP=0
54079 ENDIF
54080
54081 IF(ISKIP.NE.0) THEN
54082 WTMAX=0D0
54083 DO 160 KT=1,100
54084 S12=S12MIN+YJACO1*(KT-1)/99
54085 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54086 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54087 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54088 & -(2D0*XM(1)*XM(2))**2
54089 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54090 & -(2D0*XM(3)*XM(5))**2
54091 S23DF1=S23DF1*EPS
54092 S23DF2=S23DF2*EPS
54093 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54094 S23DEL=S23DEL/EPS
54095 S23MIN=S23AVE-S23DEL
54096 S23MAX=S23AVE+S23DEL
54097 YJACO2=S23MAX-S23MIN
54098 TH=S12
54099 DO 150 KS=1,100
54100 S23=S23MIN+YJACO2*(KS-1)/99
54101 SH=S23
54102 UH=ZM12+ZM22-SH-TH
54103 WU2 = (UH-ZM12)*(UH-ZM22)
54104 WT2 = (TH-ZM12)*(TH-ZM22)
54105 WS2 = XM1M2*SH
54106 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54107 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54108 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54109 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54110 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54111 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54112 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54113 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54114 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54115 IF(WT0.GT.WTMAX) WTMAX=WT0
54116 150 CONTINUE
54117 160 CONTINUE
54118
54119 WTMAX=WTMAX*1.05D0
54120 ENDIF
54121
54122C...FIND S12*
54123 AX=S12MIN
54124 CX=S12MAX
54125 BX=S12MIN+0.5D0*YJACO1
54126 X0=AX
54127 X3=CX
54128 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54129 X1=BX
54130 X2=BX+C*(CX-BX)
54131 ELSE
54132 X2=BX
54133 X1=BX-C*(BX-AX)
54134 ENDIF
54135
54136C...SOLVE FOR F1 AND F2
54137 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54138 &-(2D0*XM(1)*XM(2))**2
54139 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54140 &-(2D0*XM(3)*XM(5))**2
54141 S23DF1=S23DF1*EPS
54142 S23DF2=S23DF2*EPS
54143 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54144 F1=-2D0*S23DEL/EPS
54145 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54146 &-(2D0*XM(1)*XM(2))**2
54147 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54148 &-(2D0*XM(3)*XM(5))**2
54149 S23DF1=S23DF1*EPS
54150 S23DF2=S23DF2*EPS
54151 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54152 F2=-2D0*S23DEL/EPS
54153
54154 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54155C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54156 IF(F2.LE.F1)THEN
54157 X0=X1
54158 X1=X2
54159 X2=R*X1+C*X3
54160 F1=F2
54161 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54162 & -(2D0*XM(1)*XM(2))**2
54163 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54164 & -(2D0*XM(3)*XM(5))**2
54165 S23DF1=S23DF1*EPS
54166 S23DF2=S23DF2*EPS
54167 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54168 F2=-2D0*S23DEL/EPS
54169 ELSE
54170 X3=X2
54171 X2=X1
54172 X1=R*X2+C*X0
54173 F2=F1
54174 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54175 & -(2D0*XM(1)*XM(2))**2
54176 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54177 & -(2D0*XM(3)*XM(5))**2
54178 S23DF1=S23DF1*EPS
54179 S23DF2=S23DF2*EPS
54180 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54181 F1=-2D0*S23DEL/EPS
54182 ENDIF
54183 GOTO 170
54184 ENDIF
54185C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54186 IF(F1.LT.F2)THEN
54187 GOLDEN=-F1
54188 XMIN=X1
54189 ELSE
54190 GOLDEN=-F2
54191 XMIN=X2
54192 ENDIF
54193
54194 IKNT=0
54195 180 S12=S12MIN+PYR(0)*YJACO1
54196 IKNT=IKNT+1
54197C...GENERATE S23
54198 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54199 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54200 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54201 &-(2D0*XM(1)*XM(2))**2
54202 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54203 &-(2D0*XM(3)*XM(5))**2
54204 S23DF1=S23DF1*EPS
54205 S23DF2=S23DF2*EPS
54206 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54207 S23DEL=S23DEL/EPS
54208 S23MIN=S23AVE-S23DEL
54209 S23MAX=S23AVE+S23DEL
54210 YJACO2=S23MAX-S23MIN
54211 S23=S23MIN+PYR(0)*YJACO2
54212
54213C...CHECK THE SAMPLING
54214 IF(IKNT.GT.100) THEN
54215 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
54216 GOTO 190
54217 ENDIF
54218 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
54219
54220 IF(ISKIP.EQ.0) GOTO 190
54221
54222 SH=S23
54223 TH=S12
54224 UH=ZM12+ZM22-SH-TH
54225
54226 WU2 = (UH-ZM12)*(UH-ZM22)
54227 WT2 = (TH-ZM12)*(TH-ZM22)
54228 WS2 = XM1M2*SH
54229 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54230 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54231
54232 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54233 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54234 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54235 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54236c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
54237c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
54238c &/DCMPLX(TH-XML2)
54239c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
54240c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
54241c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
54242 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54243 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
54244 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54245
54246 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
54247 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
54248
54249 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
54250 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
54251 D2=XM(5)-D1-D3
54252 P1=SQRT(D1*D1-XM(1)**2)
54253 P2=SQRT(D2*D2-XM(2)**2)
54254 P3=SQRT(D3*D3-XM(3)**2)
54255 CTHE1=2D0*PYR(0)-1D0
54256 ANG1=2D0*PYR(0)*PARU(1)
54257 CPHI1=COS(ANG1)
54258 SPHI1=SIN(ANG1)
54259 ARG=1D0-CTHE1**2
54260 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54261 STHE1=SQRT(ARG)
54262 P(N+1,1)=P1*STHE1*CPHI1
54263 P(N+1,2)=P1*STHE1*SPHI1
54264 P(N+1,3)=P1*CTHE1
54265 P(N+1,4)=D1
54266
54267C...GET CPHI3
54268 ANG3=2D0*PYR(0)*PARU(1)
54269 CPHI3=COS(ANG3)
54270 SPHI3=SIN(ANG3)
54271 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
54272 ARG=1D0-CTHE3**2
54273 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
54274 STHE3=SQRT(ARG)
54275 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
54276 &+P3*STHE3*SPHI3*SPHI1
54277 &+P3*CTHE3*STHE1*CPHI1
54278 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
54279 &-P3*STHE3*SPHI3*CPHI1
54280 &+P3*CTHE3*STHE1*SPHI1
54281 P(N+3,3)=P3*STHE3*CPHI3*STHE1
54282 &+P3*CTHE3*CTHE1
54283 P(N+3,4)=D3
54284
54285 DO 200 I=1,3
54286 P(N+2,I)=-P(N+1,I)-P(N+3,I)
54287 200 CONTINUE
54288 P(N+2,4)=D2
54289
54290 RETURN
54291 END
54292
54293
54294C*********************************************************************
54295
54296C...PYTECM
54297C...Finds the s-hat dependent eigenvalues of the inverse propagator
54298C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
54299C...phase space generation. Extended to include techni-a meson, and
54300C...to return the width.
54301
54302 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
54303
54304C...Double precision and integer declarations.
54305 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54306 IMPLICIT INTEGER(I-N)
54307 INTEGER PYK,PYCHGE,PYCOMP
54308C...Parameter statement to help give large particle numbers.
54309 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54310 &KEXCIT=4000000,KDIMEN=5000000)
54311C...Commonblocks.
54312 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54313 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54314 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54315 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
54316 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
54317
54318C...Local variables.
54319 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
54320 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
54321 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
54322 INTEGER i,j,ierr
54323
54324 SH=SMIN
54325 SHR=SQRT(SH)
54326 AEM=PYALEM(SH)
54327
54328 SINW=MIN(SQRT(PARU(102)),1D0)
54329 COSW=SQRT(1D0-SINW**2)
54330 TANW=SINW/COSW
54331 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
54332 QUPD=2D0*RTCM(2)-1D0
54333
54334 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
54335 FAR=SQRT(AEM/ALPRHT)
54336 FAO=FAR*QUPD
54337 FZR=FAR*CT2W
54338 FZO=-FAO*TANW
54339 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
54340 FWR=FAR/(2D0*SINW)
54341 FWX=-FWR/RTCM(47)
54342
54343 DO 110 I=1,5
54344 DO 100 J=1,5
54345 AT(I,J)=0D0
54346 100 CONTINUE
54347 110 CONTINUE
54348
54349C...NC
54350 IF(IOPT.EQ.1) THEN
54351 AR(1,1) = SH
54352 AR(2,2) = SH-PMAS(23,1)**2
54353 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
54354 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
54355 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
54356 AR(1,2) = 0D0
54357 AR(2,1) = 0D0
54358 AR(1,3) = SH*FAR
54359 AR(3,1) = AR(1,3)
54360 AR(1,4) = SH*FAO
54361 AR(4,1) = AR(1,4)
54362 AR(2,3) = SH*FZR
54363 AR(3,2) = AR(2,3)
54364 AR(2,4) = SH*FZO
54365 AR(4,2) = AR(2,4)
54366 AR(3,4) = 0D0
54367 AR(4,3) = 0D0
54368 AR(2,5) = SH*FZX
54369 AR(5,2) = AR(2,5)
54370 AR(1,5) = 0D0
54371 AR(5,1) = AR(1,5)
54372 AR(3,5) = 0D0
54373 AR(5,3) = AR(3,5)
54374 AR(4,5) = 0D0
54375 AR(5,4) = AR(4,5)
54376 CALL PYWIDT(23,SH,WDTP,WDTE)
54377 AT(2,2) = WDTP(0)*SHR
54378 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
54379 AT(3,3) = WDTP(0)*SHR
54380 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
54381 AT(4,4) = WDTP(0)*SHR
54382 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
54383 AT(5,5) = WDTP(0)*SHR
54384 IDIM=5
54385C...CC
54386 ELSE
54387 AR(1,1) = SH-PMAS(24,1)**2
54388 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
54389 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
54390 AR(1,2) = SH*FWR
54391 AR(2,1) = AR(1,2)
54392 AR(1,3) = SH*FWX
54393 AR(3,1) = AR(1,3)
54394 AR(2,3) = 0D0
54395 AR(3,2) = 0D0
54396 CALL PYWIDT(24,SH,WDTP,WDTE)
54397 AT(1,1) = WDTP(0)*SHR
54398 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
54399 AT(2,2) = WDTP(0)*SHR
54400 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
54401 AT(3,3) = WDTP(0)*SHR
54402 IDIM=3
54403 ENDIF
54404 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
54405
54406 IMIN=1
54407 SXMN=1D20
54408 DO 120 I=1,IDIM
54409 WX(I)=SQRT(ABS(SH-WR(I)))
54410 WR(I)=ABS(WR(I))
54411 IF(WR(I).LT.SXMN) THEN
54412 SXMN=WR(I)
54413 IMIN=I
54414 ENDIF
54415 120 CONTINUE
54416 SMOU=WX(IMIN)**2
54417 WIDO=WI(IMIN)/SHR
54418
54419 RETURN
54420 END
54421C*********************************************************************
54422
54423C...PYXDIN
54424C...Universal Extra Dimensions Model (UED)
54425C...Initialize the xd masses and widths
54426C...M. ELKACIMI 4/03/2006
54427C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
54428
54429 SUBROUTINE PYXDIN
54430
54431C...Double precision and integer declarations.
54432 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54433 IMPLICIT INTEGER(I-N)
54434 INTEGER PYK,PYCHGE,PYCOMP
54435C...Commonblocks.
54436 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54437 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54438 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
54439C...UED Pythia common
54440 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54441
54442C...SAVE statements
54443 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
54444
54445C...Print out some info about the UED model
54446 WRITE(MSTU(11),7000)
54447 & ' ',
54448 & '********** PYXDIN: initialization of UED ******************',
54449 & ' ',
54450 & 'Universal Extra Dimensions (UED) switched on ',
54451 & ' ',
54452 & 'This implementation is courtesy of',
54453 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
54454 & ' see [hep-ph/0602198] (Les Houches 2005) ',
54455 & ' ',
54456 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
54457 & 'Dobrescu), with gravity-mediated decay widths calculated in',
54458 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
54459 & 'radiative corrections to the KK masses from [hep/ph0204342]',
54460 & '(Cheng, Matchev, Schmaltz).'
54461 WRITE(MSTU(11),7000)
54462 & ' ',
54463 & 'SM particles can propagate into one small extra dimension ',
54464 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
54465 & 'graviton is further allowed to propagate into N = IUED(4)',
54466 & 'large (eV^-1) extra dimensions.'
54467 WRITE(MSTU(11),7000)
54468 & ' ',
54469 & 'The switches and parameters for UED are:',
54470 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
54471 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
54472 & ' IUED(3): (D=5) number of quark flavours',
54473 & ' IUED(4): (D=6) number of large extra dimensions into',
54474 & ' which the graviton propagates',
54475 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
54476 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
54477 & ' ',
54478 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
54479 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
54480 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
54481 & ' when IUED(5)=0',
54482 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
54483 WRITE(MSTU(11),7000)
54484 & ' ',
54485 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
54486 & 'model, but is set through pmas(25,1).',
54487 & ' '
54488
54489C...Hardcoded switch, required by current implementation
54490 CALL PYGIVE('MSTP(42)=0')
54491
54492C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
54493 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
54494
54495C...Calculated the radiative corrections to the KK particle masses
54496 CALL PYUEDC
54497
54498C...Initialize the graviton mass
54499C...only if the KK particles decays gravitationally
54500 IF(IUED(2).EQ.1) CALL PYGRAM(0)
54501
54502 WRITE(MSTU(11),7000)
54503 & '********** PYXDIN: UED initialization completed ***********'
54504
54505C...Format to use for comments
54506 7000 FORMAT(' * ',A)
54507
54508 RETURN
54509 END
54510C*********************************************************************
54511
54512C...PYUEDC
54513C...Auxiliary to PYXDIN
54514C...Mass kk states radiative corrections
54515C...Radiative corrections are included (hep/ph0204342)
54516
54517 SUBROUTINE PYUEDC
54518
54519C...Double precision and integer declarations.
54520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54521 IMPLICIT INTEGER(I-N)
54522 INTEGER PYK,PYCHGE,PYCOMP
54523
54524 PARAMETER(KKPART=25,KKFLA=450)
54525
54526C...UED Pythia common
54527 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54528C...Pythia common: particles properties
54529 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54530C...Parameters.
54531 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54532C...Decay information.
54533 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54534C...Resonance width and secondary decay treatment.
54535 COMMON/PYINT4/MWID(500),WIDS(500,5)
54536 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54537
54538C...Local variables
54539 DOUBLE PRECISION PI,QUP,QDW
54540 DOUBLE PRECISION WDTP,WDTE
54541 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
54542 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
54543 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
54544 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
54545 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
54546 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
54547 DOUBLE PRECISION SWW1,CWW1
54548 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
54549 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
54550 DOUBLE PRECISION SW21,CW21,SW021,CW021
54551 COMMON/SW1/SW021,CW021
54552C...UED related declarations:
54553C...equivalences between ordered particles (451->475)
54554C...and UED particle code (5 000 000 + id)
54555 DIMENSION IUEDEQ(475)
54556 DATA (IUEDEQ(I),I=451,475)/
54557C...Singlet quarks
54558 & 6100001,6100002,6100003,6100004,6100005,6100006,
54559C...Doublet quarks
54560 & 5100001,5100002,5100003,5100004,5100005,5100006,
54561C...Singlet leptons
54562 & 6100011,6100013,6100015,
54563C...Doublet leptons
54564 & 5100012,5100011,5100014,5100013,5100016,5100015,
54565C...Gauge boson KK excitations
54566 & 5100021,5100022,5100023,5100024/
54567
54568C...N.B. rinv=rued(1)
54569 IF(RUED(1).LE.0.)THEN
54570 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
54571 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
54572 RETURN
54573 ENDIF
54574
54575 PI=DACOS(-1.D0)
54576 RMZ = PMAS(23,1)
54577 RMZ2 = RMZ**2
54578 RMW = PMAS(24,1)
54579 RMW2 = RMW**2
54580 ALPHEM = PARU(101)
54581 QUP = 2./3.
54582 QDW = -1./3.
54583
54584c...qt is q-tilde, qs is q-star
54585c...strong coupling value
54586 Q2 = RUED(1)**2
54587 ALPHS=PYALPS(Q2)
54588
54589c...weak mixing angle
54590 SW2=PARU(102)
54591 CW2=1D0-PARU(102)
54592
54593c...for the mass corrections
54594 RMKK = RUED(1)
54595 RMKK2 = RMKK**2
54596 ZETA3= 1.2
54597
54598C... Either fix the cutoff scale LAMUED
54599 IF(IUED(5).EQ.0)THEN
54600 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
54601C... or the ratio LAMUED/RINV (=product Lambda*R)
54602 ELSEIF(IUED(5).EQ.1)THEN
54603 LOGLAM = DLOG(RUED(4)**2)
54604 ELSE
54605 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
54606 CALL PYSTOP(6000)
54607 ENDIF
54608
54609C...Calculate the radiative corrections for the UED KK masses
54610 IF(IUED(6).EQ.1)THEN
54611 RFACT=1.D0
54612C...or induce a minute mass difference
54613C...keeping the UED KK mass values nearly equal to 1/R
54614 ELSEIF(IUED(6).EQ.0)THEN
54615 RFACT=0.01D0
54616 ELSE
54617 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
54618 CALL PYSTOP(6001)
54619 ENDIF
54620
54621c...Take into account only the strong interactions:
54622
54623c...The space bulk corrections :
54624 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
54625c...The boundary terms:
54626 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
54627
54628c...Mass corrections for fermions are extracted from
54629c...Phys. Rev. D66 036005(2002)9
54630 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
54631 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
54632 DBMQU=RMKK*(3.*(ALPHS/4./PI)
54633 . +(ALPHEM/4./PI/CW2))*LOGLAM
54634 DBMQD=RMKK*(3.*(ALPHS/4./PI)
54635 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
54636
54637 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
54638 . (ALPHEM/4./PI/CW2))*LOGLAM
54639 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
54640
54641c...Vector boson masss matrix diagonalization
54642 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
54643 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
54644 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
54645 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
54646
54647c...Elements of the mass matrix
54648 A = RMZ2*SW2 + DBMB2 + DSMB2
54649 B = RMZ2*CW2 + DBMA2 + DSMA2
54650 C = RMZ2*DSQRT(SW2*CW2)
54651 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
54652
54653c...Eigenvalues: corrections to X1 and Z1 masses
54654 DMB2 = (A+B-SQRDEL)/2.
54655 DMA2 = (A+B+SQRDEL)/2.
54656
54657c...Rotation angles
54658 SWW1 = 2*C
54659 CWW1 = A-B-SQRDEL
54660C...Weinberg angle
54661 SW21= SWW1**2/(SWW1**2 + CWW1**2)
54662 CW21= 1. - SW21
54663
54664 SW021=SW21
54665 CW021=CW21
54666
54667c...Masses:
54668 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
54669
54670 RMDQST=RMKK+RFACT*DBMQDO
54671 RMSQUS=RMKK+RFACT*DBMQU
54672 RMSQDS=RMKK+RFACT*DBMQD
54673
54674C...Note: MZ mass is included in ma2
54675 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
54676 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
54677 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
54678
54679 RMLSLD=RMKK+RFACT*DBMLDO
54680 RMLSLE=RMKK+RFACT*DBMLE
54681
54682 DO 100 IPART=1,5,2
54683 PMAS(KKFLA+IPART,1)=RMSQDS
54684 100 CONTINUE
54685 DO 110 IPART=2,6,2
54686 PMAS(KKFLA+IPART,1)=RMSQUS
54687 110 CONTINUE
54688 DO 120 IPART=7,12
54689 PMAS(KKFLA+IPART,1)=RMDQST
54690 120 CONTINUE
54691 DO 130 IPART=13,15
54692 PMAS(KKFLA+IPART,1)=RMLSLE
54693 130 CONTINUE
54694 DO 140 IPART=16,21
54695 PMAS(KKFLA+IPART,1)=RMLSLD
54696 140 CONTINUE
54697 PMAS(KKFLA+22,1)=RMGST
54698 PMAS(KKFLA+23,1)=RMPHST
54699 PMAS(KKFLA+24,1)=RMZST
54700 PMAS(KKFLA+25,1)=RMWST
54701
54702 WRITE(MSTU(11),7000) ' PYUEDC: ',
54703 & 'UED Mass Spectrum (GeV) :'
54704 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
54705 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
54706 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
54707 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
54708 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
54709 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
54710 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
54711 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
54712 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
54713 WRITE(MSTU(11),7000) ' '
54714
54715C...Initialize widths, branching ratios and life time
54716 DO 199 IPART=1,25
54717 KC=KKFLA+IPART
54718 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
54719 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
54720 IF(WDTP(0).LE.0)THEN
54721 WRITE(MSTU(11),*)
54722 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
54723 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
54724 GOTO 199
54725 ELSE
54726 DO 180 IDC=1,MDCY(KC,3)
54727 IC=IDC+MDCY(KC,2)-1
54728 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
54729C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
54730 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
54731 BRAT(IC)=WDTP(IDC)/WDTP(0)
54732 ENDIF
54733 180 CONTINUE
54734 ENDIF
54735 ENDIF
54736 199 CONTINUE
54737
54738C...Format to use for comments
54739 7000 FORMAT(' * ',A)
54740 7100 FORMAT(' * ',A,F12.3)
54741
54742 END
54743C********************************************************************
54744C...PYXUED
54745C... Last change:
54746C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
54747C... Original version:
54748C... M. El Kacimi
54749C... 05/07/2005
54750C Universal Extra Dimensions Subprocess cross sections
54751C The expressions used are from atl-com-phys-2005-003
54752C What is coded here is shat**2/pi * dsigma/dt = |M|**2
54753C For each UED subprocess, the color flow used is the same
54754C as the equivalent QCD subprocess. Different configuration
54755C color flows are considered to have the same probability.
54756C
54757C The Xsection is calculated following ATL-PHYS-PUB-2005-003
54758C by G.Azuelos and P.H.Beauchemin.
54759C
54760C This routine is called from pysigh.
54761
54762 SUBROUTINE PYXUED(NCHN,SIGS)
54763
54764C...Double precision and integer declarations
54765 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54766 IMPLICIT INTEGER(I-N)
54767C...
54768 INTEGER NGRDEC
54769 COMMON/DECMOD/NGRDEC
54770C...
54771 PARAMETER(KKPART=25,KKFLA=450)
54772C...Commonblocks
54773 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54774 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54775 COMMON/PYINT1/MINT(400),VINT(400)
54776 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
54777 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
54778 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
54779 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
54780 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
54781 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
54782C...UED Pythia common
54783 COMMON/PYPUED/IUED(0:99),RUED(0:99)
54784C...Local arrays and complex variables
54785 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
54786 + ,FAC1,XMNKK,XMUED,SIGS
54787 INTEGER NCHN
54788
54789C...Return if UED not switched on
54790 IF (IUED(1).LE.0) THEN
54791 RETURN
54792 ENDIF
54793
54794C...Energy scale of the parton processus
54795C...taken equal to the mass of the final state kk
54796c Q2=XMNKK**2
54797
54798C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
54799 XMNKK=PMAS(KKFLA+23,1)
54800
54801C...To compare the cross section with phys-pub-2005-03
54802C...(no radiative corrections),
54803C...take xmnkk=rinv and q2=rinv**2
54804c++lnk
54805C...n.b. (rinv=rued(1))
54806c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
54807 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
54808c--lnk
54809
54810 SHAT=VINT(44)
54811 SP=SHAT
54812 THAT=VINT(45)
54813 TP=THAT-XMNKK**2
54814 UHAT=VINT(46)
54815 UP=UHAT-XMNKK**2
54816 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
54817 PI=DACOS(-1.D0)
54818c++lnk
54819c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
54820 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
54821
54822c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
54823 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
54824c--lnk
54825
54826C...Strong coupling value
54827 ALPHAS=PYALPS(Q2)
54828
54829 IF(ISUB.EQ.311)THEN
54830C...gg --> g* g*
54831 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
54832 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
54833 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
54834 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
54835 & 12.*TP**2*UP**3+6*TP*UP**4)
54836 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
54837 & 15.*TP**3*UP**3+13*TP**2*UP**4+
54838 & 6.*TP*UP**5+2.*UP**6)
54839 NCHN=NCHN+1
54840 ISIG(NCHN,1)=21
54841 ISIG(NCHN,2)=21
54842C...Three color flow configurations (qcd g+g->g+g)
54843 XCOL=PYR(0)
54844 IF(XCOL.LE.1./3.)THEN
54845 ISIG(NCHN,3)=1
54846 ELSEIF(XCOL.LE.2./3.)THEN
54847 ISIG(NCHN,3)=2
54848 ELSE
54849 ISIG(NCHN,3)=3
54850 ENDIF
54851 SIGH(NCHN)=COMFAC*XMUED
54852 ELSEIF(ISUB.EQ.312)THEN
54853C...q + g -> q*_D + g*, q*_S + g*
54854C...(the two channels have the same cross section)
54855 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
54856 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
54857 & 5.*SP**4*UP**2+12.*SP**5*UP)
54858 XMUED=COMFAC*2.*XMUED
54859
54860 DO 190 I=MMINA,MMAXA
54861 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
54862 DO 180 ISDE=1,2
54863
54864 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
54865 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
54866 NCHN=NCHN+1
54867 ISIG(NCHN,ISDE)=I
54868 ISIG(NCHN,3-ISDE)=21
54869 ISIG(NCHN,3)=1
54870 SIGH(NCHN)=XMUED
54871 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54872 180 CONTINUE
54873 190 CONTINUE
54874
54875 ELSEIF(ISUB.EQ.313)THEN
54876C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
54877C...(the two channels have the same cross section)
54878C...qi and qj have the same charge sign
54879 DO 100 I=MMIN1,MMAX1
54880 IA=IABS(I)
54881 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
54882 DO 101 J=MMIN2,MMAX2
54883 JA=IABS(J)
54884 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
54885 & EQ.0) GOTO 101
54886 IF(J*I.LE.0)GOTO 101
54887 NCHN=NCHN+1
54888 ISIG(NCHN,1)=I
54889 ISIG(NCHN,2)=J
54890 IF(J.EQ.I)THEN
54891 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
54892 XMUED=FAC1*
54893 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
54894 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
54895 & 20.*TP**2*UP**2+56./3.*
54896 & TP*UP**3+8.*UP**4)
54897 SIGH(NCHN)=COMFAC*2.*XMUED
54898 ISIG(NCHN,3)=1
54899 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
54900 ELSE
54901 FAC1=2./9.*ALPHAS**2/TP**2
54902 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54903 SIGH(NCHN)=COMFAC*2.*XMUED
54904 ISIG(NCHN,3)=1
54905 ENDIF
54906 101 CONTINUE
54907 100 CONTINUE
54908 ELSEIF(ISUB.EQ.314)THEN
54909C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
54910C...(the two channels have the same cross section)
54911 NCHN=NCHN+1
54912 ISIG(NCHN,1)=21
54913 ISIG(NCHN,2)=21
54914 ISIG(NCHN,3)=INT(1.5+PYR(0))
54915
54916 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
54917 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
54918 + +4.*UP**4+4*TP**4)
54919 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
54920 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
54921 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
54922
54923 SIGH(NCHN)=COMFAC*XMUED
54924C...has been multiplied by 5: all possible quark flavors in final state
54925
54926 ELSEIF(ISUB.EQ.315)THEN
54927C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
54928C...(the two channels have the same cross section)
54929 DO 141 I=MMIN1,MMAX1
54930 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
54931 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
54932 DO 142 J=MMIN2,MMAX2
54933 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
54934 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
54935 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
54936 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
54937 & 2./3.*SP**3*TP+SP**4)
54938 NCHN=NCHN+1
54939 ISIG(NCHN,1)=I
54940 ISIG(NCHN,2)=-I
54941 ISIG(NCHN,3)=1
54942 SIGH(NCHN)=COMFAC*2.*XMUED
54943 142 CONTINUE
54944 141 CONTINUE
54945 ELSEIF(ISUB.EQ.316)THEN
54946C...q + qbar' -> q*_D + q*_Sbar'
54947 FAC1=2./9.*ALPHAS**2
54948 DO 300 I=MMIN1,MMAX1
54949 IA=IABS(I)
54950 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
54951 DO 301 J=MMIN2,MMAX2
54952 JA=IABS(J)
54953 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
54954 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
54955 NCHN=NCHN+1
54956 ISIG(NCHN,1)=I
54957 ISIG(NCHN,2)=J
54958 ISIG(NCHN,3)=1
54959 FAC1=2./9.*ALPHAS**2/TP**2
54960 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
54961 SIGH(NCHN)=COMFAC*XMUED
54962 301 CONTINUE
54963 300 CONTINUE
54964
54965 ELSEIF(ISUB.EQ.317)THEN
54966C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
54967C...(the two channels have the same cross section)
54968 DO 400 I=MMIN1,MMAX1
54969 IA=IABS(I)
54970 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
54971 DO 401 J=MMIN1,MMAX1
54972 JA=IABS(J)
54973 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
54974 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
54975 NCHN=NCHN+1
54976 ISIG(NCHN,1)=I
54977 ISIG(NCHN,2)=J
54978 ISIG(NCHN,3)=1
54979 FAC1=1./18.*ALPHAS**2/TP**2
54980 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
54981 SIGH(NCHN)=COMFAC*2.*XMUED
54982 401 CONTINUE
54983 400 CONTINUE
54984 ELSEIF(ISUB.EQ.318)THEN
54985C...q + q' -> q*_D + q*_S'
54986 DO 500 I=MMIN1,MMAX1
54987 IA=IABS(I)
54988 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
54989 DO 501 J=MMIN2,MMAX2
54990 JA=IABS(J)
54991 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
54992 IF(J*I.LE.0)GOTO 501
54993 IF(IA.EQ.JA)THEN
54994 NCHN=NCHN+1
54995 ISIG(NCHN,1)=I
54996 ISIG(NCHN,2)=J
54997 ISIG(NCHN,3)=INT(1.5+PYR(0))
54998 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
54999 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55000 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55001 SIGH(NCHN)=COMFAC*XMUED
55002 ELSE
55003 NCHN=NCHN+1
55004 ISIG(NCHN,1)=I
55005 ISIG(NCHN,2)=J
55006 ISIG(NCHN,3)=1
55007 FAC1=1./18.*ALPHAS**2/TP**2
55008 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55009 SIGH(NCHN)=COMFAC*2.*XMUED
55010 ENDIF
55011 501 CONTINUE
55012 500 CONTINUE
55013 ELSEIF(ISUB.EQ.319)THEN
55014C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55015C...(the two channels have the same cross section)
55016 DO 741 I=MMIN1,MMAX1
55017 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55018 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55019 DO 742 J=MMIN2,MMAX2
55020 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55021 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55022 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55023 NCHN=NCHN+1
55024 ISIG(NCHN,1)=I
55025 ISIG(NCHN,2)=-I
55026 ISIG(NCHN,3)=1
55027 SIGH(NCHN)=COMFAC*2.*XMUED
55028 742 CONTINUE
55029 741 CONTINUE
55030
55031 ENDIF
55032
55033 RETURN
55034 END
55035C*********************************************************************
55036
55037C...PYGRAM
55038C...Universal Extra Dimensions Model (UED)
55039C...Computation of the Graviton mass.
55040
55041 SUBROUTINE PYGRAM(IN)
55042
55043C...Double precision and integer declarations
55044 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55045 IMPLICIT INTEGER(I-N)
55046
55047C...Pythia commonblocks
55048 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55049 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55050C...UED Pythia common
55051 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55052
55053C...Local variables
55054 INTEGER KCFLA,NMAX
55055 PARAMETER(KCFLA=450,NMAX=5000)
55056 DIMENSION YVEC(5000),RESVEC(5000)
55057 COMMON/INTSAV/YSAV,YMAX,RESMAX
55058 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55059 COMMON/KAPPA/XKAPPA
55060
55061C...External function (used in call to PYGAUS)
55062 EXTERNAL PYGRAW
55063
55064C...SAVE statements
55065 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55066
55067C...Initialization
55068 NDIM=IUED(4)
55069 RINV=RUED(1)
55070 XMD=RUED(2)
55071 PI=PARU(1)
55072
55073C...Initialize for numerical integration
55074 XMPLNK=2.4D+18
55075 XKAPPA=DSQRT(2.D0)/XMPLNK
55076
55077C...For NDIM=2, compute graviton mass distribution numerically
55078 IF(NDIM.EQ.2)THEN
55079
55080C... For first event: tabulate distribution of stepwise integrals:
55081C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55082 IF(IN.EQ.0)THEN
55083 RESMAX = 0D0
55084 YMAX = 0D0
55085 DO 100 I=1,NMAX
55086 YSAV = (I-0.5)/DBLE(NMAX)
55087 TOL = 1D-6
55088C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55089 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55090 YVEC(I) = YSAV
55091 RESVEC(I) = RESINT
55092C... Save max of distribution (for accept/reject below)
55093 IF(RESINT.GT.RESMAX)THEN
55094 RESMAX = RESINT
55095 YMAX = YVEC(I)
55096 ENDIF
55097 100 CONTINUE
55098 ENDIF
55099
55100C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55101 PCUJET=1D0
55102 KCGAKK=KCFLA+23
55103 XMGAMK=PMAS(KCGAKK,1)
55104
55105C... Pick random graviton mass, accept according to stored integrals
55106 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55107 110 RMG=AMMAX*PYR(0)
55108 X=RMG/XMGAMK
55109
55110C... Bin enumeration starts at 1, but make sure always in range
55111 IBIN=INT(NMAX*X)+1
55112 IBIN=MIN(IBIN,NMAX)
55113 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55114
55115C... For NDIM=4 and 6, the analytical expression for the
55116C... graviton mass distribution integral is used.
55117 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55118
55119C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55120 PCUJET=1D0
55121
55122C... KK photon (?) compressed code and mass
55123 KCGAKK=KCFLA+23
55124 XMGAMK=PMAS(KCGAKK,1)
55125
55126C... Find maximum of (dGamma/dMg)
55127 IF(IN.EQ.0)THEN
55128 RESMAX=0D0
55129 YMAX=0D0
55130 DO 120 I=1,NMAX-1
55131 Y=I/DBLE(NMAX)
55132 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55133 IF(RESINT.GE.RESMAX)THEN
55134 RESMAX=RESINT
55135 YMAX=Y
55136 ENDIF
55137 120 CONTINUE
55138 ENDIF
55139
55140C... Pick random graviton mass, accept/reject
55141 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55142 130 RMG=AMMAX*PYR(0)
55143 X=RMG/XMGAMK
55144 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55145 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55146
55147C... If the user has not chosen N=2,4 or 6, STOP
55148 ELSE
55149 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55150 & ' (MUST BE 2, 4, OR 6) '
55151 CALL PYSTOP(6002)
55152 ENDIF
55153
55154C... Now store the sampled Mg
55155 PMAS(39,1)=RMG
55156
55157 RETURN
55158 END
55159
55160C*********************************************************************
55161
55162C...PYGRAW
55163C...Universal Extra Dimensions Model (UED)
55164C...
55165C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55166C...
55167C...Integrand for the KK boson -> SM boson + graviton
55168C...graviton mass distribution (and gravity mediated total width),
55169C...which contains (see 0201300 and below for the full product)
55170C...the gravity mediated partial decay width Gamma(xx, yy)
55171C... i.e. GRADEN(YY)*PYWDKK(XXA)
55172C... where xx is exclusive to gravity
55173C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55174C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55175
55176 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55177
55178C...Double precision and integer declarations
55179 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55180 IMPLICIT INTEGER (I-N)
55181
55182C...Pythia commonblocks
55183 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55184
55185C...Local UED commonblocks and variables
55186 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55187 COMMON/INTSAV/YSAV,YMAX,RESMAX
55188
55189C...SAVE statements
55190 SAVE /PYDAT1/,/INTSAV/
55191
55192C...External: Pythia's Gamma function
55193 EXTERNAL PYGAMM
55194
55195C...Pi
55196 PI=PARU(1)
55197 PI2=PI*PI
55198
55199 YMIN=1.D-9/RINV
55200 YY=YSAV
55201 XX=DSQRT(1.-YY**2)*YIN
55202 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
55203 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
55204 XND=(NDIM-1.)/2.
55205 GAMMN=PYGAMM(XND)
55206 FAC=FAC/GAMMN
55207 XXA=DSQRT(XX**2+YY**2)
55208 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
55209
55210 PYGRAW=DJAC*
55211 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
55212
55213 RETURN
55214 END
55215C*********************************************************************
55216
55217C...PYWDKK
55218C...Universal Extra Dimensions Model (UED)
55219C...
55220C...Multiplied by the square modulus of a form factor
55221C...(see GRADEN in function PYGRAW)
55222C...PYWDKK is the KK boson -> SM boson + graviton
55223C...gravity mediated partial decay width Gamma(xx, yy)
55224C... where xx is exclusive to gravity
55225C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55226C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
55227C...
55228C...N.B. The Feynman rules for the couplings of the graviton fields
55229C...to the UED fields are related to the corresponding couplings of
55230C...the graviton fields to the SM fields by the form factor.
55231
55232 DOUBLE PRECISION FUNCTION PYWDKK(X)
55233
55234C...Double precision and integer declarations
55235 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55236 IMPLICIT INTEGER (I-N)
55237
55238C...Pythia commonblocks
55239 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55240 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55241
55242C...Local UED commonblocks and variables
55243 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55244 COMMON/KAPPA/XKAPPA
55245
55246C...SAVE statements
55247 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
55248
55249 PI=PARU(1)
55250
55251C...gamma* mass 473
55252 KCQKK=473
55253 XMNKK=PMAS(KCQKK,1)
55254
55255C...Bosons partial width Macesanu hep-ph/0201300
55256 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
55257 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
55258
55259 RETURN
55260 END
55261
55262C*********************************************************************
55263
55264C...PYEIGC
55265C...Finds eigenvalues of a general complex matrix
55266C
55267C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
55268C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
55269C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
55270C OF A COMPLEX GENERAL MATRIX.
55271C
55272C ON INPUT
55273C
55274C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
55275C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55276C DIMENSION STATEMENT.
55277C
55278C N IS THE ORDER OF THE MATRIX A=(AR,AI).
55279C
55280C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
55281C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
55282C
55283C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
55284C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
55285C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
55286C
55287C ON OUTPUT
55288C
55289C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55290C RESPECTIVELY, OF THE EIGENVALUES.
55291C
55292C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55293C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
55294C
55295C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
55296C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
55297C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
55298C
55299C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
55300C
55301C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55302C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55303C
55304C THIS VERSION DATED AUGUST 1983.
55305C
55306
55307 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
55308
55309 INTEGER N,NM,IS1,IS2,IERR,MATZ
55310 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55311 X FV1(5),FV2(5),FV3(5)
55312 IF (N .LE. NM) GOTO 100
55313 IERR = 10 * N
55314 GOTO 120
55315C
55316 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
55317 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
55318 IF (MATZ .NE. 0) GOTO 110
55319C .......... FIND EIGENVALUES ONLY ..........
55320 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
55321 GOTO 120
55322C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
55323 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
55324 IF (IERR .NE. 0) GOTO 120
55325 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
55326 120 RETURN
55327 END
55328
55329C*********************************************************************
55330
55331C...PYCMQR
55332C...Auxiliary to PYEICG.
55333C
55334C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55335C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
55336C AND WILKINSON.
55337C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
55338C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55339C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55340C
55341C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
55342C UPPER HESSENBERG MATRIX BY THE QR METHOD.
55343C
55344C ON INPUT
55345C
55346C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55347C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55348C DIMENSION STATEMENT.
55349C
55350C N IS THE ORDER OF THE MATRIX.
55351C
55352C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55353C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55354C SET LOW=1, IGH=N.
55355C
55356C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55357C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55358C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
55359C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
55360C THE REDUCTION BY CORTH, IF PERFORMED.
55361C
55362C ON OUTPUT
55363C
55364C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
55365C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
55366C CALLING COMQR IF SUBSEQUENT CALCULATION OF
55367C EIGENVECTORS IS TO BE PERFORMED.
55368C
55369C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55370C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55371C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55372C FOR INDICES IERR+1,...,N.
55373C
55374C IERR IS SET TO
55375C ZERO FOR NORMAL RETURN,
55376C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55377C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55378C
55379C CALLS PYCDIV FOR COMPLEX DIVISION.
55380C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55381C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55382C
55383C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55384C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55385C
55386C THIS VERSION DATED AUGUST 1983.
55387C
55388
55389 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
55390
55391 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
55392 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
55393 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55394 X PYTHAG
55395
55396 IERR = 0
55397 IF (LOW .EQ. IGH) GOTO 130
55398C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55399 L = LOW + 1
55400C
55401 DO 120 I = L, IGH
55402 LL = MIN0(I+1,IGH)
55403 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
55404 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55405 YR = HR(I,I-1) / NORM
55406 YI = HI(I,I-1) / NORM
55407 HR(I,I-1) = NORM
55408 HI(I,I-1) = 0.0D0
55409C
55410 DO 100 J = I, IGH
55411 SI = YR * HI(I,J) - YI * HR(I,J)
55412 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55413 HI(I,J) = SI
55414 100 CONTINUE
55415C
55416 DO 110 J = LOW, LL
55417 SI = YR * HI(J,I) + YI * HR(J,I)
55418 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55419 HI(J,I) = SI
55420 110 CONTINUE
55421C
55422 120 CONTINUE
55423C .......... STORE ROOTS ISOLATED BY CBAL ..........
55424 130 DO 140 I = 1, N
55425 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
55426 WR(I) = HR(I,I)
55427 WI(I) = HI(I,I)
55428 140 CONTINUE
55429C
55430 EN = IGH
55431 TR = 0.0D0
55432 TI = 0.0D0
55433 ITN = 30*N
55434C .......... SEARCH FOR NEXT EIGENVALUE ..........
55435 150 IF (EN .LT. LOW) GOTO 320
55436 ITS = 0
55437 ENM1 = EN - 1
55438C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55439C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
55440 160 DO 170 LL = LOW, EN
55441 L = EN + LOW - LL
55442 IF (L .EQ. LOW) GOTO 180
55443 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55444 X + DABS(HR(L,L)) + DABS(HI(L,L))
55445 TST2 = TST1 + DABS(HR(L,L-1))
55446 IF (TST2 .EQ. TST1) GOTO 180
55447 170 CONTINUE
55448C .......... FORM SHIFT ..........
55449 180 IF (L .EQ. EN) GOTO 300
55450 IF (ITN .EQ. 0) GOTO 310
55451 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
55452 SR = HR(EN,EN)
55453 SI = HI(EN,EN)
55454 XR = HR(ENM1,EN) * HR(EN,ENM1)
55455 XI = HI(ENM1,EN) * HR(EN,ENM1)
55456 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
55457 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55458 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55459 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55460 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
55461 ZZR = -ZZR
55462 ZZI = -ZZI
55463 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55464 SR = SR - XR
55465 SI = SI - XI
55466 GOTO 210
55467C .......... FORM EXCEPTIONAL SHIFT ..........
55468 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55469 SI = 0.0D0
55470C
55471 210 DO 220 I = LOW, EN
55472 HR(I,I) = HR(I,I) - SR
55473 HI(I,I) = HI(I,I) - SI
55474 220 CONTINUE
55475C
55476 TR = TR + SR
55477 TI = TI + SI
55478 ITS = ITS + 1
55479 ITN = ITN - 1
55480C .......... REDUCE TO TRIANGLE (ROWS) ..........
55481 LP1 = L + 1
55482C
55483 DO 240 I = LP1, EN
55484 SR = HR(I,I-1)
55485 HR(I,I-1) = 0.0D0
55486 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55487 XR = HR(I-1,I-1) / NORM
55488 WR(I-1) = XR
55489 XI = HI(I-1,I-1) / NORM
55490 WI(I-1) = XI
55491 HR(I-1,I-1) = NORM
55492 HI(I-1,I-1) = 0.0D0
55493 HI(I,I-1) = SR / NORM
55494C
55495 DO 230 J = I, EN
55496 YR = HR(I-1,J)
55497 YI = HI(I-1,J)
55498 ZZR = HR(I,J)
55499 ZZI = HI(I,J)
55500 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55501 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55502 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55503 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55504 230 CONTINUE
55505C
55506 240 CONTINUE
55507C
55508 SI = HI(EN,EN)
55509 IF (SI .EQ. 0.0D0) GOTO 250
55510 NORM = PYTHAG(HR(EN,EN),SI)
55511 SR = HR(EN,EN) / NORM
55512 SI = SI / NORM
55513 HR(EN,EN) = NORM
55514 HI(EN,EN) = 0.0D0
55515C .......... INVERSE OPERATION (COLUMNS) ..........
55516 250 DO 280 J = LP1, EN
55517 XR = WR(J-1)
55518 XI = WI(J-1)
55519C
55520 DO 270 I = L, J
55521 YR = HR(I,J-1)
55522 YI = 0.0D0
55523 ZZR = HR(I,J)
55524 ZZI = HI(I,J)
55525 IF (I .EQ. J) GOTO 260
55526 YI = HI(I,J-1)
55527 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55528 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55529 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55530 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55531 270 CONTINUE
55532C
55533 280 CONTINUE
55534C
55535 IF (SI .EQ. 0.0D0) GOTO 160
55536C
55537 DO 290 I = L, EN
55538 YR = HR(I,EN)
55539 YI = HI(I,EN)
55540 HR(I,EN) = SR * YR - SI * YI
55541 HI(I,EN) = SR * YI + SI * YR
55542 290 CONTINUE
55543C
55544 GOTO 160
55545C .......... A ROOT FOUND ..........
55546 300 WR(EN) = HR(EN,EN) + TR
55547 WI(EN) = HI(EN,EN) + TI
55548 EN = ENM1
55549 GOTO 150
55550C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55551C CONVERGED AFTER 30*N ITERATIONS ..........
55552 310 IERR = EN
55553 320 RETURN
55554 END
55555
55556C*********************************************************************
55557
55558C...PYCMQ2
55559C...Auxiliary to PYEICG.
55560C
55561C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
55562C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
55563C AND WILKINSON.
55564C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
55565C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
55566C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
55567C
55568C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
55569C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
55570C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
55571C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
55572C THIS GENERAL MATRIX TO HESSENBERG FORM.
55573C
55574C ON INPUT
55575C
55576C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
55577C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
55578C DIMENSION STATEMENT.
55579C
55580C N IS THE ORDER OF THE MATRIX.
55581C
55582C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
55583C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
55584C SET LOW=1, IGH=N.
55585C
55586C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
55587C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
55588C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
55589C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
55590C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
55591C
55592C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
55593C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
55594C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
55595C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
55596C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
55597C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
55598C ARBITRARY.
55599C
55600C ON OUTPUT
55601C
55602C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
55603C HAVE BEEN DESTROYED.
55604C
55605C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
55606C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
55607C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
55608C FOR INDICES IERR+1,...,N.
55609C
55610C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
55611C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
55612C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
55613C THE EIGENVECTORS HAS BEEN FOUND.
55614C
55615C IERR IS SET TO
55616C ZERO FOR NORMAL RETURN,
55617C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
55618C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
55619C
55620C CALLS PYCDIV FOR COMPLEX DIVISION.
55621C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
55622C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
55623C
55624C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
55625C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
55626C
55627C THIS VERSION DATED OCTOBER 1989.
55628C
55629C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
55630C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
55631C
55632
55633 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
55634
55635 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
55636 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
55637 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
55638 X ORTR(5),ORTI(5)
55639 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
55640 X PYTHAG
55641
55642 IERR = 0
55643C .......... INITIALIZE EIGENVECTOR MATRIX ..........
55644 DO 110 J = 1, N
55645C
55646 DO 100 I = 1, N
55647 ZR(I,J) = 0.0D0
55648 ZI(I,J) = 0.0D0
55649 100 CONTINUE
55650 ZR(J,J) = 1.0D0
55651 110 CONTINUE
55652C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
55653C FROM THE INFORMATION LEFT BY CORTH ..........
55654 IEND = IGH - LOW - 1
55655 IF (IEND.LT.0) GOTO 220
55656 IF (IEND.EQ.0) GOTO 170
55657C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
55658 DO 160 II = 1, IEND
55659 I = IGH - II
55660 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
55661 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
55662C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
55663 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
55664 IP1 = I + 1
55665C
55666 DO 120 K = IP1, IGH
55667 ORTR(K) = HR(K,I-1)
55668 ORTI(K) = HI(K,I-1)
55669 120 CONTINUE
55670C
55671 DO 150 J = I, IGH
55672 SR = 0.0D0
55673 SI = 0.0D0
55674C
55675 DO 130 K = I, IGH
55676 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
55677 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
55678 130 CONTINUE
55679C
55680 SR = SR / NORM
55681 SI = SI / NORM
55682C
55683 DO 140 K = I, IGH
55684 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
55685 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
55686 140 CONTINUE
55687C
55688 150 CONTINUE
55689C
55690 160 CONTINUE
55691C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
55692 170 L = LOW + 1
55693C
55694 DO 210 I = L, IGH
55695 LL = MIN0(I+1,IGH)
55696 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
55697 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
55698 YR = HR(I,I-1) / NORM
55699 YI = HI(I,I-1) / NORM
55700 HR(I,I-1) = NORM
55701 HI(I,I-1) = 0.0D0
55702C
55703 DO 180 J = I, N
55704 SI = YR * HI(I,J) - YI * HR(I,J)
55705 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
55706 HI(I,J) = SI
55707 180 CONTINUE
55708C
55709 DO 190 J = 1, LL
55710 SI = YR * HI(J,I) + YI * HR(J,I)
55711 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
55712 HI(J,I) = SI
55713 190 CONTINUE
55714C
55715 DO 200 J = LOW, IGH
55716 SI = YR * ZI(J,I) + YI * ZR(J,I)
55717 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
55718 ZI(J,I) = SI
55719 200 CONTINUE
55720C
55721 210 CONTINUE
55722C .......... STORE ROOTS ISOLATED BY CBAL ..........
55723 220 DO 230 I = 1, N
55724 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
55725 WR(I) = HR(I,I)
55726 WI(I) = HI(I,I)
55727 230 CONTINUE
55728C
55729 EN = IGH
55730 TR = 0.0D0
55731 TI = 0.0D0
55732 ITN = 30*N
55733C .......... SEARCH FOR NEXT EIGENVALUE ..........
55734 240 IF (EN .LT. LOW) GOTO 430
55735 ITS = 0
55736 ENM1 = EN - 1
55737C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
55738C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
55739 250 DO 260 LL = LOW, EN
55740 L = EN + LOW - LL
55741 IF (L .EQ. LOW) GOTO 270
55742 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
55743 X + DABS(HR(L,L)) + DABS(HI(L,L))
55744 TST2 = TST1 + DABS(HR(L,L-1))
55745 IF (TST2 .EQ. TST1) GOTO 270
55746 260 CONTINUE
55747C .......... FORM SHIFT ..........
55748 270 IF (L .EQ. EN) GOTO 420
55749 IF (ITN .EQ. 0) GOTO 550
55750 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
55751 SR = HR(EN,EN)
55752 SI = HI(EN,EN)
55753 XR = HR(ENM1,EN) * HR(EN,ENM1)
55754 XI = HI(ENM1,EN) * HR(EN,ENM1)
55755 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
55756 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
55757 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
55758 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
55759 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
55760 ZZR = -ZZR
55761 ZZI = -ZZI
55762 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
55763 SR = SR - XR
55764 SI = SI - XI
55765 GOTO 300
55766C .......... FORM EXCEPTIONAL SHIFT ..........
55767 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
55768 SI = 0.0D0
55769C
55770 300 DO 310 I = LOW, EN
55771 HR(I,I) = HR(I,I) - SR
55772 HI(I,I) = HI(I,I) - SI
55773 310 CONTINUE
55774C
55775 TR = TR + SR
55776 TI = TI + SI
55777 ITS = ITS + 1
55778 ITN = ITN - 1
55779C .......... REDUCE TO TRIANGLE (ROWS) ..........
55780 LP1 = L + 1
55781C
55782 DO 330 I = LP1, EN
55783 SR = HR(I,I-1)
55784 HR(I,I-1) = 0.0D0
55785 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
55786 XR = HR(I-1,I-1) / NORM
55787 WR(I-1) = XR
55788 XI = HI(I-1,I-1) / NORM
55789 WI(I-1) = XI
55790 HR(I-1,I-1) = NORM
55791 HI(I-1,I-1) = 0.0D0
55792 HI(I,I-1) = SR / NORM
55793C
55794 DO 320 J = I, N
55795 YR = HR(I-1,J)
55796 YI = HI(I-1,J)
55797 ZZR = HR(I,J)
55798 ZZI = HI(I,J)
55799 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
55800 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
55801 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
55802 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
55803 320 CONTINUE
55804C
55805 330 CONTINUE
55806C
55807 SI = HI(EN,EN)
55808 IF (SI .EQ. 0.0D0) GOTO 350
55809 NORM = PYTHAG(HR(EN,EN),SI)
55810 SR = HR(EN,EN) / NORM
55811 SI = SI / NORM
55812 HR(EN,EN) = NORM
55813 HI(EN,EN) = 0.0D0
55814 IF (EN .EQ. N) GOTO 350
55815 IP1 = EN + 1
55816C
55817 DO 340 J = IP1, N
55818 YR = HR(EN,J)
55819 YI = HI(EN,J)
55820 HR(EN,J) = SR * YR + SI * YI
55821 HI(EN,J) = SR * YI - SI * YR
55822 340 CONTINUE
55823C .......... INVERSE OPERATION (COLUMNS) ..........
55824 350 DO 390 J = LP1, EN
55825 XR = WR(J-1)
55826 XI = WI(J-1)
55827C
55828 DO 370 I = 1, J
55829 YR = HR(I,J-1)
55830 YI = 0.0D0
55831 ZZR = HR(I,J)
55832 ZZI = HI(I,J)
55833 IF (I .EQ. J) GOTO 360
55834 YI = HI(I,J-1)
55835 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55836 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55837 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55838 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55839 370 CONTINUE
55840C
55841 DO 380 I = LOW, IGH
55842 YR = ZR(I,J-1)
55843 YI = ZI(I,J-1)
55844 ZZR = ZR(I,J)
55845 ZZI = ZI(I,J)
55846 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
55847 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
55848 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
55849 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
55850 380 CONTINUE
55851C
55852 390 CONTINUE
55853C
55854 IF (SI .EQ. 0.0D0) GOTO 250
55855C
55856 DO 400 I = 1, EN
55857 YR = HR(I,EN)
55858 YI = HI(I,EN)
55859 HR(I,EN) = SR * YR - SI * YI
55860 HI(I,EN) = SR * YI + SI * YR
55861 400 CONTINUE
55862C
55863 DO 410 I = LOW, IGH
55864 YR = ZR(I,EN)
55865 YI = ZI(I,EN)
55866 ZR(I,EN) = SR * YR - SI * YI
55867 ZI(I,EN) = SR * YI + SI * YR
55868 410 CONTINUE
55869C
55870 GOTO 250
55871C .......... A ROOT FOUND ..........
55872 420 HR(EN,EN) = HR(EN,EN) + TR
55873 WR(EN) = HR(EN,EN)
55874 HI(EN,EN) = HI(EN,EN) + TI
55875 WI(EN) = HI(EN,EN)
55876 EN = ENM1
55877 GOTO 240
55878C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
55879C VECTORS OF UPPER TRIANGULAR FORM ..........
55880 430 NORM = 0.0D0
55881C
55882 DO 440 I = 1, N
55883C
55884 DO 440 J = I, N
55885 TR = DABS(HR(I,J)) + DABS(HI(I,J))
55886 IF (TR .GT. NORM) NORM = TR
55887 440 CONTINUE
55888C
55889 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
55890C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
55891 DO 500 NN = 2, N
55892 EN = N + 2 - NN
55893 XR = WR(EN)
55894 XI = WI(EN)
55895 HR(EN,EN) = 1.0D0
55896 HI(EN,EN) = 0.0D0
55897 ENM1 = EN - 1
55898C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
55899 DO 490 II = 1, ENM1
55900 I = EN - II
55901 ZZR = 0.0D0
55902 ZZI = 0.0D0
55903 IP1 = I + 1
55904C
55905 DO 450 J = IP1, EN
55906 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
55907 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
55908 450 CONTINUE
55909C
55910 YR = XR - WR(I)
55911 YI = XI - WI(I)
55912 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
55913 TST1 = NORM
55914 YR = TST1
55915 460 YR = 0.01D0 * YR
55916 TST2 = NORM + YR
55917 IF (TST2 .GT. TST1) GOTO 460
55918 470 CONTINUE
55919 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
55920C .......... OVERFLOW CONTROL ..........
55921 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
55922 IF (TR .EQ. 0.0D0) GOTO 490
55923 TST1 = TR
55924 TST2 = TST1 + 1.0D0/TST1
55925 IF (TST2 .GT. TST1) GOTO 490
55926 DO 480 J = I, EN
55927 HR(J,EN) = HR(J,EN)/TR
55928 HI(J,EN) = HI(J,EN)/TR
55929 480 CONTINUE
55930C
55931 490 CONTINUE
55932C
55933 500 CONTINUE
55934C .......... END BACKSUBSTITUTION ..........
55935C .......... VECTORS OF ISOLATED ROOTS ..........
55936 DO 520 I = 1, N
55937 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
55938C
55939 DO 510 J = I, N
55940 ZR(I,J) = HR(I,J)
55941 ZI(I,J) = HI(I,J)
55942 510 CONTINUE
55943C
55944 520 CONTINUE
55945C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
55946C VECTORS OF ORIGINAL FULL MATRIX.
55947C FOR J=N STEP -1 UNTIL LOW DO -- ..........
55948 DO 540 JJ = LOW, N
55949 J = N + LOW - JJ
55950 M = MIN0(J,IGH)
55951C
55952 DO 540 I = LOW, IGH
55953 ZZR = 0.0D0
55954 ZZI = 0.0D0
55955C
55956 DO 530 K = LOW, M
55957 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
55958 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
55959 530 CONTINUE
55960C
55961 ZR(I,J) = ZZR
55962 ZI(I,J) = ZZI
55963 540 CONTINUE
55964C
55965 GOTO 560
55966C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
55967C CONVERGED AFTER 30*N ITERATIONS ..........
55968 550 IERR = EN
55969 560 RETURN
55970 END
55971
55972C*********************************************************************
55973
55974C...PYCDIV
55975C...Auxiliary to PYCMQR
55976C
55977C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
55978C
55979
55980 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
55981
55982 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
55983 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
55984
55985 S = DABS(BR) + DABS(BI)
55986 ARS = AR/S
55987 AIS = AI/S
55988 BRS = BR/S
55989 BIS = BI/S
55990 S = BRS**2 + BIS**2
55991 CR = (ARS*BRS + AIS*BIS)/S
55992 CI = (AIS*BRS - ARS*BIS)/S
55993 RETURN
55994 END
55995
55996C*********************************************************************
55997
55998C...PYCSRT
55999C...Auxiliary to PYCMQR
56000C
56001C (YR,YI) = COMPLEX DSQRT(XR,XI)
56002C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56003C
56004
56005 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56006
56007 DOUBLE PRECISION XR,XI,YR,YI
56008 DOUBLE PRECISION S,TR,TI,PYTHAG
56009
56010 TR = XR
56011 TI = XI
56012 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56013 IF (TR .GE. 0.0D0) YR = S
56014 IF (TI .LT. 0.0D0) S = -S
56015 IF (TR .LE. 0.0D0) YI = S
56016 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56017 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56018 RETURN
56019 END
56020
56021 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56022 DOUBLE PRECISION A,B
56023C
56024C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56025C
56026 DOUBLE PRECISION P,R,S,T,U
56027 P = DMAX1(DABS(A),DABS(B))
56028 IF (P .EQ. 0.0D0) GOTO 110
56029 R = (DMIN1(DABS(A),DABS(B))/P)**2
56030 100 CONTINUE
56031 T = 4.0D0 + R
56032 IF (T .EQ. 4.0D0) GOTO 110
56033 S = R/T
56034 U = 1.0D0 + 2.0D0*S
56035 P = U*P
56036 R = (S/U)**2 * R
56037 GOTO 100
56038 110 PYTHAG = P
56039 RETURN
56040 END
56041
56042C*********************************************************************
56043
56044C...PYCBAL
56045C...Auxiliary to PYEICG
56046C
56047C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56048C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56049C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56050C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56051C
56052C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56053C EIGENVALUES WHENEVER POSSIBLE.
56054C
56055C ON INPUT
56056C
56057C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56058C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56059C DIMENSION STATEMENT.
56060C
56061C N IS THE ORDER OF THE MATRIX.
56062C
56063C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56064C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56065C
56066C ON OUTPUT
56067C
56068C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56069C RESPECTIVELY, OF THE BALANCED MATRIX.
56070C
56071C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56072C ARE EQUAL TO ZERO IF
56073C (1) I IS GREATER THAN J AND
56074C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56075C
56076C SCALE CONTAINS INFORMATION DETERMINING THE
56077C PERMUTATIONS AND SCALING FACTORS USED.
56078C
56079C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56080C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56081C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56082C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56083C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56084C = D(J,J) J = LOW,...,IGH
56085C = P(J) J = IGH+1,...,N.
56086C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56087C THEN 1 TO LOW-1.
56088C
56089C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56090C
56091C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56092C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56093C K,L HAVE BEEN REVERSED.)
56094C
56095C ARITHMETIC IS REAL THROUGHOUT.
56096C
56097C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56098C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56099C
56100C THIS VERSION DATED AUGUST 1983.
56101C
56102
56103 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56104
56105 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56106 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56107 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56108 LOGICAL NOCONV
56109
56110 RADIX = 16.0D0
56111C
56112 B2 = RADIX * RADIX
56113 K = 1
56114 L = N
56115 GOTO 150
56116C .......... IN-LINE PROCEDURE FOR ROW AND
56117C COLUMN EXCHANGE ..........
56118 100 SCALE(M) = J
56119 IF (J .EQ. M) GOTO 130
56120C
56121 DO 110 I = 1, L
56122 F = AR(I,J)
56123 AR(I,J) = AR(I,M)
56124 AR(I,M) = F
56125 F = AI(I,J)
56126 AI(I,J) = AI(I,M)
56127 AI(I,M) = F
56128 110 CONTINUE
56129C
56130 DO 120 I = K, N
56131 F = AR(J,I)
56132 AR(J,I) = AR(M,I)
56133 AR(M,I) = F
56134 F = AI(J,I)
56135 AI(J,I) = AI(M,I)
56136 AI(M,I) = F
56137 120 CONTINUE
56138C
56139 130 IF(IEXC.EQ.1) GOTO 140
56140 IF(IEXC.EQ.2) GOTO 180
56141C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56142C AND PUSH THEM DOWN ..........
56143 140 IF (L .EQ. 1) GOTO 320
56144 L = L - 1
56145C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56146 150 DO 170 JJ = 1, L
56147 J = L + 1 - JJ
56148C
56149 DO 160 I = 1, L
56150 IF (I .EQ. J) GOTO 160
56151 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56152 160 CONTINUE
56153C
56154 M = L
56155 IEXC = 1
56156 GOTO 100
56157 170 CONTINUE
56158C
56159 GOTO 190
56160C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56161C AND PUSH THEM LEFT ..........
56162 180 K = K + 1
56163C
56164 190 DO 210 J = K, L
56165C
56166 DO 200 I = K, L
56167 IF (I .EQ. J) GOTO 200
56168 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56169 200 CONTINUE
56170C
56171 M = K
56172 IEXC = 2
56173 GOTO 100
56174 210 CONTINUE
56175C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56176 DO 220 I = K, L
56177 220 SCALE(I) = 1.0D0
56178C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56179 230 NOCONV = .FALSE.
56180C
56181 DO 310 I = K, L
56182 C = 0.0D0
56183 R = 0.0D0
56184C
56185 DO 240 J = K, L
56186 IF (J .EQ. I) GOTO 240
56187 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56188 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56189 240 CONTINUE
56190C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56191 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56192 G = R / RADIX
56193 F = 1.0D0
56194 S = C + R
56195 250 IF (C .GE. G) GOTO 260
56196 F = F * RADIX
56197 C = C * B2
56198 GOTO 250
56199 260 G = R * RADIX
56200 270 IF (C .LT. G) GOTO 280
56201 F = F / RADIX
56202 C = C / B2
56203 GOTO 270
56204C .......... NOW BALANCE ..........
56205 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
56206 G = 1.0D0 / F
56207 SCALE(I) = SCALE(I) * F
56208 NOCONV = .TRUE.
56209C
56210 DO 290 J = K, N
56211 AR(I,J) = AR(I,J) * G
56212 AI(I,J) = AI(I,J) * G
56213 290 CONTINUE
56214C
56215 DO 300 J = 1, L
56216 AR(J,I) = AR(J,I) * F
56217 AI(J,I) = AI(J,I) * F
56218 300 CONTINUE
56219C
56220 310 CONTINUE
56221C
56222 IF (NOCONV) GOTO 230
56223C
56224 320 LOW = K
56225 IGH = L
56226 RETURN
56227 END
56228
56229C*********************************************************************
56230
56231C...PYCBA2
56232C...Auxiliary to PYEICG.
56233C
56234C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56235C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
56236C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56237C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56238C
56239C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
56240C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
56241C BALANCED MATRIX DETERMINED BY CBAL.
56242C
56243C ON INPUT
56244C
56245C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56246C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56247C DIMENSION STATEMENT.
56248C
56249C N IS THE ORDER OF THE MATRIX.
56250C
56251C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
56252C
56253C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
56254C AND SCALING FACTORS USED BY CBAL.
56255C
56256C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
56257C
56258C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56259C RESPECTIVELY, OF THE EIGENVECTORS TO BE
56260C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
56261C
56262C ON OUTPUT
56263C
56264C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56265C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
56266C IN THEIR FIRST M COLUMNS.
56267C
56268C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56269C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56270C
56271C THIS VERSION DATED AUGUST 1983.
56272C
56273
56274 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
56275
56276 INTEGER I,J,K,M,N,II,NM,IGH,LOW
56277 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
56278 DOUBLE PRECISION S
56279
56280 IF (M .EQ. 0) GOTO 150
56281 IF (IGH .EQ. LOW) GOTO 120
56282C
56283 DO 110 I = LOW, IGH
56284 S = SCALE(I)
56285C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
56286C IF THE FOREGOING STATEMENT IS REPLACED BY
56287C S=1.0D0/SCALE(I). ..........
56288 DO 100 J = 1, M
56289 ZR(I,J) = ZR(I,J) * S
56290 ZI(I,J) = ZI(I,J) * S
56291 100 CONTINUE
56292C
56293 110 CONTINUE
56294C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
56295C IGH+1 STEP 1 UNTIL N DO -- ..........
56296 120 DO 140 II = 1, N
56297 I = II
56298 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56299 IF (I .LT. LOW) I = LOW - II
56300 K = SCALE(I)
56301 IF (K .EQ. I) GOTO 140
56302C
56303 DO 130 J = 1, M
56304 S = ZR(I,J)
56305 ZR(I,J) = ZR(K,J)
56306 ZR(K,J) = S
56307 S = ZI(I,J)
56308 ZI(I,J) = ZI(K,J)
56309 ZI(K,J) = S
56310 130 CONTINUE
56311C
56312 140 CONTINUE
56313C
56314 150 RETURN
56315 END
56316
56317C*********************************************************************
56318
56319C...PYCRTH
56320C...Auxiliary to PYEICG.
56321C
56322C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
56323C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
56324C BY MARTIN AND WILKINSON.
56325C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
56326C
56327C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
56328C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
56329C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
56330C UNITARY SIMILARITY TRANSFORMATIONS.
56331C
56332C ON INPUT
56333C
56334C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56335C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56336C DIMENSION STATEMENT.
56337C
56338C N IS THE ORDER OF THE MATRIX.
56339C
56340C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56341C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56342C SET LOW=1, IGH=N.
56343C
56344C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56345C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
56346C
56347C ON OUTPUT
56348C
56349C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56350C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
56351C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
56352C IS STORED IN THE REMAINING TRIANGLES UNDER THE
56353C HESSENBERG MATRIX.
56354C
56355C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
56356C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
56357C
56358C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56359C
56360C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56361C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56362C
56363C THIS VERSION DATED AUGUST 1983.
56364C
56365
56366 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
56367
56368 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
56369 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
56370 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
56371
56372 LA = IGH - 1
56373 KP1 = LOW + 1
56374 IF (LA .LT. KP1) GOTO 210
56375C
56376 DO 200 M = KP1, LA
56377 H = 0.0D0
56378 ORTR(M) = 0.0D0
56379 ORTI(M) = 0.0D0
56380 SCALE = 0.0D0
56381C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
56382 DO 100 I = M, IGH
56383 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
56384C
56385 IF (SCALE .EQ. 0.0D0) GOTO 200
56386 MP = M + IGH
56387C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56388 DO 110 II = M, IGH
56389 I = MP - II
56390 ORTR(I) = AR(I,M-1) / SCALE
56391 ORTI(I) = AI(I,M-1) / SCALE
56392 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
56393 110 CONTINUE
56394C
56395 G = DSQRT(H)
56396 F = PYTHAG(ORTR(M),ORTI(M))
56397 IF (F .EQ. 0.0D0) GOTO 120
56398 H = H + F * G
56399 G = G / F
56400 ORTR(M) = (1.0D0 + G) * ORTR(M)
56401 ORTI(M) = (1.0D0 + G) * ORTI(M)
56402 GOTO 130
56403C
56404 120 ORTR(M) = G
56405 AR(M,M-1) = SCALE
56406C .......... FORM (I-(U*UT)/H) * A ..........
56407 130 DO 160 J = M, N
56408 FR = 0.0D0
56409 FI = 0.0D0
56410C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
56411 DO 140 II = M, IGH
56412 I = MP - II
56413 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
56414 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
56415 140 CONTINUE
56416C
56417 FR = FR / H
56418 FI = FI / H
56419C
56420 DO 150 I = M, IGH
56421 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
56422 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
56423 150 CONTINUE
56424C
56425 160 CONTINUE
56426C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
56427 DO 190 I = 1, IGH
56428 FR = 0.0D0
56429 FI = 0.0D0
56430C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
56431 DO 170 JJ = M, IGH
56432 J = MP - JJ
56433 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
56434 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
56435 170 CONTINUE
56436C
56437 FR = FR / H
56438 FI = FI / H
56439C
56440 DO 180 J = M, IGH
56441 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
56442 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
56443 180 CONTINUE
56444C
56445 190 CONTINUE
56446C
56447 ORTR(M) = SCALE * ORTR(M)
56448 ORTI(M) = SCALE * ORTI(M)
56449 AR(M,M-1) = -G * AR(M,M-1)
56450 AI(M,M-1) = -G * AI(M,M-1)
56451 200 CONTINUE
56452C
56453 210 RETURN
56454 END
56455
56456C*********************************************************************
56457
56458C...PYLDCM
56459C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56460C...processes.
56461
56462 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
56463 IMPLICIT NONE
56464 INTEGER N,NP,INDX(N)
56465 REAL*8 D,TINY
56466 COMPLEX*16 A(NP,NP)
56467 PARAMETER (TINY=1.0D-20)
56468 INTEGER I,IMAX,J,K
56469 REAL*8 AAMAX,VV(6),DUM
56470 COMPLEX*16 SUM,DUMC
56471
56472 D=1D0
56473 DO 110 I=1,N
56474 AAMAX=0D0
56475 DO 100 J=1,N
56476 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
56477 100 CONTINUE
56478 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
56479 VV(I)=1D0/AAMAX
56480 110 CONTINUE
56481 DO 180 J=1,N
56482 DO 130 I=1,J-1
56483 SUM=A(I,J)
56484 DO 120 K=1,I-1
56485 SUM=SUM-A(I,K)*A(K,J)
56486 120 CONTINUE
56487 A(I,J)=SUM
56488 130 CONTINUE
56489 AAMAX=0D0
56490 DO 150 I=J,N
56491 SUM=A(I,J)
56492 DO 140 K=1,J-1
56493 SUM=SUM-A(I,K)*A(K,J)
56494 140 CONTINUE
56495 A(I,J)=SUM
56496 DUM=VV(I)*ABS(SUM)
56497 IF (DUM.GE.AAMAX) THEN
56498 IMAX=I
56499 AAMAX=DUM
56500 ENDIF
56501 150 CONTINUE
56502 IF (J.NE.IMAX)THEN
56503 DO 160 K=1,N
56504 DUMC=A(IMAX,K)
56505 A(IMAX,K)=A(J,K)
56506 A(J,K)=DUMC
56507 160 CONTINUE
56508 D=-D
56509 VV(IMAX)=VV(J)
56510 ENDIF
56511 INDX(J)=IMAX
56512 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
56513 IF(J.NE.N)THEN
56514 DO 170 I=J+1,N
56515 A(I,J)=A(I,J)/A(J,J)
56516 170 CONTINUE
56517 ENDIF
56518 180 CONTINUE
56519
56520 RETURN
56521 END
56522
56523C*********************************************************************
56524
56525C...PYBKSB
56526C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
56527C...processes.
56528
56529 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
56530 IMPLICIT NONE
56531 INTEGER N,NP,INDX(N)
56532 COMPLEX*16 A(NP,NP),B(N)
56533 INTEGER I,II,J,LL
56534 COMPLEX*16 SUM
56535
56536 II=0
56537 DO 110 I=1,N
56538 LL=INDX(I)
56539 SUM=B(LL)
56540 B(LL)=B(I)
56541 IF (II.NE.0)THEN
56542 DO 100 J=II,I-1
56543 SUM=SUM-A(I,J)*B(J)
56544 100 CONTINUE
56545 ELSE IF (ABS(SUM).NE.0D0) THEN
56546 II=I
56547 ENDIF
56548 B(I)=SUM
56549 110 CONTINUE
56550 DO 130 I=N,1,-1
56551 SUM=B(I)
56552 DO 120 J=I+1,N
56553 SUM=SUM-A(I,J)*B(J)
56554 120 CONTINUE
56555 B(I)=SUM/A(I,I)
56556 130 CONTINUE
56557 RETURN
56558 END
56559
56560C***********************************************************************
56561
56562C...PYWIDX
56563C...Calculates full and partial widths of resonances.
56564C....copy of PYWIDT, used for techniparticle widths
56565
56566 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
56567
56568C...Double precision and integer declarations.
56569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56570 IMPLICIT INTEGER(I-N)
56571 INTEGER PYK,PYCHGE,PYCOMP
56572C...Parameter statement to help give large particle numbers.
56573 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56574 &KEXCIT=4000000,KDIMEN=5000000)
56575C...Commonblocks.
56576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56578 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
56579 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
56580 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
56581 COMMON/PYINT1/MINT(400),VINT(400)
56582 COMMON/PYINT4/MWID(500),WIDS(500,5)
56583 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56584 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
56585 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
56586 &/PYINT4/,/PYMSSM/,/PYTCSM/
56587C...Local arrays and saved variables.
56588 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
56589 &WID2SV(3,2)
56590 SAVE MOFSV,WIDWSV,WID2SV
56591 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
56592
56593C...Compressed code and sign; mass.
56594 KFLA=IABS(KFLR)
56595 KFLS=ISIGN(1,KFLR)
56596 KC=PYCOMP(KFLA)
56597 SHR=SQRT(SH)
56598 PMR=PMAS(KC,1)
56599
56600C...Reset width information.
56601 DO I=0,400
56602 WDTP(I)=0D0
56603 ENDDO
56604
56605C...Common electroweak and strong constants.
56606 XW=PARU(102)
56607 XWV=XW
56608 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
56609 XW1=1D0-XW
56610 AEM=PYALEM(SH)
56611 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
56612 AS=PYALPS(SH)
56613 RADC=1D0+AS/PARU(1)
56614
56615 IF(KFLA.EQ.23) THEN
56616C...Z0:
56617 XWC=1D0/(16D0*XW*XW1)
56618 FAC=(AEM*XWC/3D0)*SHR
56619 120 CONTINUE
56620 DO 130 I=1,MDCY(KC,3)
56621 IDC=I+MDCY(KC,2)-1
56622 IF(MDME(IDC,1).LT.0) GOTO 130
56623 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56624 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56625 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
56626 IF(I.LE.8) THEN
56627C...Z0 -> q + qbar
56628 EF=KCHG(I,1)/3D0
56629 AF=SIGN(1D0,EF+0.1D0)
56630 VF=AF-4D0*EF*XWV
56631 FCOF=3D0*RADC
56632 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
56633 ELSEIF(I.LE.16) THEN
56634C...Z0 -> l+ + l-, nu + nubar
56635 EF=KCHG(I+2,1)/3D0
56636 AF=SIGN(1D0,EF+0.1D0)
56637 VF=AF-4D0*EF*XWV
56638 FCOF=1D0
56639 ENDIF
56640 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
56641 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
56642 & BE34
56643 WDTP(0)=WDTP(0)+WDTP(I)
56644 130 CONTINUE
56645
56646
56647 ELSEIF(KFLA.EQ.24) THEN
56648C...W+/-:
56649 FAC=(AEM/(24D0*XW))*SHR
56650 DO 140 I=1,MDCY(KC,3)
56651 IDC=I+MDCY(KC,2)-1
56652 IF(MDME(IDC,1).LT.0) GOTO 140
56653 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
56654 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
56655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
56656 WID2=1D0
56657 IF(I.LE.16) THEN
56658C...W+/- -> q + qbar'
56659 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
56660 ELSEIF(I.LE.20) THEN
56661C...W+/- -> l+/- + nu
56662 FCOF=1D0
56663 ENDIF
56664 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
56665 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
56666 WDTP(0)=WDTP(0)+WDTP(I)
56667 140 CONTINUE
56668
56669C.....V8 -> quark anti-quark
56670 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
56671 FAC=AS/6D0*SHR
56672 TANT3=RTCM(21)
56673 IF(ITCM(2).EQ.0) THEN
56674 IMDL=1
56675 ELSEIF(ITCM(2).EQ.1) THEN
56676 IMDL=2
56677 ENDIF
56678 DO 150 I=1,MDCY(KC,3)
56679 IDC=I+MDCY(KC,2)-1
56680 IF(MDME(IDC,1).LT.0) GOTO 150
56681 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
56682 RM1=PM1**2/SH
56683 IF(RM1.GT.0.25D0) GOTO 150
56684 WID2=1D0
56685 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
56686 FMIX=1D0/TANT3**2
56687 ELSE
56688 FMIX=TANT3**2
56689 ENDIF
56690 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
56691 IF(I.EQ.6) WID2=WIDS(6,1)
56692 WDTP(0)=WDTP(0)+WDTP(I)
56693 150 CONTINUE
56694 ENDIF
56695
56696 RETURN
56697 END
56698
56699C*********************************************************************
56700
56701C...PYRVSF
56702C...Calculates R-violating decays of sfermions.
56703C...P. Z. Skands
56704
56705 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
56706
56707C...Double precision and integer declarations.
56708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
56709 IMPLICIT INTEGER(I-N)
56710C...Parameter statement to help give large particle numbers.
56711 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
56712 &KEXCIT=4000000,KDIMEN=5000000)
56713C...Commonblocks.
56714 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56715 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
56716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
56717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
56718 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
56719C...Local variables.
56720 DOUBLE PRECISION XLAM(0:400)
56721 INTEGER IDLAM(400,3), PYCOMP
56722 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
56723
56724C...IS R-VIOLATION ON ?
56725 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
56726C...Mass eigenstate counter
56727 ICNT=INT(KFIN/KSUSY1)
56728C...SM KF code of SUSY particle
56729 KFSM=KFIN-ICNT*KSUSY1
56730C...Squared Sparticle Mass
56731 SM=PMAS(PYCOMP(KFIN),1)**2
56732C... Squared mass of top quark
56733 SMT=PMAS(PYCOMP(6),1)**2
56734C...IS L-VIOLATION ON ?
56735 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
56736C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
56737 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
56738 & THEN
56739 K=INT((KFSM-9)/2)
56740 DO 110 I=1,3
56741 DO 100 J=1,3
56742 IF(I.NE.J) THEN
56743C...~e,~mu,~tau -> nu_I + lepton-_J
56744 LKNT = LKNT+1
56745 IDLAM(LKNT,1)= 12 +2*(I-1)
56746 IDLAM(LKNT,2)= 11 +2*(J-1)
56747 IDLAM(LKNT,3)= 0
56748 XLAM(LKNT)=0D0
56749 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56750 IF (IMSS(51).NE.0) XLAM(LKNT) =
56751 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56752C...KINEMATICS CHECK
56753 IF (XLAM(LKNT).EQ.0D0) THEN
56754 LKNT=LKNT-1
56755 ENDIF
56756 ENDIF
56757 100 CONTINUE
56758 110 CONTINUE
56759C...~e,~mu,~tau -> nu_Ibar + lepton-_K
56760 J=INT((KFSM-9)/2)
56761 DO 130 I=1,3
56762 IF(I.NE.J) THEN
56763 DO 120 K=1,3
56764 LKNT = LKNT+1
56765 IDLAM(LKNT,1)=-12 -2*(I-1)
56766 IDLAM(LKNT,2)= 11 +2*(K-1)
56767 IDLAM(LKNT,3)= 0
56768 XLAM(LKNT)=0D0
56769 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56770 IF (IMSS(51).NE.0) XLAM(LKNT) =
56771 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56772C...KINEMATICS CHECK
56773 IF (XLAM(LKNT).EQ.0D0) THEN
56774 LKNT=LKNT-1
56775 ENDIF
56776 120 CONTINUE
56777 ENDIF
56778 130 CONTINUE
56779C...~e,~mu,~tau -> u_Jbar + d_K
56780 I=INT((KFSM-9)/2)
56781 DO 150 J=1,3
56782 DO 140 K=1,3
56783 LKNT = LKNT+1
56784 IDLAM(LKNT,1)=-2 -2*(J-1)
56785 IDLAM(LKNT,2)= 1 +2*(K-1)
56786 IDLAM(LKNT,3)= 0
56787 XLAM(LKNT)=0
56788 IF (IMSS(52).NE.0) THEN
56789C...Use massive top quark
56790 IF (IDLAM(LKNT,1).EQ.-6) THEN
56791 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
56792 & * (SM-SMT)
56793 XLAM(LKNT) =
56794 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56795C...If no top quark, all decay products massless
56796 ELSE
56797 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56798 XLAM(LKNT) =
56799 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56800 ENDIF
56801C...KINEMATICS CHECK
56802 IF (XLAM(LKNT).EQ.0D0) THEN
56803 LKNT=LKNT-1
56804 ENDIF
56805 ENDIF
56806 140 CONTINUE
56807 150 CONTINUE
56808 ENDIF
56809C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
56810C...No right-handed neutrinos
56811 IF(ICNT.EQ.1) THEN
56812 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
56813 J=INT((KFSM-10)/2)
56814 DO 170 I=1,3
56815 DO 160 K=1,3
56816 IF (I.NE.J) THEN
56817C...~nu_J -> lepton+_I + lepton-_K
56818 LKNT = LKNT+1
56819 IDLAM(LKNT,1)=-11 -2*(I-1)
56820 IDLAM(LKNT,2)= 11 +2*(K-1)
56821 IDLAM(LKNT,3)= 0
56822 XLAM(LKNT)=0D0
56823 RM2=RVLAM(I,J,K)**2 * SM
56824 IF (IMSS(51).NE.0) XLAM(LKNT) =
56825 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56826C...KINEMATICS CHECK
56827 IF (XLAM(LKNT).EQ.0D0) THEN
56828 LKNT=LKNT-1
56829 ENDIF
56830 ENDIF
56831 160 CONTINUE
56832 170 CONTINUE
56833C...~nu_I -> dbar_J + d_K
56834 I=INT((KFSM-10)/2)
56835 DO 190 J=1,3
56836 DO 180 K=1,3
56837 LKNT = LKNT+1
56838 IDLAM(LKNT,1)=-1 -2*(J-1)
56839 IDLAM(LKNT,2)= 1 +2*(K-1)
56840 IDLAM(LKNT,3)= 0
56841 XLAM(LKNT)=0D0
56842 RM2=3*RVLAMP(I,J,K)**2 * SM
56843 IF (IMSS(52).NE.0) XLAM(LKNT) =
56844 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56845C...KINEMATICS CHECK
56846 IF (XLAM(LKNT).EQ.0D0) THEN
56847 LKNT=LKNT-1
56848 ENDIF
56849 180 CONTINUE
56850 190 CONTINUE
56851 ENDIF
56852 ENDIF
56853C * SDOWN -> NU(BAR) + D and LEPTON- + U
56854 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56855 J=INT((KFSM+1)/2)
56856 DO 210 I=1,3
56857 DO 200 K=1,3
56858C...~d_J -> nu_Ibar + d_K
56859 LKNT = LKNT+1
56860 IDLAM(LKNT,1)=-12 -2*(I-1)
56861 IDLAM(LKNT,2)= 1 +2*(K-1)
56862 IDLAM(LKNT,3)= 0
56863 XLAM(LKNT)=0D0
56864 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56865 IF (IMSS(52).NE.0) XLAM(LKNT) =
56866 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56867C...KINEMATICS CHECK
56868 IF (XLAM(LKNT).EQ.0D0) THEN
56869 LKNT=LKNT-1
56870 ENDIF
56871 200 CONTINUE
56872 210 CONTINUE
56873 K=INT((KFSM+1)/2)
56874 DO 240 I=1,3
56875 DO 230 J=1,3
56876C...~d_K -> nu_I + d_J
56877 LKNT = LKNT+1
56878 IDLAM(LKNT,1)= 12 +2*(I-1)
56879 IDLAM(LKNT,2)= 1 +2*(J-1)
56880 IDLAM(LKNT,3)= 0
56881 XLAM(LKNT)=0D0
56882 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56883 IF (IMSS(52).NE.0) XLAM(LKNT) =
56884 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56885C...KINEMATICS CHECK
56886 IF (XLAM(LKNT).EQ.0D0) THEN
56887 LKNT=LKNT-1
56888 ENDIF
56889C...~d_K -> lepton_I- + u_J
56890 220 LKNT = LKNT+1
56891 IDLAM(LKNT,1)= 11 +2*(I-1)
56892 IDLAM(LKNT,2)= 2 +2*(J-1)
56893 IDLAM(LKNT,3)= 0
56894 XLAM(LKNT)=0D0
56895 IF (IMSS(52).NE.0) THEN
56896C...Use massive top quark
56897 IF (IDLAM(LKNT,2).EQ.6) THEN
56898 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
56899 XLAM(LKNT) =
56900 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
56901C...If no top quark, all decay products massless
56902 ELSE
56903 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56904 XLAM(LKNT) =
56905 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56906 ENDIF
56907C...KINEMATICS CHECK
56908 IF (XLAM(LKNT).EQ.0D0) THEN
56909 LKNT=LKNT-1
56910 ENDIF
56911 ENDIF
56912 230 CONTINUE
56913 240 CONTINUE
56914 ENDIF
56915C * SUP -> LEPTON+ + D
56916 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56917 J=NINT(KFSM/2.)
56918 DO 260 I=1,3
56919 DO 250 K=1,3
56920C...~u_J -> lepton_I+ + d_K
56921 LKNT = LKNT+1
56922 IDLAM(LKNT,1)=-11 -2*(I-1)
56923 IDLAM(LKNT,2)= 1 +2*(K-1)
56924 IDLAM(LKNT,3)= 0
56925 XLAM(LKNT)=0D0
56926 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
56927 IF (IMSS(52).NE.0) XLAM(LKNT) =
56928 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56929C...KINEMATICS CHECK
56930 IF (XLAM(LKNT).EQ.0D0) THEN
56931 LKNT=LKNT-1
56932 ENDIF
56933 250 CONTINUE
56934 260 CONTINUE
56935 ENDIF
56936 ENDIF
56937C...BARYON NUMBER VIOLATING DECAYS
56938 IF (IMSS(53).GE.1) THEN
56939C * SUP -> DBAR + DBAR
56940 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
56941 I = KFSM/2
56942 DO 280 J=1,3
56943 DO 270 K=1,3
56944C...~u_I -> dbar_J + dbar_K
56945 IF (J.LT.K) THEN
56946C...(anti-) symmetry J <-> K.
56947 LKNT = LKNT + 1
56948 IDLAM(LKNT,1) = -1 -2*(J-1)
56949 IDLAM(LKNT,2) = -1 -2*(K-1)
56950 IDLAM(LKNT,3) = 0
56951 XLAM(LKNT) = 0D0
56952 RM2 = 2.*(RVLAMB(I,J,K)**2)
56953 & * SFMIX(KFSM,2*ICNT)**2 * SM
56954 XLAM(LKNT) =
56955 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56956C...KINEMATICS CHECK
56957 IF (XLAM(LKNT).EQ.0D0) THEN
56958 LKNT = LKNT-1
56959 ENDIF
56960 ENDIF
56961 270 CONTINUE
56962 280 CONTINUE
56963 ENDIF
56964C * SDOWN -> UBAR + DBAR
56965 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
56966 K=(KFSM+1)/2
56967 DO 300 I=1,3
56968 DO 290 J=1,3
56969C...LAMB coupling antisymmetric in J and K.
56970 IF (J.NE.K) THEN
56971C...~d_K -> ubar_I + dbar_K
56972 LKNT = LKNT + 1
56973 IDLAM(LKNT,1)= -2 -2*(I-1)
56974 IDLAM(LKNT,2)= -1 -2*(J-1)
56975 IDLAM(LKNT,3)= 0
56976 XLAM(LKNT)=0D0
56977C...Use massive top quark
56978 IF (IDLAM(LKNT,1).EQ.-6) THEN
56979 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
56980 & )
56981 XLAM(LKNT) =
56982 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
56983C...If no top quark, all decay products massless
56984 ELSE
56985 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
56986 XLAM(LKNT) =
56987 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
56988 ENDIF
56989C...KINEMATICS CHECK
56990 IF (XLAM(LKNT).EQ.0D0) THEN
56991 LKNT=LKNT-1
56992 ENDIF
56993 ENDIF
56994 290 CONTINUE
56995 300 CONTINUE
56996 ENDIF
56997 ENDIF
56998 ENDIF
56999
57000 RETURN
57001 END
57002
57003C*********************************************************************
57004
57005C...PYRVNE
57006C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57007C...P. Z. Skands
57008
57009 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57010
57011C...Double precision and integer declarations.
57012 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57013 IMPLICIT INTEGER(I-N)
57014C...Parameter statement to help give large particle numbers.
57015 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57016 &KEXCIT=4000000,KDIMEN=5000000)
57017C...Commonblocks.
57018 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57019 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57020 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57021 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57022 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57023 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57024C...Local variables.
57025 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57026 & ,DCMASS,KFR(3)
57027 DOUBLE PRECISION XLAM(0:400)
57028 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57029 INTEGER IDLAM(400,3), PYCOMP
57030 LOGICAL DCMASS
57031 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57032
57033C...R-VIOLATING DECAYS
57034 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57035 KFSM=KFIN-KSUSY1
57036 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57037C...WHICH NEUTRALINO ?
57038 NCHI=1
57039 IF (KFSM.EQ.23) NCHI=2
57040 IF (KFSM.EQ.25) NCHI=3
57041 IF (KFSM.EQ.35) NCHI=4
57042C...SIGN OF MASS (Opposite convention as HERWIG)
57043 ISM = 1
57044 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57045
57046C...Useful parameters for the calculation of the A and B constants.
57047 WMASS = PMAS(PYCOMP(24),1)
57048 ECHG = 2*SQRT(PARU(103)*PARU(1))
57049 COSB=1/(SQRT(1+RMSS(5)**2))
57050 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57051 COSW=SQRT(1-PARU(102))
57052 SINW=SQRT(PARU(102))
57053 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57054C...Run quark masses to neutralino mass squared (for Higgs-type
57055C...couplings)
57056 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57057 DO 100 I=1,6
57058 RMQ(I)=PYMRUN(I,SQMCHI)
57059 100 CONTINUE
57060C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57061 DO 110 NCHJ=1,4
57062 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57063 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57064 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57065 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57066 110 CONTINUE
57067 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57068 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57069 C2=ECHG*ZPMIX(NCHI,1)
57070 C3=GW*ZPMIX(NCHI,2)/COSW
57071 EU=2D0/3D0
57072 ED=-1D0/3D0
57073C... AB(x,y,z):
57074C x=1-2 : Select A or B constant (1:A ; 2:B)
57075C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57076C 11-16:e,nu_e,mu,...)
57077C z=1-2 : Mass eigenstate number
57078C...CALCULATE COUPLINGS
57079 DO 120 I = 11,15,2
57080 CMS=PMAS(PYCOMP(I),1)
57081C...Intermediate sleptons
57082 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57083 & *(C2-C3*SINW**2))
57084 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57085 & *(C2-C3*SINW**2))
57086 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57087 & **2))
57088 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57089 & **2))
57090C...Inermediate sneutrinos
57091 AB(1,I+1,1)=0D0
57092 AB(2,I+1,1)=5D-1*C3
57093 AB(1,I+1,2)=0D0
57094 AB(2,I+1,2)=0D0
57095C...Inermediate sdown
57096 J=I-10
57097 CMS=RMQ(J)
57098 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57099 & *ED*(C2-C3*SINW**2))
57100 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57101 & *ED*(C2-C3*SINW**2))
57102 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57103 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57104 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57105 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57106C...Inermediate sup
57107 J=J+1
57108 CMS=RMQ(J)
57109 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57110 & *EU*(C2-C3*SINW**2))
57111 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57112 & *EU*(C2-C3*SINW**2))
57113 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57114 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57115 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57116 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57117 120 CONTINUE
57118
57119 IF (IMSS(51).GE.1) THEN
57120C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57121C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57122C...STEP IN I,J,K USING SINGLE COUNTER
57123 DO 130 ISC=0,26
57124C...LAMBDA COUPLING ASYM IN I,J
57125 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57126 LKNT = LKNT+1
57127 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57128 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57129 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57130 XLAM(LKNT) = 0D0
57131C...Set coupling, and decay product masses on/off
57132 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57133 & ,MOD(ISC,3)+1)**2
57134 DCMASS=.FALSE.
57135 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57136 & DCMASS = .TRUE.
57137C...Resonance KF codes (1=I,2=J,3=K)
57138 KFR(1)=-IDLAM(LKNT,1)
57139 KFR(2)=-IDLAM(LKNT,2)
57140 KFR(3)=-IDLAM(LKNT,3)
57141C...Calculate width.
57142 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57143 & IDLAM(LKNT,3),XLAM(LKNT))
57144 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57145C...Charge conjugate mode.
57146 LKNT=LKNT+1
57147 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57148 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57149 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57150 XLAM(LKNT)=XLAM(LKNT-1)
57151C...KINEMATICS CHECK
57152 IF (XLAM(LKNT).EQ.0D0) THEN
57153 LKNT=LKNT-2
57154 ENDIF
57155 ENDIF
57156 130 CONTINUE
57157 ENDIF
57158
57159 IF (IMSS(52).GE.1) THEN
57160C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57161C * CHI0 -> NUBAR_I + DBAR_J + D_K
57162 DO 140 ISC=0,26
57163 LKNT = LKNT+1
57164 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57165 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57166 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57167 XLAM(LKNT) = 0D0
57168C...Set coupling, and decay product masses on/off
57169 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57170 & ,MOD(ISC,3)+1)**2
57171 DCMASS=.FALSE.
57172 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57173 & DCMASS = .TRUE.
57174C...Resonance KF codes (1=I,2=J,3=K)
57175 KFR(1)=-IDLAM(LKNT,1)
57176 KFR(2)=-IDLAM(LKNT,2)
57177 KFR(3)=-IDLAM(LKNT,3)
57178C...Calculate width.
57179 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57180 & ,XLAM(LKNT))
57181 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57182C...Charge conjugate mode.
57183 LKNT=LKNT+1
57184 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57185 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57186 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57187 XLAM(LKNT)=XLAM(LKNT-1)
57188C...KINEMATICS CHECK
57189 IF (XLAM(LKNT).EQ.0D0) THEN
57190 LKNT=LKNT-2
57191 ENDIF
57192
57193C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
57194 LKNT = LKNT+1
57195 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57196 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57197 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57198 XLAM(LKNT) = 0D0
57199C...Set coupling, and decay product masses on/off
57200 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57201 & ,MOD(ISC,3)+1)**2
57202 DCMASS=.FALSE.
57203 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57204 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57205C...Resonance KF codes (1=I,2=J,3=K)
57206 KFR(1)=-IDLAM(LKNT,1)
57207 KFR(2)=-IDLAM(LKNT,2)
57208 KFR(3)=-IDLAM(LKNT,3)
57209C...Calculate width.
57210 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57211 & ,XLAM(LKNT))
57212 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57213C...Charge conjugate mode.
57214 LKNT=LKNT+1
57215 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57216 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57217 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57218 XLAM(LKNT)=XLAM(LKNT-1)
57219C...KINEMATICS CHECK
57220 IF (XLAM(LKNT).EQ.0D0) THEN
57221 LKNT=LKNT-2
57222 ENDIF
57223 140 CONTINUE
57224 ENDIF
57225
57226 IF (IMSS(53).GE.1) THEN
57227C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
57228C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
57229 DO 150 ISC=0,26
57230C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
57231 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57232 LKNT = LKNT+1
57233 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57234 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57235 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57236 XLAM(LKNT) = 0D0
57237C...Set coupling, and decay product masses on/off
57238 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
57239 & +1,MOD(ISC,3)+1)**2
57240 DCMASS=.FALSE.
57241 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57242 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57243C...Resonance KF codes (1=I,2=J,3=K)
57244 KFR(1) = IDLAM(LKNT,1)
57245 KFR(2) = IDLAM(LKNT,2)
57246 KFR(3) = IDLAM(LKNT,3)
57247C...Calculate width.
57248 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57249 & IDLAM(LKNT,3),XLAM(LKNT))
57250 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57251C...Charge conjugate mode.
57252 LKNT=LKNT+1
57253 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57254 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57255 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57256 XLAM(LKNT)=XLAM(LKNT-1)
57257C...KINEMATICS CHECK
57258 IF (XLAM(LKNT).EQ.0D0) THEN
57259 LKNT=LKNT-2
57260 ENDIF
57261 ENDIF
57262 150 CONTINUE
57263 ENDIF
57264 ENDIF
57265 ENDIF
57266
57267 RETURN
57268 END
57269
57270C*********************************************************************
57271
57272C...PYRVCH
57273C...Calculates R-violating chargino decay widths.
57274C...P. Z. Skands
57275
57276 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
57277
57278C...Double precision and integer declarations.
57279 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57280 IMPLICIT INTEGER(I-N)
57281C...Parameter statement to help give large particle numbers.
57282 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57283 &KEXCIT=4000000,KDIMEN=5000000)
57284C...Commonblocks.
57285 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57286 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57287 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57288 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57289 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57290 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57291C...Local variables.
57292 DOUBLE PRECISION XLAM(0:400)
57293 INTEGER IDLAM(400,3), PYCOMP
57294C...Information from main routine to PYRVGW
57295 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57296 & ,DCMASS,KFR(3)
57297C...Auxiliary variables needed for BV (RV Gauge STOre)
57298 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57299 & ,RVLJKI,RVLJIK
57300C...Running quark masses
57301 DOUBLE PRECISION RMQ(6)
57302C...Decay product masses on/off
57303 LOGICAL DCMASS
57304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57305 & /RVGSTO/
57306
57307
57308C...IF R-VIOLATION ON.
57309 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57310 KFSM=KFIN-KSUSY1
57311 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
57312C...WHICH CHARGINO ?
57313 NCHI = 1
57314 IF (KFSM.EQ.37) NCHI = 2
57315
57316C...Useful parameters for calculating the A and B constants.
57317C...SIGN OF MASS (Opposite convention as HERWIG)
57318 ISM = 1
57319 IF (SMW(NCHI).LT.0D0) ISM = -1
57320 WMASS = PMAS(PYCOMP(24),1)
57321 COSB = 1/(SQRT(1+RMSS(5)**2))
57322 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
57323 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
57324 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
57325 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
57326 C2 = UMIX(NCHI,1)
57327 C3 = VMIX(NCHI,1)
57328C...Running masses at Q^2=MCHI^2.
57329 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
57330 DO 100 I=1,6
57331 RMQ(I)=PYMRUN(I,SQMCHI)
57332 100 CONTINUE
57333
57334C... AB(x,y,z) coefficients:
57335C x=1-2 : A or B coefficient (1:A ; 2:B)
57336C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57337C 11-16:e,nu_e,mu,...)
57338C z=1-2 : Mass eigenstate number
57339 DO 110 I = 11,15,2
57340C...Intermediate sleptons
57341 AB(1,I,1) = 0D0
57342 AB(1,I,2) = 0D0
57343 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
57344 & SFMIX(I,1)*C2
57345 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
57346 & SFMIX(I,3)*C2
57347C...Intermediate sneutrinos
57348 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
57349 AB(1,I+1,2) = 0D0
57350 AB(2,I+1,1) = ISM*C3
57351 AB(2,I+1,2) = 0D0
57352C...Intermediate sdown
57353 J=I-10
57354 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
57355 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
57356 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
57357 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
57358C...Intermediate sup
57359 J=J+1
57360 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
57361 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
57362 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
57363 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
57364 110 CONTINUE
57365
57366C...LLE TYPE R-VIOLATION
57367 IF (IMSS(51).GE.1) THEN
57368C...LOOP OVER DECAY MODES
57369 DO 140 ISC=0,26
57370
57371C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
57372 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57373 LKNT = LKNT+1
57374 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
57375 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
57376 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
57377 XLAM(LKNT) = 0D0
57378C...Set coupling, and decay product masses on/off
57379 RVLAMC = GW2 * 5D-1 *
57380 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57381 & **2
57382 DCMASS=.FALSE.
57383 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
57384C...Resonance KF codes (1=I,2=J,3=K).
57385 KFR(1) = 0
57386 KFR(2) = 0
57387 KFR(3) = -IDLAM(LKNT,3)+1
57388C...Calculate width.
57389 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57390 & IDLAM(LKNT,3),XLAM(LKNT))
57391 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57392C...KINEMATICS CHECK
57393 IF (XLAM(LKNT).EQ.0D0) THEN
57394 LKNT=LKNT-1
57395 ENDIF
57396
57397C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
57398 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
57399 LKNT = LKNT+1
57400 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57401 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
57402 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
57403 XLAM(LKNT) = 0D0
57404C...Set coupling, and decay product masses on/off
57405 RVLAMC = GW2 * 5D-1 *
57406 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57407C...I,J SYMMETRY => FACTOR 2
57408 RVLAMC=2*RVLAMC
57409 DCMASS=.FALSE.
57410 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
57411C...Resonance KF codes (1=I,2=J,3=K)
57412 KFR(1)=IDLAM(LKNT,1)-1
57413 KFR(2)=IDLAM(LKNT,2)-1
57414 KFR(3)=0
57415C...Calculate width.
57416 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57417 & IDLAM(LKNT,3),XLAM(LKNT))
57418 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57419C...KINEMATICS CHECK
57420 IF (XLAM(LKNT).EQ.0D0) THEN
57421 LKNT=LKNT-1
57422 ENDIF
57423 130 ENDIF
57424
57425C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K
57426 LKNT = LKNT+1
57427 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57428 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57429 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57430 XLAM(LKNT) = 0D0
57431C...Set coupling, and decay product masses on/off
57432 RVLAMC = GW2 * 5D-1 *
57433 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57434C...I,J SYMMETRY => FACTOR 2
57435 RVLAMC=2*RVLAMC
57436 DCMASS=.FALSE.
57437 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
57438 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
57439C...Resonance KF codes (1=I,2=J,3=K)
57440 KFR(1) =-IDLAM(LKNT,1)+1
57441 KFR(2) =-IDLAM(LKNT,2)+1
57442 KFR(3) = 0
57443C...Calculate width.
57444 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57445 & IDLAM(LKNT,3),XLAM(LKNT))
57446 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57447C...KINEMATICS CHECK
57448 IF (XLAM(LKNT).EQ.0D0) THEN
57449 LKNT=LKNT-1
57450 ENDIF
57451 ENDIF
57452 140 CONTINUE
57453 ENDIF
57454
57455C...LQD TYPE R-VIOLATION
57456 IF (IMSS(52).GE.1) THEN
57457C...LOOP OVER DECAY MODES
57458 DO 180 ISC=0,26
57459
57460C...CHI+ -> NUBAR_I + DBAR_J + U_K
57461 LKNT = LKNT+1
57462 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57463 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57464 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57465 XLAM(LKNT) = 0D0
57466C...Set coupling, and decay product masses on/off
57467 RVLAMC = 3. * GW2 * 5D-1 *
57468 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57469 DCMASS=.FALSE.
57470 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
57471 & DCMASS = .TRUE.
57472C...Resonance KF codes (1=I,2=J,3=K)
57473 KFR(1)=0
57474 KFR(2)=0
57475 KFR(3)=-IDLAM(LKNT,3)+1
57476C...Calculate width.
57477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57478 & ,XLAM(LKNT))
57479 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57480C...KINEMATICS CHECK
57481 IF (XLAM(LKNT).EQ.0D0) THEN
57482 LKNT=LKNT-1
57483 ENDIF
57484
57485C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
57486 150 LKNT = LKNT+1
57487 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57488 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57489 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
57490 XLAM(LKNT) = 0D0
57491C...Set coupling, and decay product masses on/off
57492 RVLAMC = 3. * GW2 * 5D-1 *
57493 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57494 DCMASS=.FALSE.
57495 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
57496 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
57497C...Resonance KF codes (1=I,2=J,3=K)
57498 KFR(1)=0
57499 KFR(2)=0
57500 KFR(3)=-IDLAM(LKNT,3)+1
57501C...Calculate width.
57502 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57503 & ,XLAM(LKNT))
57504 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57505C...KINEMATICS CHECK
57506 IF (XLAM(LKNT).EQ.0D0) THEN
57507 LKNT=LKNT-1
57508 ENDIF
57509
57510C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
57511 160 LKNT = LKNT+1
57512 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57513 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57514 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57515 XLAM(LKNT) = 0D0
57516C...Set coupling, and decay product masses on/off
57517 RVLAMC = 3. * GW2 * 5D-1 *
57518 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57519 DCMASS = .FALSE.
57520 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
57521 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57522C...Resonance KF codes (1=I,2=J,3=K)
57523 KFR(1)=-IDLAM(LKNT,1)+1
57524 KFR(2)=-IDLAM(LKNT,2)+1
57525 KFR(3)=0
57526C...Calculate width.
57527 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57528 & ,XLAM(LKNT))
57529 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57530C...KINEMATICS CHECK
57531 IF (XLAM(LKNT).EQ.0D0) THEN
57532 LKNT=LKNT-1
57533 ENDIF
57534
57535C * CHI+ -> NU_I + U_J + DBAR_K.
57536 170 LKNT = LKNT+1
57537 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
57538 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57539 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57540 XLAM(LKNT) = 0D0
57541C...Set coupling, and decay product masses on/off
57542 DCMASS = .FALSE.
57543 RVLAMC = 3. * GW2 * 5D-1 *
57544 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57545 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
57546 & DCMASS = .TRUE.
57547C...Resonance KF codes (1=I,2=J,3=K)
57548 KFR(1)=IDLAM(LKNT,1)-1
57549 KFR(2)=IDLAM(LKNT,2)-1
57550 KFR(3)=0
57551C...Calculate width.
57552 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57553 & ,XLAM(LKNT))
57554 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57555C...KINEMATICS CHECK
57556 IF (XLAM(LKNT).EQ.0D0) THEN
57557 LKNT=LKNT-1
57558 ENDIF
57559
57560 180 CONTINUE
57561 ENDIF
57562
57563C...UDD TYPE R-VIOLATION
57564C...These decays need special treatment since more than one BV coupling
57565C...contributes (with interference). Consider e.g. (symbolically)
57566C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
57567C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
57568C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
57569C...The problem is that a single call to PYRVGW would evaluate all
57570C...these terms and sum them, but without the different couplings. The
57571C...way out is to call PYRVGW three times, once for the first line, once
57572C...for the second line, and then once for all the lines (it is
57573C...impossible to get just the last line out) without multiplying by
57574C...couplings. The last line is then obtained as the result of the third
57575C...call minus the results of the two first calls. Each term is then
57576C...multiplied by its respective coupling before the whole thing is
57577C...summed up in XLAM.
57578C...Note that with three interfering resonances, this procedure becomes
57579C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
57580
57581 IF (IMSS(53).GE.1) THEN
57582C...LOOP OVER DECAY MODES
57583 DO 190 ISC=1,25
57584
57585C...CHI+ -> U_I + U_J + D_K
57586C...Decay mode I<->J symmetric.
57587 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
57588 LKNT = LKNT+1
57589 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
57590 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
57591 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57592 XLAM(LKNT) = 0D0
57593C...Set coupling, and decay product masses on/off
57594 RVLAMC= 6. * GW2 * 5D-1
57595 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
57596 & +1)
57597 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57598 & +1)
57599 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
57600 & * RVLAMC
57601 DCMASS=.FALSE.
57602 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
57603 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
57604C...Resonance KF codes (1=I,2=J,3=K)
57605 KFR(1) = -IDLAM(LKNT,1)+1
57606 KFR(2) = 0
57607 KFR(3) = 0
57608C...Calculate width.
57609 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57610 & IDLAM(LKNT,3),XRESI)
57611C...Resonance KF codes (1=I,2=J,3=K)
57612 KFR(1) = 0
57613 KFR(2) = -IDLAM(LKNT,2)+1
57614 KFR(3) = 0
57615C...Calculate width.
57616 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57617 & IDLAM(LKNT,3),XRESJ)
57618C...Resonance KF codes (1=I,2=J,3=K)
57619 KFR(1) = -IDLAM(LKNT,1)+1
57620 KFR(2) = -IDLAM(LKNT,2)+1
57621 KFR(3) = 0
57622C...Calculate width.
57623 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57624 & IDLAM(LKNT,3),XRESIJ)
57625 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57626 XRESIJ = XRESIJ-XRESI-XRESJ
57627 ELSE
57628 XRESIJ = 0D0
57629 ENDIF
57630C...CALCULATE TOTAL WIDTH
57631 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
57632 & + RVLJIK*RVLIJK * XRESIJ
57633 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57634C...KINEMATICS CHECK
57635 IF (XLAM(LKNT).EQ.0D0) THEN
57636 LKNT=LKNT-1
57637 ENDIF
57638 ENDIF
57639C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
57640C...Symmetry I<->J<->K.
57641 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
57642 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
57643 LKNT = LKNT+1
57644 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
57645 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57646 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57647 XLAM(LKNT) = 0D0
57648C...Set coupling, and decay product masses on/off
57649 RVLAMC = 6. * GW2 * 5D-1
57650 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
57651 & +1)
57652 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
57653 & +1)
57654 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
57655 & +1)
57656 DCMASS = .FALSE.
57657 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
57658 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
57659C...Collect symmetry factors
57660 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
57661 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
57662 & RVLAMC = 5D-1 * RVLAMC
57663C...Resonance KF codes (1=I,2=J,3=K)
57664 KFR(1) = IDLAM(LKNT,1)-1
57665 KFR(2) = 0
57666 KFR(3) = 0
57667C...Calculate width.
57668 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57669 & IDLAM(LKNT,3),XRESI)
57670C...Resonance KF codes (1=I,2=J,3=K)
57671 KFR(1) = 0
57672 KFR(2) = IDLAM(LKNT,2)-1
57673 KFR(3) = 0
57674C...Calculate width.
57675 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57676 & IDLAM(LKNT,3),XRESJ)
57677C...Resonance KF codes (1=I,2=J,3=K)
57678 KFR(1) = 0
57679 KFR(2) = 0
57680 KFR(3) = IDLAM(LKNT,3)-1
57681C...Calculate width.
57682 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57683 & IDLAM(LKNT,3),XRESK)
57684C...Resonance KF codes (1=I,2=J,3=K)
57685 KFR(1) = IDLAM(LKNT,1)-1
57686 KFR(2) = IDLAM(LKNT,2)-1
57687 KFR(3) = 0
57688C...Calculate width.
57689 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57690 & IDLAM(LKNT,3),XRESIJ)
57691 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
57692 XRESIJ = XRESI+XRESJ-XRESIJ
57693 ELSE
57694 XRESIJ = 0D0
57695 ENDIF
57696C...Resonance KF codes (1=I,2=J,3=K)
57697 KFR(1) = 0
57698 KFR(2) = IDLAM(LKNT,2)-1
57699 KFR(3) = IDLAM(LKNT,3)-1
57700C...Calculate width.
57701 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57702 & IDLAM(LKNT,3),XRESJK)
57703 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
57704 XRESJK = XRESJ+XRESK-XRESJK
57705 ELSE
57706 XRESJK = 0D0
57707 ENDIF
57708C...Resonance KF codes (1=I,2=J,3=K)
57709 KFR(1) = IDLAM(LKNT,1)-1
57710 KFR(2) = 0
57711 KFR(3) = IDLAM(LKNT,3)-1
57712C...Calculate width.
57713 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57714 & IDLAM(LKNT,3),XRESIK)
57715 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
57716 XRESIK = XRESI+XRESK-XRESIK
57717 ELSE
57718 XRESIK = 0D0
57719 ENDIF
57720C...CALCULATE TOTAL WIDTH
57721 XLAM(LKNT) =
57722 & RVLIJK**2 * XRESI
57723 & + RVLJKI**2 * XRESJ
57724 & + RVLKIJ**2 * XRESK
57725 & + RVLIJK*RVLJKI * XRESIJ
57726 & + RVLIJK*RVLKIJ * XRESIK
57727 & + RVLJKI*RVLKIJ * XRESJK
57728 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
57729C...KINEMATICS CHECK
57730 IF (XLAM(LKNT).EQ.0D0) THEN
57731 LKNT=LKNT-1
57732 ENDIF
57733 ENDIF
57734 190 CONTINUE
57735 ENDIF
57736 ENDIF
57737 ENDIF
57738
57739 RETURN
57740 END
57741
57742C*********************************************************************
57743
57744C...PYRVGL
57745C...Calculates R-violating gluino decay widths.
57746C...See BV part of PYRVCH for comments about the way the BV decay width
57747C...is calculated. Same comments apply here.
57748C...P. Z. Skands
57749
57750 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
57751
57752C...Double precision and integer declarations.
57753 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57754 IMPLICIT INTEGER(I-N)
57755C...Parameter statement to help give large particle numbers.
57756 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57757 &KEXCIT=4000000,KDIMEN=5000000)
57758C...Commonblocks.
57759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57761 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57762 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57763 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57764 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57765C...Local variables.
57766 DOUBLE PRECISION XLAM(0:400)
57767 INTEGER IDLAM(400,3), PYCOMP
57768C...Information from main routine to PYRVGW
57769 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57770 & ,DCMASS,KFR(3)
57771C...Auxiliary variables needed for BV (RV Gauge STOre)
57772 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
57773 & ,RVLJKI,RVLJIK
57774C...Running quark masses
57775 DOUBLE PRECISION RMQ(6)
57776C...Decay product masses on/off
57777 LOGICAL DCMASS
57778 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
57779 & /RVGSTO/
57780
57781C...IF LQD OR UDD TYPE R-VIOLATION ON.
57782 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
57783 KFSM=KFIN-KSUSY1
57784
57785C... AB(x,y,z):
57786C x=1-2 : Select A or B coupling (1:A ; 2:B)
57787C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57788C 11-16:e,nu_e,mu,... not used here)
57789C z=1-2 : Mass eigenstate number
57790 DO 100 I = 1,6
57791C...A Couplings
57792 AB(1,I,1) = SFMIX(I,2)
57793 AB(1,I,2) = SFMIX(I,4)
57794C...B Couplings
57795 AB(2,I,1) = -SFMIX(I,1)
57796 AB(2,I,2) = -SFMIX(I,3)
57797 100 CONTINUE
57798 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
57799C...LQD DECAYS.
57800 IF (IMSS(52).GE.1) THEN
57801C...STEP IN I,J,K USING SINGLE COUNTER
57802 DO 120 ISC=0,26
57803C * GLUINO -> NUBAR_I + DBAR_J + D_K.
57804 LKNT = LKNT+1
57805 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57806 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57807 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57808 XLAM(LKNT)=0D0
57809C...Set coupling, and decay product masses on/off
57810 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
57811 & * 5D-1 * GSTR2
57812 DCMASS = .FALSE.
57813 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
57814C...Resonance KF codes (1=I,2=J,3=K)
57815 KFR(1) = 0
57816 KFR(2) = -IDLAM(LKNT,2)
57817 KFR(3) = -IDLAM(LKNT,3)
57818C...Calculate width.
57819 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57820 & ,XLAM(LKNT))
57821C...Normalize
57822 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57823C...Charge conjugate mode.
57824 110 LKNT = LKNT+1
57825 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57826 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57827 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57828 XLAM(LKNT) = XLAM(LKNT-1)
57829C...KINEMATICS CHECK
57830 IF (XLAM(LKNT).EQ.0D0) THEN
57831 LKNT=LKNT-2
57832 ENDIF
57833
57834C * GLUINO -> LEPTON+_I + UBAR_J + D_K
57835 LKNT = LKNT+1
57836 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
57837 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
57838 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57839 XLAM(LKNT)=0D0
57840C...Set coupling, and decay product masses on/off
57841 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57842 & **2* 5D-1 * GSTR2
57843 DCMASS = .FALSE.
57844 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
57845 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
57846C...Resonance KF codes (1=I,2=J,3=K)
57847 KFR(1) = 0
57848 KFR(2) = -IDLAM(LKNT,2)
57849 KFR(3) = -IDLAM(LKNT,3)
57850C...Calculate width.
57851 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57852 & ,XLAM(LKNT))
57853 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57854C...Charge conjugate mode.
57855 LKNT=LKNT+1
57856 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
57857 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
57858 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
57859 XLAM(LKNT) = XLAM(LKNT-1)
57860C...KINEMATICS CHECK
57861 IF (XLAM(LKNT).EQ.0D0) THEN
57862 LKNT=LKNT-2
57863 ENDIF
57864
57865 120 CONTINUE
57866 ENDIF
57867
57868C...UDD DECAYS.
57869 IF (IMSS(53).GE.1) THEN
57870C...STEP IN I,J,K USING SINGLE COUNTER
57871 DO 130 ISC=0,26
57872C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
57873 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
57874 LKNT = LKNT+1
57875 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
57876 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57877 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
57878 XLAM(LKNT)=0D0
57879C...Set coupling, and decay product masses on/off. A factor of 2 for
57880C...(N_C-1) has been used to cancel a factor 0.5.
57881 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
57882 & **2 * GSTR2
57883 DCMASS = .FALSE.
57884 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
57885 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
57886C...Resonance KF codes (1=I,2=J,3=K)
57887 KFR(1) = IDLAM(LKNT,1)
57888 KFR(2) = 0
57889 KFR(3) = 0
57890C...Calculate width.
57891 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57892 & ,XRESI)
57893C...Resonance KF codes (1=I,2=J,3=K)
57894 KFR(1) = 0
57895 KFR(2) = IDLAM(LKNT,2)
57896 KFR(3) = 0
57897C...Calculate width.
57898 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57899 & ,XRESJ)
57900C...Resonance KF codes (1=I,2=J,3=K)
57901 KFR(1) = 0
57902 KFR(2) = 0
57903 KFR(3) = IDLAM(LKNT,3)
57904C...Calculate width.
57905 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57906 & ,XRESK)
57907C...Resonance KF codes (1=I,2=J,3=K)
57908 KFR(1) = IDLAM(LKNT,1)
57909 KFR(2) = IDLAM(LKNT,2)
57910 KFR(3) = 0
57911C...Calculate width.
57912 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57913 & ,XRESIJ)
57914C...Calculate interference function. (Factor -1/2 to make up for factor
57915C...-2 in PYRVGW.
57916 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
57917 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
57918 ELSE
57919 XRESIJ = 0D0
57920 ENDIF
57921C...Resonance KF codes (1=I,2=J,3=K)
57922 KFR(1) = 0
57923 KFR(2) = IDLAM(LKNT,2)
57924 KFR(3) = IDLAM(LKNT,3)
57925C...Calculate width.
57926 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57927 & ,XRESJK)
57928 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
57929 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
57930 ELSE
57931 XRESJK = 0D0
57932 ENDIF
57933C...Resonance KF codes (1=I,2=J,3=K)
57934 KFR(1) = IDLAM(LKNT,1)
57935 KFR(2) = 0
57936 KFR(3) = IDLAM(LKNT,3)
57937C...Calculate width.
57938 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57939 & ,XRESIK)
57940 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
57941 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
57942 ELSE
57943 XRESIK = 0D0
57944 ENDIF
57945C...Calculate total width (factor 1/2 from 1/(N_C-1))
57946 XLAM(LKNT) = XRESI + XRESJ + XRESK
57947 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
57948C...Normalize
57949 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57950C...Charge conjugate mode.
57951 LKNT = LKNT+1
57952 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
57953 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
57954 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
57955 XLAM(LKNT) = XLAM(LKNT-1)
57956C...KINEMATICS CHECK
57957 IF (XLAM(LKNT).EQ.0D0) THEN
57958 LKNT=LKNT-2
57959 ENDIF
57960 ENDIF
57961 130 CONTINUE
57962 ENDIF
57963 ENDIF
57964 RETURN
57965 END
57966
57967C*********************************************************************
57968
57969C...PYRVSB
57970C...Auxiliary function to PYRVSF for calculating R-Violating
57971C...sfermion widths. Though the decay products are most often treated
57972C...as massless in the calculation, the kinematical boundary of phase
57973C...space is tested using the true masses.
57974C...MODE = 1: All decay products massive
57975C...MODE = 2: Decay product 1 massless
57976C...MODE = 3: Decay product 2 massless
57977C...MODE = 4: All decay products massless
57978
57979 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
57980
57981 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
57982 IMPLICIT INTEGER (I-N)
57983 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57984 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57985 SAVE /PYDAT1/,/PYDAT2/
57986 DOUBLE PRECISION SM(3)
57987 INTEGER PYCOMP, KC(3)
57988 KC(1)=PYCOMP(KFIN)
57989 KC(2)=PYCOMP(ID1)
57990 KC(3)=PYCOMP(ID2)
57991 SM(1)=PMAS(KC(1),1)**2
57992 SM(2)=PMAS(KC(2),1)**2
57993 SM(3)=PMAS(KC(3),1)**2
57994C...Kinematics check
57995 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
57996 PYRVSB=0D0
57997 RETURN
57998 ENDIF
57999C...CM momenta squared
58000 IF (MODE.EQ.1) THEN
58001 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58002 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58003 ELSE IF (MODE.EQ.2) THEN
58004 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58005 ELSE IF (MODE.EQ.3) THEN
58006 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58007 ELSE
58008 P2CM=SM(1)/4.
58009 ENDIF
58010C...Calculate Width
58011 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58012 RETURN
58013 END
58014
58015C*********************************************************************
58016
58017C...PYRVGW
58018C...Generalized Matrix Element for R-Violating 3-body widths.
58019C...P. Z. Skands
58020 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58021
58022 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58023 IMPLICIT INTEGER (I-N)
58024 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58025 &KEXCIT=4000000,KDIMEN=5000000)
58026 PARAMETER (EPS=1D-4)
58027 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58028 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58029 & ,DCMASS,KFR(3)
58030 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58031 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58032 DOUBLE PRECISION XLIM(3,3)
58033 INTEGER KC(0:3), PYCOMP
58034 LOGICAL DCMASS, DCHECK(6)
58035 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58036
58037 XLAM = 0D0
58038
58039 KC(0) = PYCOMP(KFIN)
58040 KC(1) = PYCOMP(ID1)
58041 KC(2) = PYCOMP(ID2)
58042 KC(3) = PYCOMP(ID3)
58043 RMS(0) = PMAS(KC(0),1)
58044 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58045 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58046 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58047C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58048 XLIM(1,1)=(RMS(1)+RMS(2))**2
58049 XLIM(1,2)=(RMS(0)-RMS(3))**2
58050 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58051 XLIM(2,1)=(RMS(2)+RMS(3))**2
58052 XLIM(2,2)=(RMS(0)-RMS(1))**2
58053 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58054 XLIM(3,1)=(RMS(1)+RMS(3))**2
58055 XLIM(3,2)=(RMS(0)-RMS(2))**2
58056 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58057C...Check Phase Space
58058 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58059 RETURN
58060 ENDIF
58061
58062C...INITIALIZE RESONANCE INFORMATION
58063 DO 110 JRES = 1,3
58064 DO 100 IMASS = 1,2
58065 IRES = 2*(JRES-1)+IMASS
58066 INTRES(IRES,1) = 0
58067 DCHECK(IRES) =.FALSE.
58068C...NO RIGHT-HANDED NEUTRINOS
58069 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58070 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58071 & .KFR(JRES).EQ.0) GOTO 100
58072 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58073 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58074 INTRES(IRES,1) = IABS(KFR(JRES))
58075 INTRES(IRES,2) = IMASS
58076 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58077 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58078 100 CONTINUE
58079 110 CONTINUE
58080
58081C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58082
58083C...RESONANCE CONTRIBUTIONS
58084C...(Only sum contributions where the resonance is off shell).
58085C...Store whether diagram on/off in DCHECK.
58086C...LOOP OVER MASS STATES
58087 DO 120 J=1,2
58088 IDR=J
58089 IF(INTRES(IDR,1).NE.0) THEN
58090
58091 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58092 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58093 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58094 DCHECK(IDR) =.TRUE.
58095 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58096 ENDIF
58097 ENDIF
58098
58099 IDR=J+2
58100 IF(INTRES(IDR,1).NE.0) THEN
58101 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58102 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58103 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58104 DCHECK(IDR) =.TRUE.
58105 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58106 ENDIF
58107 ENDIF
58108
58109 IDR=J+4
58110 IF(INTRES(IDR,1).NE.0) THEN
58111 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58112 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58113 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58114 DCHECK(IDR) =.TRUE.
58115 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58116 ENDIF
58117 ENDIF
58118 120 CONTINUE
58119C... L-R INTERFERENCES
58120C... (Only add contributions where both contributing diagrams
58121C... are non-resonant).
58122 IDR=1
58123 IF (DCHECK(1).AND.DCHECK(2)) THEN
58124C...Bug corrected 11/12 2001. Skands.
58125 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58126 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58127 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58128 ENDIF
58129
58130 IDR=3
58131 IF (DCHECK(3).AND.DCHECK(4)) THEN
58132 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58133 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58134 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58135 ENDIF
58136
58137 IDR=5
58138 IF (DCHECK(5).AND.DCHECK(6)) THEN
58139 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58140 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58141 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58142 ENDIF
58143C... TRUE INTERFERENCES
58144C... (Only add contributions where both contributing diagrams
58145C... are non-resonant).
58146 PREF=-2D0
58147 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58148 DO 140 IKR1 = 1,2
58149 DO 130 IKR2 = 1,2
58150 IDR = IKR1+2
58151 IDR2 = IKR2
58152 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58153 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58154 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58155 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58156 ENDIF
58157
58158 IDR = IKR1+4
58159 IDR2 = IKR2
58160 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58161 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58162 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58163 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58164 ENDIF
58165
58166 IDR = IKR1+4
58167 IDR2 = IKR2+2
58168 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58169 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58170 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58171 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58172 ENDIF
58173 130 CONTINUE
58174 140 CONTINUE
58175
58176 RETURN
58177 END
58178
58179C*********************************************************************
58180
58181C...PYRVI1
58182C...Function to integrate resonance contributions
58183
58184 FUNCTION PYRVI1(ID1,ID2,ID3)
58185
58186 IMPLICIT NONE
58187 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58188 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58189 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58190 LOGICAL MFLAG,DCMASS
58191 EXTERNAL PYRVG1,PYGAUS
58192 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58193 & ,DCMASS,KFR(3)
58194 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58195 SAVE/PYRVNV/,/PYRVPM/
58196C...Initialize mass and width information
58197 PYRVI1 = 0D0
58198 RM(0) = RMS(0)
58199 RM(1) = RMS(ID1)
58200 RM(2) = RMS(ID2)
58201 RM(3) = RMS(ID3)
58202 RESM(1)= RES(IDR,1)
58203 RESW(1)= RES(IDR,2)
58204C...A->B and B->A for antisparticles
58205 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58206 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58207C...Integration boundaries and mass flag
58208 LO = (RM(1)+RM(2))**2
58209 HI = (RM(0)-RM(3))**2
58210 MFLAG = DCMASS
58211 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
58212 RETURN
58213 END
58214
58215C*********************************************************************
58216
58217C...PYRVI2
58218C...Function to integrate L-R interference contributions
58219
58220 FUNCTION PYRVI2(ID1,ID2,ID3)
58221
58222 IMPLICIT NONE
58223 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
58224 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58225 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58226 LOGICAL MFLAG,DCMASS
58227 EXTERNAL PYRVG2,PYGAUS
58228 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58229 & ,DCMASS,KFR(3)
58230 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58231 SAVE/PYRVNV/,/PYRVPM/
58232C...Initialize mass and width information
58233 PYRVI2 = 0D0
58234 RM(0) = RMS(0)
58235 RM(1) = RMS(ID1)
58236 RM(2) = RMS(ID2)
58237 RM(3) = RMS(ID3)
58238 RESM(1)= RES(IDR,1)
58239 RESW(1)= RES(IDR,2)
58240 RESM(2)= RES(IDR+1,1)
58241 RESW(2)= RES(IDR+1,2)
58242C...A->B and B->A for antisparticles
58243 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58244 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58245 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58246 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
58247C...Boundaries and mass flag
58248 LO = (RM(1)+RM(2))**2
58249 HI = (RM(0)-RM(3))**2
58250 MFLAG = DCMASS
58251 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
58252 RETURN
58253 END
58254
58255C*********************************************************************
58256
58257C...PYRVI3
58258C...Function to integrate true interference contributions
58259
58260 FUNCTION PYRVI3(ID1,ID2,ID3)
58261
58262 IMPLICIT NONE
58263 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
58264 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58265 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58266 LOGICAL MFLAG,DCMASS
58267 EXTERNAL PYRVG3,PYGAUS
58268 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58269 & ,DCMASS,KFR(3)
58270 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58271 SAVE/PYRVNV/,/PYRVPM/
58272C...Initialize mass and width information
58273 PYRVI3 = 0D0
58274 RM(0) = RMS(0)
58275 RM(1) = RMS(ID1)
58276 RM(2) = RMS(ID2)
58277 RM(3) = RMS(ID3)
58278 RESM(1)= RES(IDR,1)
58279 RESW(1)= RES(IDR,2)
58280 RESM(2)= RES(IDR2,1)
58281 RESW(2)= RES(IDR2,2)
58282C...A -> B and B -> A for antisparticles
58283 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58284 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
58285 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58286 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
58287C...Boundaries and mass flag
58288 LO = (RM(1)+RM(2))**2
58289 HI = (RM(0)-RM(3))**2
58290 MFLAG = DCMASS
58291 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
58292 RETURN
58293 END
58294
58295C*********************************************************************
58296
58297C...PYRVG1
58298C...Integrand for resonance contributions
58299
58300 FUNCTION PYRVG1(X)
58301
58302 IMPLICIT NONE
58303 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58304 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
58305 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
58306 LOGICAL MFLAG
58307 SAVE/PYRVPM/
58308 RVR = PYRVR(X,RESM(1),RESW(1))
58309 C1 = 2D0*SQRT(MAX(0D0,X))
58310 IF (.NOT.MFLAG) THEN
58311 E2 = X/C1
58312 E3 = (RM(0)**2-X)/C1
58313 DELTAY = 4D0*E2*E3
58314 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
58315 ELSE
58316 E2 = (X-RM(1)**2+RM(2)**2)/C1
58317 E3 = (RM(0)**2-X-RM(3)**2)/C1
58318 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58319 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58320 DELTAY = 4D0*SR1*SR2
58321 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
58322 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
58323 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
58324 ENDIF
58325 RETURN
58326 END
58327
58328C*********************************************************************
58329
58330C...PYRVG2
58331C...Integrand for L-R interference contributions
58332
58333 FUNCTION PYRVG2(X)
58334
58335 IMPLICIT NONE
58336 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58337 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
58338 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
58339 LOGICAL MFLAG
58340 SAVE/PYRVPM/
58341 C1 = 2D0*SQRT(MAX(0D0,X))
58342 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
58343 IF (.NOT.MFLAG) THEN
58344 E2 = X/C1
58345 E3 = (RM(0)**2-X)/C1
58346 DELTAY = 4D0*E2*E3
58347 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
58348 ELSE
58349 E2 = (X-RM(1)**2+RM(2)**2)/C1
58350 E3 = (RM(0)**2-X-RM(3)**2)/C1
58351 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58352 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58353 DELTAY = 4D0*SR1*SR2
58354 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
58355 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
58356 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
58357 ENDIF
58358 RETURN
58359 END
58360
58361C*********************************************************************
58362
58363C...PYRVG3
58364C...Function to do Y integration over true interference contributions
58365
58366 FUNCTION PYRVG3(X)
58367
58368 IMPLICIT NONE
58369 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58370C...Second Dalitz variable for PYRVG4
58371 COMMON/PYG2DX/X1
58372 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
58373 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
58374 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
58375 LOGICAL MFLAG
58376 EXTERNAL PYGAU2,PYRVG4
58377 SAVE/PYRVPM/,/PYG2DX/
58378 PYRVG3=0D0
58379 C1=2D0*SQRT(MAX(1D-9,X))
58380 X1=X
58381 IF (.NOT.MFLAG) THEN
58382 E2 = X/C1
58383 E3 = (RM(0)**2-X)/C1
58384 YMIN = 0D0
58385 YMAX = 4D0*E2*E3
58386 ELSE
58387 E2 = (X-RM(1)**2+RM(2)**2)/C1
58388 E3 = (RM(0)**2-X-RM(3)**2)/C1
58389 SQ1 = (E2+E3)**2
58390 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
58391 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
58392 YMIN = SQ1-(SR1+SR2)**2
58393 YMAX = SQ1-(SR1-SR2)**2
58394 ENDIF
58395 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
58396 RETURN
58397 END
58398
58399C*********************************************************************
58400
58401C...PYRVG4
58402C...Integrand for true intereference contributions
58403
58404 FUNCTION PYRVG4(Y)
58405
58406 IMPLICIT NONE
58407 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
58408 COMMON/PYG2DX/X
58409 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
58410 LOGICAL MFLAG
58411 SAVE /PYRVPM/,/PYG2DX/
58412 PYRVG4=0D0
58413 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
58414 IF (.NOT.MFLAG) THEN
58415 PYRVG4 = RVS*B(1)*B(2)*X*Y
58416 ELSE
58417 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
58418 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
58419 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
58420 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
58421 ENDIF
58422 RETURN
58423 END
58424
58425C*********************************************************************
58426
58427C...PYRVR
58428C...Breit-Wigner for resonance contributions
58429
58430 FUNCTION PYRVR(Mab2,RM,RW)
58431
58432 IMPLICIT NONE
58433 DOUBLE PRECISION Mab2,RM,RW,PYRVR
58434 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
58435 RETURN
58436 END
58437
58438C*********************************************************************
58439
58440C...PYRVS
58441C...Interference function
58442
58443 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
58444
58445 IMPLICIT NONE
58446 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
58447 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
58448 & +W1*W2*M1*M2)
58449 RETURN
58450 END
58451
58452C*********************************************************************
58453
58454C...PY1ENT
58455C...Stores one parton/particle in commonblock PYJETS.
58456
58457 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
58458
58459C...Double precision and integer declarations.
58460 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58461 IMPLICIT INTEGER(I-N)
58462 INTEGER PYK,PYCHGE,PYCOMP
58463C...Commonblocks.
58464 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58465 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58466 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58467 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58468
58469C...Standard checks.
58470 MSTU(28)=0
58471 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58472 IPA=MAX(1,IABS(IP))
58473 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
58474 &'(PY1ENT:) writing outside PYJETS memory')
58475 KC=PYCOMP(KF)
58476 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
58477
58478C...Find mass. Reset K, P and V vectors.
58479 PM=0D0
58480 IF(MSTU(10).EQ.1) PM=P(IPA,5)
58481 IF(MSTU(10).GE.2) PM=PYMASS(KF)
58482 DO 100 J=1,5
58483 K(IPA,J)=0
58484 P(IPA,J)=0D0
58485 V(IPA,J)=0D0
58486 100 CONTINUE
58487
58488C...Store parton/particle in K and P vectors.
58489 K(IPA,1)=1
58490 IF(IP.LT.0) K(IPA,1)=2
58491 K(IPA,2)=KF
58492 P(IPA,5)=PM
58493 P(IPA,4)=MAX(PE,PM)
58494 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
58495 P(IPA,1)=PA*SIN(THE)*COS(PHI)
58496 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
58497 P(IPA,3)=PA*COS(THE)
58498
58499C...Set N. Optionally fragment/decay.
58500 N=IPA
58501 IF(IP.EQ.0) CALL PYEXEC
58502
58503 RETURN
58504 END
58505
58506C*********************************************************************
58507
58508C...PY2ENT
58509C...Stores two partons/particles in their CM frame,
58510C...with the first along the +z axis.
58511
58512 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
58513
58514C...Double precision and integer declarations.
58515 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58516 IMPLICIT INTEGER(I-N)
58517 INTEGER PYK,PYCHGE,PYCOMP
58518C...Commonblocks.
58519 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58520 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58521 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58522 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58523
58524C...Standard checks.
58525 MSTU(28)=0
58526 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58527 IPA=MAX(1,IABS(IP))
58528 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
58529 &'(PY2ENT:) writing outside PYJETS memory')
58530 KC1=PYCOMP(KF1)
58531 KC2=PYCOMP(KF2)
58532 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
58533 &'(PY2ENT:) unknown flavour code')
58534
58535C...Find masses. Reset K, P and V vectors.
58536 PM1=0D0
58537 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58538 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58539 PM2=0D0
58540 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58541 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58542 DO 110 I=IPA,IPA+1
58543 DO 100 J=1,5
58544 K(I,J)=0
58545 P(I,J)=0D0
58546 V(I,J)=0D0
58547 100 CONTINUE
58548 110 CONTINUE
58549
58550C...Check flavours.
58551 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58552 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58553 IF(MSTU(19).EQ.1) THEN
58554 MSTU(19)=0
58555 ELSE
58556 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
58557 & '(PY2ENT:) unphysical flavour combination')
58558 ENDIF
58559 K(IPA,2)=KF1
58560 K(IPA+1,2)=KF2
58561
58562C...Store partons/particles in K vectors for normal case.
58563 IF(IP.GE.0) THEN
58564 K(IPA,1)=1
58565 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
58566 K(IPA+1,1)=1
58567
58568C...Store partons in K vectors for parton shower evolution.
58569 ELSE
58570 K(IPA,1)=3
58571 K(IPA+1,1)=3
58572 K(IPA,4)=MSTU(5)*(IPA+1)
58573 K(IPA,5)=K(IPA,4)
58574 K(IPA+1,4)=MSTU(5)*IPA
58575 K(IPA+1,5)=K(IPA+1,4)
58576 ENDIF
58577
58578C...Check kinematics and store partons/particles in P vectors.
58579 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
58580 &'(PY2ENT:) energy smaller than sum of masses')
58581 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
58582 &(2D0*PECM)
58583 P(IPA,3)=PA
58584 P(IPA,4)=SQRT(PM1**2+PA**2)
58585 P(IPA,5)=PM1
58586 P(IPA+1,3)=-PA
58587 P(IPA+1,4)=SQRT(PM2**2+PA**2)
58588 P(IPA+1,5)=PM2
58589
58590C...Set N. Optionally fragment/decay.
58591 N=IPA+1
58592 IF(IP.EQ.0) CALL PYEXEC
58593
58594 RETURN
58595 END
58596
58597C*********************************************************************
58598
58599C...PY3ENT
58600C...Stores three partons or particles in their CM frame,
58601C...with the first along the +z axis and the third in the (x,z)
58602C...plane with x > 0.
58603
58604 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
58605
58606C...Double precision and integer declarations.
58607 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58608 IMPLICIT INTEGER(I-N)
58609 INTEGER PYK,PYCHGE,PYCOMP
58610C...Commonblocks.
58611 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58612 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58613 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58614 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58615
58616C...Standard checks.
58617 MSTU(28)=0
58618 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58619 IPA=MAX(1,IABS(IP))
58620 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
58621 &'(PY3ENT:) writing outside PYJETS memory')
58622 KC1=PYCOMP(KF1)
58623 KC2=PYCOMP(KF2)
58624 KC3=PYCOMP(KF3)
58625 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
58626 &'(PY3ENT:) unknown flavour code')
58627
58628C...Find masses. Reset K, P and V vectors.
58629 PM1=0D0
58630 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58631 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58632 PM2=0D0
58633 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58634 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58635 PM3=0D0
58636 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58637 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58638 DO 110 I=IPA,IPA+2
58639 DO 100 J=1,5
58640 K(I,J)=0
58641 P(I,J)=0D0
58642 V(I,J)=0D0
58643 100 CONTINUE
58644 110 CONTINUE
58645
58646C...Check flavours.
58647 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58648 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58649 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58650 IF(MSTU(19).EQ.1) THEN
58651 MSTU(19)=0
58652 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
58653 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
58654 & KQ1+KQ3.EQ.4)) THEN
58655 ELSE
58656 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
58657 ENDIF
58658 K(IPA,2)=KF1
58659 K(IPA+1,2)=KF2
58660 K(IPA+2,2)=KF3
58661
58662C...Store partons/particles in K vectors for normal case.
58663 IF(IP.GE.0) THEN
58664 K(IPA,1)=1
58665 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
58666 K(IPA+1,1)=1
58667 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
58668 K(IPA+2,1)=1
58669
58670C...Store partons in K vectors for parton shower evolution.
58671 ELSE
58672 K(IPA,1)=3
58673 K(IPA+1,1)=3
58674 K(IPA+2,1)=3
58675 KCS=4
58676 IF(KQ1.EQ.-1) KCS=5
58677 K(IPA,KCS)=MSTU(5)*(IPA+1)
58678 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
58679 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58680 K(IPA+1,9-KCS)=MSTU(5)*IPA
58681 K(IPA+2,KCS)=MSTU(5)*IPA
58682 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58683 ENDIF
58684
58685C...Check kinematics.
58686 MKERR=0
58687 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
58688 &0.5D0*X3*PECM.LE.PM3) MKERR=1
58689 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58690 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
58691 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
58692 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
58693 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
58694 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
58695 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
58696 IF(MKERR.NE.0) CALL PYERRM(13,
58697 &'(PY3ENT:) unphysical kinematical variable setup')
58698
58699C...Store partons/particles in P vectors.
58700 P(IPA,3)=PA1
58701 P(IPA,4)=SQRT(PA1**2+PM1**2)
58702 P(IPA,5)=PM1
58703 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
58704 P(IPA+2,3)=PA3*CTHE3
58705 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
58706 P(IPA+2,5)=PM3
58707 P(IPA+1,1)=-P(IPA+2,1)
58708 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
58709 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
58710 P(IPA+1,5)=PM2
58711
58712C...Set N. Optionally fragment/decay.
58713 N=IPA+2
58714 IF(IP.EQ.0) CALL PYEXEC
58715
58716 RETURN
58717 END
58718
58719C*********************************************************************
58720
58721C...PY4ENT
58722C...Stores four partons or particles in their CM frame, with
58723C...the first along the +z axis, the last in the xz plane with x > 0
58724C...and the second having y < 0 and y > 0 with equal probability.
58725
58726 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
58727
58728C...Double precision and integer declarations.
58729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58730 IMPLICIT INTEGER(I-N)
58731 INTEGER PYK,PYCHGE,PYCOMP
58732C...Commonblocks.
58733 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58734 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58735 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58736 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
58737
58738C...Standard checks.
58739 MSTU(28)=0
58740 IF(MSTU(12).NE.12345) CALL PYLIST(0)
58741 IPA=MAX(1,IABS(IP))
58742 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
58743 &'(PY4ENT:) writing outside PYJETS momory')
58744 KC1=PYCOMP(KF1)
58745 KC2=PYCOMP(KF2)
58746 KC3=PYCOMP(KF3)
58747 KC4=PYCOMP(KF4)
58748 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
58749 &'(PY4ENT:) unknown flavour code')
58750
58751C...Find masses. Reset K, P and V vectors.
58752 PM1=0D0
58753 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
58754 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
58755 PM2=0D0
58756 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
58757 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
58758 PM3=0D0
58759 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
58760 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
58761 PM4=0D0
58762 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
58763 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
58764 DO 110 I=IPA,IPA+3
58765 DO 100 J=1,5
58766 K(I,J)=0
58767 P(I,J)=0D0
58768 V(I,J)=0D0
58769 100 CONTINUE
58770 110 CONTINUE
58771
58772C...Check flavours.
58773 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
58774 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
58775 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
58776 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
58777 IF(MSTU(19).EQ.1) THEN
58778 MSTU(19)=0
58779 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
58780 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
58781 & KQ1+KQ4.EQ.4)) THEN
58782 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
58783 & THEN
58784 ELSE
58785 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
58786 ENDIF
58787 K(IPA,2)=KF1
58788 K(IPA+1,2)=KF2
58789 K(IPA+2,2)=KF3
58790 K(IPA+3,2)=KF4
58791
58792C...Store partons/particles in K vectors for normal case.
58793 IF(IP.GE.0) THEN
58794 K(IPA,1)=1
58795 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
58796 K(IPA+1,1)=1
58797 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
58798 & K(IPA+1,1)=2
58799 K(IPA+2,1)=1
58800 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
58801 K(IPA+3,1)=1
58802
58803C...Store partons for parton shower evolution from q-g-g-qbar or
58804C...g-g-g-g event.
58805 ELSEIF(KQ1+KQ2.NE.0) THEN
58806 K(IPA,1)=3
58807 K(IPA+1,1)=3
58808 K(IPA+2,1)=3
58809 K(IPA+3,1)=3
58810 KCS=4
58811 IF(KQ1.EQ.-1) KCS=5
58812 K(IPA,KCS)=MSTU(5)*(IPA+1)
58813 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
58814 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
58815 K(IPA+1,9-KCS)=MSTU(5)*IPA
58816 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
58817 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
58818 K(IPA+3,KCS)=MSTU(5)*IPA
58819 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
58820
58821C...Store partons for parton shower evolution from q-qbar-q-qbar event.
58822 ELSE
58823 K(IPA,1)=3
58824 K(IPA+1,1)=3
58825 K(IPA+2,1)=3
58826 K(IPA+3,1)=3
58827 K(IPA,4)=MSTU(5)*(IPA+1)
58828 K(IPA,5)=K(IPA,4)
58829 K(IPA+1,4)=MSTU(5)*IPA
58830 K(IPA+1,5)=K(IPA+1,4)
58831 K(IPA+2,4)=MSTU(5)*(IPA+3)
58832 K(IPA+2,5)=K(IPA+2,4)
58833 K(IPA+3,4)=MSTU(5)*(IPA+2)
58834 K(IPA+3,5)=K(IPA+3,4)
58835 ENDIF
58836
58837C...Check kinematics.
58838 MKERR=0
58839 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
58840 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
58841 &MKERR=1
58842 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
58843 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
58844 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
58845 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
58846 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
58847 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
58848 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
58849 STHE4=SQRT(1D0-CTHE4**2)
58850 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
58851 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
58852 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
58853 STHE2=SQRT(1D0-CTHE2**2)
58854 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
58855 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
58856 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
58857 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
58858 IF(MKERR.EQ.1) CALL PYERRM(13,
58859 &'(PY4ENT:) unphysical kinematical variable setup')
58860
58861C...Store partons/particles in P vectors.
58862 P(IPA,3)=PA1
58863 P(IPA,4)=SQRT(PA1**2+PM1**2)
58864 P(IPA,5)=PM1
58865 P(IPA+3,1)=PA4*STHE4
58866 P(IPA+3,3)=PA4*CTHE4
58867 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
58868 P(IPA+3,5)=PM4
58869 P(IPA+1,1)=PA2*STHE2*CPHI2
58870 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
58871 P(IPA+1,3)=PA2*CTHE2
58872 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
58873 P(IPA+1,5)=PM2
58874 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
58875 P(IPA+2,2)=-P(IPA+1,2)
58876 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
58877 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
58878 P(IPA+2,5)=PM3
58879
58880C...Set N. Optionally fragment/decay.
58881 N=IPA+3
58882 IF(IP.EQ.0) CALL PYEXEC
58883
58884 RETURN
58885 END
58886
58887C*********************************************************************
58888
58889C...PY2FRM
58890C...An interface from a two-fermion generator to include
58891C...parton showers and hadronization.
58892
58893 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
58894
58895C...Double precision and integer declarations.
58896 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58897 IMPLICIT INTEGER(I-N)
58898 INTEGER PYK,PYCHGE,PYCOMP
58899C...Commonblocks.
58900 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
58901 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58902 SAVE /PYJETS/,/PYDAT1/
58903C...Local arrays.
58904 DIMENSION IJOIN(2),INTAU(2)
58905
58906C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
58907 IF(ICOM.EQ.0) THEN
58908 MSTU(28)=0
58909 CALL PYHEPC(2)
58910 ENDIF
58911
58912C...Loop through entries and pick up all final fermions/antifermions.
58913 I1=0
58914 I2=0
58915 DO 100 I=1,N
58916 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
58917 KFA=IABS(K(I,2))
58918 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
58919 IF(K(I,2).GT.0) THEN
58920 IF(I1.EQ.0) THEN
58921 I1=I
58922 ELSE
58923 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
58924 ENDIF
58925 ELSE
58926 IF(I2.EQ.0) THEN
58927 I2=I
58928 ELSE
58929 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
58930 ENDIF
58931 ENDIF
58932 ENDIF
58933 100 CONTINUE
58934
58935C...Check that event is arranged according to conventions.
58936 IF(I1.EQ.0.OR.I2.EQ.0) THEN
58937 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
58938 ENDIF
58939 IF(I2.LT.I1) THEN
58940 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
58941 ENDIF
58942
58943C...Check whether fermion pair is quarks or leptons.
58944 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
58945 IQL12=1
58946 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
58947 IQL12=2
58948 ELSE
58949 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
58950 ENDIF
58951
58952C...Decide whether to allow or not photon radiation in showers.
58953 MSTJ(41)=2
58954 IF(IRAD.EQ.0) MSTJ(41)=1
58955
58956C...Do colour joining and parton showers.
58957 IP1=I1
58958 IP2=I2
58959 IF(IQL12.EQ.1) THEN
58960 IJOIN(1)=IP1
58961 IJOIN(2)=IP2
58962 CALL PYJOIN(2,IJOIN)
58963 ENDIF
58964 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
58965 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
58966 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
58967 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
58968 ENDIF
58969
58970C...Do fragmentation and decays. Possibly except tau decay.
58971 IF(ITAU.EQ.0) THEN
58972 NTAU=0
58973 DO 110 I=1,N
58974 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
58975 NTAU=NTAU+1
58976 INTAU(NTAU)=I
58977 K(I,1)=11
58978 ENDIF
58979 110 CONTINUE
58980 ENDIF
58981 CALL PYEXEC
58982 IF(ITAU.EQ.0) THEN
58983 DO 120 I=1,NTAU
58984 K(INTAU(I),1)=1
58985 120 CONTINUE
58986 ENDIF
58987
58988C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
58989 IF(ICOM.EQ.0) THEN
58990 MSTU(28)=0
58991 CALL PYHEPC(1)
58992 ENDIF
58993
58994 END
58995
58996C*********************************************************************
58997
58998C...PY4FRM
58999C...An interface from a four-fermion generator to include
59000C...parton showers and hadronization.
59001
59002 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59003
59004C...Double precision and integer declarations.
59005 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59006 IMPLICIT INTEGER(I-N)
59007 INTEGER PYK,PYCHGE,PYCOMP
59008C...Commonblocks.
59009 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59010 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59011 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59012 COMMON/PYINT1/MINT(400),VINT(400)
59013 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59014C...Local arrays.
59015 DIMENSION IJOIN(2),INTAU(4)
59016
59017C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59018 IF(ICOM.EQ.0) THEN
59019 MSTU(28)=0
59020 CALL PYHEPC(2)
59021 ENDIF
59022
59023C...Loop through entries and pick up all final fermions/antifermions.
59024 I1=0
59025 I2=0
59026 I3=0
59027 I4=0
59028 DO 100 I=1,N
59029 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59030 KFA=IABS(K(I,2))
59031 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59032 IF(K(I,2).GT.0) THEN
59033 IF(I1.EQ.0) THEN
59034 I1=I
59035 ELSEIF(I3.EQ.0) THEN
59036 I3=I
59037 ELSE
59038 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59039 ENDIF
59040 ELSE
59041 IF(I2.EQ.0) THEN
59042 I2=I
59043 ELSEIF(I4.EQ.0) THEN
59044 I4=I
59045 ELSE
59046 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59047 ENDIF
59048 ENDIF
59049 ENDIF
59050 100 CONTINUE
59051
59052C...Check that event is arranged according to conventions.
59053 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59054 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59055 ENDIF
59056 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59057 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59058 ENDIF
59059
59060C...Check which fermion pairs are quarks and which leptons.
59061 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59062 IQL12=1
59063 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59064 IQL12=2
59065 ELSE
59066 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59067 ENDIF
59068 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59069 IQL34=1
59070 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59071 IQL34=2
59072 ELSE
59073 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59074 ENDIF
59075
59076C...Decide whether to allow or not photon radiation in showers.
59077 MSTJ(41)=2
59078 IF(IRAD.EQ.0) MSTJ(41)=1
59079
59080C...Decide on dipole pairing.
59081 IP1=I1
59082 IP2=I2
59083 IP3=I3
59084 IP4=I4
59085 IF(IQL12.EQ.IQL34) THEN
59086 R1SQ=A1SQ
59087 R2SQ=A2SQ
59088 DELTA=ATOTSQ-A1SQ-A2SQ
59089 IF(ISTRAT.EQ.1) THEN
59090 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59091 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59092 ELSEIF(ISTRAT.EQ.2) THEN
59093 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59094 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59095 ENDIF
59096 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59097 IP2=I4
59098 IP4=I2
59099 ENDIF
59100 ENDIF
59101
59102C...If colour reconnection then bookkeep W+W- or Z0Z0
59103C...and copy q qbar q qbar consecutively.
59104 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59105 K(N+1,1)=11
59106 K(N+1,3)=IP1
59107 K(N+1,4)=N+3
59108 K(N+1,5)=N+4
59109 K(N+2,1)=11
59110 K(N+2,3)=IP3
59111 K(N+2,4)=N+5
59112 K(N+2,5)=N+6
59113 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59114 K(N+1,2)=23
59115 K(N+2,2)=23
59116 MINT(1)=22
59117 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59118 K(N+1,2)=24
59119 K(N+2,2)=-24
59120 MINT(1)=25
59121 ELSE
59122 K(N+1,2)=-24
59123 K(N+2,2)=24
59124 MINT(1)=25
59125 ENDIF
59126 DO 110 J=1,5
59127 K(N+3,J)=K(IP1,J)
59128 K(N+4,J)=K(IP2,J)
59129 K(N+5,J)=K(IP3,J)
59130 K(N+6,J)=K(IP4,J)
59131 P(N+1,J)=P(IP1,J)+P(IP2,J)
59132 P(N+2,J)=P(IP3,J)+P(IP4,J)
59133 P(N+3,J)=P(IP1,J)
59134 P(N+4,J)=P(IP2,J)
59135 P(N+5,J)=P(IP3,J)
59136 P(N+6,J)=P(IP4,J)
59137 V(N+1,J)=V(IP1,J)
59138 V(N+2,J)=V(IP3,J)
59139 V(N+3,J)=V(IP1,J)
59140 V(N+4,J)=V(IP2,J)
59141 V(N+5,J)=V(IP3,J)
59142 V(N+6,J)=V(IP4,J)
59143 110 CONTINUE
59144 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59145 & P(N+1,3)**2))
59146 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59147 & P(N+2,3)**2))
59148 K(N+3,3)=N+1
59149 K(N+4,3)=N+1
59150 K(N+5,3)=N+2
59151 K(N+6,3)=N+2
59152C...Remove original q qbar q qbar and update counters.
59153 K(IP1,1)=K(IP1,1)+10
59154 K(IP2,1)=K(IP2,1)+10
59155 K(IP3,1)=K(IP3,1)+10
59156 K(IP4,1)=K(IP4,1)+10
59157 IW1=N+1
59158 IW2=N+2
59159 NSD1=N+2
59160 IP1=N+3
59161 IP2=N+4
59162 IP3=N+5
59163 IP4=N+6
59164 N=N+6
59165 ENDIF
59166
59167C...Do colour joinings and parton showers.
59168 IF(IQL12.EQ.1) THEN
59169 IJOIN(1)=IP1
59170 IJOIN(2)=IP2
59171 CALL PYJOIN(2,IJOIN)
59172 ENDIF
59173 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59174 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59175 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59176 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59177 ENDIF
59178 NAFT1=N
59179 IF(IQL34.EQ.1) THEN
59180 IJOIN(1)=IP3
59181 IJOIN(2)=IP4
59182 CALL PYJOIN(2,IJOIN)
59183 ENDIF
59184 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59185 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59186 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59187 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59188 ENDIF
59189
59190C...Optionally do colour reconnection.
59191 MINT(32)=0
59192 MSTI(32)=0
59193 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59194 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
59195 MSTI(32)=MINT(32)
59196 ENDIF
59197
59198C...Do fragmentation and decays. Possibly except tau decay.
59199 IF(ITAU.EQ.0) THEN
59200 NTAU=0
59201 DO 120 I=1,N
59202 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59203 NTAU=NTAU+1
59204 INTAU(NTAU)=I
59205 K(I,1)=11
59206 ENDIF
59207 120 CONTINUE
59208 ENDIF
59209 CALL PYEXEC
59210 IF(ITAU.EQ.0) THEN
59211 DO 130 I=1,NTAU
59212 K(INTAU(I),1)=1
59213 130 CONTINUE
59214 ENDIF
59215
59216C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59217 IF(ICOM.EQ.0) THEN
59218 MSTU(28)=0
59219 CALL PYHEPC(1)
59220 ENDIF
59221
59222 END
59223
59224C*********************************************************************
59225
59226C...PY6FRM
59227C...An interface from a six-fermion generator to include
59228C...parton showers and hadronization.
59229
59230 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
59231
59232C...Double precision and integer declarations.
59233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59234 IMPLICIT INTEGER(I-N)
59235 INTEGER PYK,PYCHGE,PYCOMP
59236C...Commonblocks.
59237 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59238 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59239 SAVE /PYJETS/,/PYDAT1/
59240C...Local arrays.
59241 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
59242
59243C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59244 IF(ICOM.EQ.0) THEN
59245 MSTU(28)=0
59246 CALL PYHEPC(2)
59247 ENDIF
59248
59249C...Loop through entries and pick up all final fermions/antifermions.
59250 I1=0
59251 I2=0
59252 I3=0
59253 I4=0
59254 I5=0
59255 I6=0
59256 DO 100 I=1,N
59257 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59258 KFA=IABS(K(I,2))
59259 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59260 IF(K(I,2).GT.0) THEN
59261 IF(I1.EQ.0) THEN
59262 I1=I
59263 ELSEIF(I3.EQ.0) THEN
59264 I3=I
59265 ELSEIF(I5.EQ.0) THEN
59266 I5=I
59267 ELSE
59268 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
59269 ENDIF
59270 ELSE
59271 IF(I2.EQ.0) THEN
59272 I2=I
59273 ELSEIF(I4.EQ.0) THEN
59274 I4=I
59275 ELSEIF(I6.EQ.0) THEN
59276 I6=I
59277 ELSE
59278 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
59279 ENDIF
59280 ENDIF
59281 ENDIF
59282 100 CONTINUE
59283
59284C...Check that event is arranged according to conventions.
59285 IF(I5.EQ.0.OR.I6.EQ.0) THEN
59286 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
59287 ENDIF
59288 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
59289 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
59290 ENDIF
59291
59292C...Check which fermion pairs are quarks and which leptons.
59293 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59294 IQL12=1
59295 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59296 IQL12=2
59297 ELSE
59298 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
59299 ENDIF
59300 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59301 IQL34=1
59302 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59303 IQL34=2
59304 ELSE
59305 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
59306 ENDIF
59307 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
59308 IQL56=1
59309 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
59310 IQL56=2
59311 ELSE
59312 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
59313 ENDIF
59314
59315C...Decide whether to allow or not photon radiation in showers.
59316 MSTJ(41)=2
59317 IF(IRAD.EQ.0) MSTJ(41)=1
59318
59319C...Allow dipole pairings only among leptons and quarks separately.
59320 P12D=P12
59321 P13D=0D0
59322 IF(IQL34.EQ.IQL56) P13D=P13
59323 P21D=0D0
59324 IF(IQL12.EQ.IQL34) P21D=P21
59325 P23D=0D0
59326 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
59327 P31D=0D0
59328 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
59329 P32D=0D0
59330 IF(IQL12.EQ.IQL56) P32D=P32
59331
59332C...Decide whether t+tbar.
59333 ITOP=0
59334 IF(PYR(0).LT.PTOP) THEN
59335 ITOP=1
59336
59337C...If t+tbar: reconstruct t's.
59338 IT=N+1
59339 ITB=N+2
59340 DO 110 J=1,5
59341 K(IT,J)=0
59342 K(ITB,J)=0
59343 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
59344 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
59345 V(IT,J)=0D0
59346 V(ITB,J)=0D0
59347 110 CONTINUE
59348 K(IT,1)=1
59349 K(ITB,1)=1
59350 K(IT,2)=6
59351 K(ITB,2)=-6
59352 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
59353 & P(IT,3)**2))
59354 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
59355 & P(ITB,3)**2))
59356 N=N+2
59357
59358C...If t+tbar: colour join t's and let them shower.
59359 IJOIN(1)=IT
59360 IJOIN(2)=ITB
59361 CALL PYJOIN(2,IJOIN)
59362 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
59363 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
59364 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
59365
59366C...If t+tbar: pick up the t's after shower.
59367 ITNEW=IT
59368 ITBNEW=ITB
59369 DO 120 I=ITB+1,N
59370 IF(K(I,2).EQ.6) ITNEW=I
59371 IF(K(I,2).EQ.-6) ITBNEW=I
59372 120 CONTINUE
59373
59374C...If t+tbar: loop over two top systems.
59375 DO 200 IT1=1,2
59376 IF(IT1.EQ.1) THEN
59377 ITO=IT
59378 ITN=ITNEW
59379 IBO=I1
59380 IW1=I3
59381 IW2=I4
59382 ELSE
59383 ITO=ITB
59384 ITN=ITBNEW
59385 IBO=I2
59386 IW1=I5
59387 IW2=I6
59388 ENDIF
59389 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
59390 & '(PY6FRM:) not b in t decay')
59391
59392C...If t+tbar: find boost from original to new top frame.
59393 DO 130 J=1,3
59394 BETAO(J)=P(ITO,J)/P(ITO,4)
59395 BETAN(J)=P(ITN,J)/P(ITN,4)
59396 130 CONTINUE
59397
59398C...If t+tbar: boost copy of b by t shower and connect it in colour.
59399 N=N+1
59400 IB=N
59401 K(IB,1)=3
59402 K(IB,2)=K(IBO,2)
59403 K(IB,3)=ITN
59404 DO 140 J=1,5
59405 P(IB,J)=P(IBO,J)
59406 V(IB,J)=0D0
59407 140 CONTINUE
59408 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59409 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59410 K(IB,4)=MSTU(5)*ITN
59411 K(IB,5)=MSTU(5)*ITN
59412 K(ITN,4)=K(ITN,4)+IB
59413 K(ITN,5)=K(ITN,5)+IB
59414 K(ITN,1)=K(ITN,1)+10
59415 K(IBO,1)=K(IBO,1)+10
59416
59417C...If t+tbar: construct W recoiling against b.
59418 N=N+1
59419 IW=N
59420 DO 150 J=1,5
59421 K(IW,J)=0
59422 V(IW,J)=0D0
59423 150 CONTINUE
59424 K(IW,1)=1
59425 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
59426 IF(IABS(KCHW).EQ.3) THEN
59427 K(IW,2)=ISIGN(24,KCHW)
59428 ELSE
59429 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
59430 ENDIF
59431 K(IW,3)=IW1
59432
59433C...If t+tbar: construct W momentum, including boost by t shower.
59434 DO 160 J=1,4
59435 P(IW,J)=P(IW1,J)+P(IW2,J)
59436 160 CONTINUE
59437 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
59438 & P(IW,3)**2))
59439 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59440 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59441
59442C...If t+tbar: boost b and W to top rest frame.
59443 DO 170 J=1,3
59444 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
59445 170 CONTINUE
59446 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59447 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59448
59449C...If t+tbar: let b shower and pick up modified W.
59450 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
59451 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
59452 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
59453 DO 180 I=IW,N
59454 IF(IABS(K(I,2)).EQ.24) IWM=I
59455 180 CONTINUE
59456
59457C...If t+tbar: take copy of W decay products.
59458 DO 190 J=1,5
59459 K(N+1,J)=K(IW1,J)
59460 P(N+1,J)=P(IW1,J)
59461 V(N+1,J)=V(IW1,J)
59462 K(N+2,J)=K(IW2,J)
59463 P(N+2,J)=P(IW2,J)
59464 V(N+2,J)=V(IW2,J)
59465 190 CONTINUE
59466 K(IW1,1)=K(IW1,1)+10
59467 K(IW2,1)=K(IW2,1)+10
59468 K(IWM,1)=K(IWM,1)+10
59469 K(IWM,4)=N+1
59470 K(IWM,5)=N+2
59471 K(N+1,3)=IWM
59472 K(N+2,3)=IWM
59473 IF(IT1.EQ.1) THEN
59474 I3=N+1
59475 I4=N+2
59476 ELSE
59477 I5=N+1
59478 I6=N+2
59479 ENDIF
59480 N=N+2
59481
59482C...If t+tbar: boost W decay products, first by effects of t shower,
59483C...then by those of b shower. b and its shower simple boost back.
59484 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
59485 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
59486 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59487 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
59488 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
59489 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
59490 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
59491 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
59492 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
59493 200 CONTINUE
59494 ENDIF
59495
59496C...Decide on dipole pairing.
59497 IP1=I1
59498 IP3=I3
59499 IP5=I5
59500 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
59501 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
59502 IP2=I2
59503 IP4=I4
59504 IP6=I6
59505 ELSEIF(PRN.LT.P12D+P13D) THEN
59506 IP2=I2
59507 IP4=I6
59508 IP6=I4
59509 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
59510 IP2=I4
59511 IP4=I2
59512 IP6=I6
59513 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
59514 IP2=I4
59515 IP4=I6
59516 IP6=I2
59517 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
59518 IP2=I6
59519 IP4=I2
59520 IP6=I4
59521 ELSE
59522 IP2=I6
59523 IP4=I4
59524 IP6=I2
59525 ENDIF
59526
59527C...Do colour joinings and parton showers
59528C...(except ones already made for t+tbar).
59529 IF(ITOP.EQ.0) THEN
59530 IF(IQL12.EQ.1) THEN
59531 IJOIN(1)=IP1
59532 IJOIN(2)=IP2
59533 CALL PYJOIN(2,IJOIN)
59534 ENDIF
59535 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59536 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59537 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59538 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59539 ENDIF
59540 ENDIF
59541 IF(IQL34.EQ.1) THEN
59542 IJOIN(1)=IP3
59543 IJOIN(2)=IP4
59544 CALL PYJOIN(2,IJOIN)
59545 ENDIF
59546 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59547 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59548 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59549 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59550 ENDIF
59551 IF(IQL56.EQ.1) THEN
59552 IJOIN(1)=IP5
59553 IJOIN(2)=IP6
59554 CALL PYJOIN(2,IJOIN)
59555 ENDIF
59556 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
59557 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
59558 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
59559 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
59560 ENDIF
59561
59562C...Do fragmentation and decays. Possibly except tau decay.
59563 IF(ITAU.EQ.0) THEN
59564 NTAU=0
59565 DO 210 I=1,N
59566 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59567 NTAU=NTAU+1
59568 INTAU(NTAU)=I
59569 K(I,1)=11
59570 ENDIF
59571 210 CONTINUE
59572 ENDIF
59573 CALL PYEXEC
59574 IF(ITAU.EQ.0) THEN
59575 DO 220 I=1,NTAU
59576 K(INTAU(I),1)=1
59577 220 CONTINUE
59578 ENDIF
59579
59580C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59581 IF(ICOM.EQ.0) THEN
59582 MSTU(28)=0
59583 CALL PYHEPC(1)
59584 ENDIF
59585
59586 END
59587
59588C*********************************************************************
59589
59590C...PY4JET
59591C...An interface from a four-parton generator to include
59592C...parton showers and hadronization.
59593
59594 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
59595
59596C...Double precision and integer declarations.
59597 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59598 IMPLICIT INTEGER(I-N)
59599 INTEGER PYK,PYCHGE,PYCOMP
59600C...Commonblocks.
59601 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59602 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59603 SAVE /PYJETS/,/PYDAT1/
59604C...Local arrays.
59605 DIMENSION IJOIN(2),PTOT(4),BETA(3)
59606
59607C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59608 IF(ICOM.EQ.0) THEN
59609 MSTU(28)=0
59610 CALL PYHEPC(2)
59611 ENDIF
59612
59613C...Loop through entries and pick up all final partons.
59614 I1=0
59615 I2=0
59616 I3=0
59617 I4=0
59618 DO 100 I=1,N
59619 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59620 KFA=IABS(K(I,2))
59621 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
59622 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
59623 IF(I1.EQ.0) THEN
59624 I1=I
59625 ELSEIF(I3.EQ.0) THEN
59626 I3=I
59627 ELSE
59628 CALL PYERRM(16,'(PY4JET:) more than two quarks')
59629 ENDIF
59630 ELSEIF(K(I,2).LT.0) THEN
59631 IF(I2.EQ.0) THEN
59632 I2=I
59633 ELSEIF(I4.EQ.0) THEN
59634 I4=I
59635 ELSE
59636 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
59637 ENDIF
59638 ELSE
59639 IF(I3.EQ.0) THEN
59640 I3=I
59641 ELSEIF(I4.EQ.0) THEN
59642 I4=I
59643 ELSE
59644 CALL PYERRM(16,'(PY4JET:) more than two gluons')
59645 ENDIF
59646 ENDIF
59647 ENDIF
59648 100 CONTINUE
59649
59650C...Check that event is arranged according to conventions.
59651 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
59652 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
59653 ENDIF
59654 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59655 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
59656 ENDIF
59657
59658C...Check whether second pair are quarks or gluons.
59659 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59660 IQG34=1
59661 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
59662 IQG34=2
59663 ELSE
59664 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
59665 ENDIF
59666
59667C...Boost partons to their cm frame.
59668 DO 110 J=1,4
59669 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
59670 110 CONTINUE
59671 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
59672 DO 120 J=1,3
59673 BETA(J)=PTOT(J)/PTOT(4)
59674 120 CONTINUE
59675 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59676 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59677 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59678 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
59679 NSAV=N
59680
59681C...Decide and set up shower history for q qbar q' qbar' events.
59682 IF(IQG34.EQ.1) THEN
59683 W1=PY4JTW(0,I1,I3,I4)
59684 W2=PY4JTW(0,I2,I3,I4)
59685 IF(W1.GT.PYR(0)*(W1+W2)) THEN
59686 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59687 ELSE
59688 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59689 ENDIF
59690
59691C...Decide and set up shower history for q qbar g g events.
59692 ELSE
59693 W1=PY4JTW(I1,I3,I2,I4)
59694 W2=PY4JTW(I1,I4,I2,I3)
59695 W3=PY4JTW(0,I3,I1,I4)
59696 W4=PY4JTW(0,I4,I1,I3)
59697 W5=PY4JTW(0,I3,I2,I4)
59698 W6=PY4JTW(0,I4,I2,I3)
59699 W7=PY4JTW(0,I1,I3,I4)
59700 W8=PY4JTW(0,I2,I3,I4)
59701 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
59702 IF(W1.GT.WR) THEN
59703 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
59704 ELSEIF(W1+W2.GT.WR) THEN
59705 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
59706 ELSEIF(W1+W2+W3.GT.WR) THEN
59707 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
59708 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
59709 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
59710 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
59711 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
59712 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
59713 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
59714 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
59715 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
59716 ELSE
59717 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
59718 ENDIF
59719 ENDIF
59720
59721C...Boost back original partons and mark them as deleted.
59722 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
59723 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
59724 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
59725 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
59726 K(I1,1)=K(I1,1)+10
59727 K(I2,1)=K(I2,1)+10
59728 K(I3,1)=K(I3,1)+10
59729 K(I4,1)=K(I4,1)+10
59730
59731C...Rotate shower initiating partons to be along z axis.
59732 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
59733 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
59734 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
59735 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
59736
59737C...Set up copy of shower initiating partons as on mass shell.
59738 DO 140 I=N+1,N+2
59739 DO 130 J=1,5
59740 K(I,J)=0
59741 P(I,J)=0D0
59742 V(I,J)=V(I1,J)
59743 130 CONTINUE
59744 K(I,1)=1
59745 K(I,2)=K(I-6,2)
59746 140 CONTINUE
59747 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
59748 K(N+1,3)=I1
59749 P(N+1,5)=P(I1,5)
59750 K(N+2,3)=I2
59751 P(N+2,5)=P(I2,5)
59752 ELSE
59753 K(N+1,3)=I2
59754 P(N+1,5)=P(I2,5)
59755 K(N+2,3)=I1
59756 P(N+2,5)=P(I1,5)
59757 ENDIF
59758 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
59759 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
59760 P(N+1,3)=PABS
59761 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
59762 P(N+2,3)=-PABS
59763 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
59764 N=N+2
59765
59766C...Decide whether to allow or not photon radiation in showers.
59767C...Connect up colours.
59768 MSTJ(41)=2
59769 IF(IRAD.EQ.0) MSTJ(41)=1
59770 IJOIN(1)=N-1
59771 IJOIN(2)=N
59772 CALL PYJOIN(2,IJOIN)
59773
59774C...Decide on maximum virtuality and do parton shower.
59775 IF(PMAX.LT.PARJ(82)) THEN
59776 PQMAX=QMAX
59777 ELSE
59778 PQMAX=PMAX
59779 ENDIF
59780 CALL PYSHOW(NSAV+1,-100,PQMAX)
59781
59782C...Rotate and boost back system.
59783 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
59784
59785C...Do fragmentation and decays.
59786 CALL PYEXEC
59787
59788C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59789 IF(ICOM.EQ.0) THEN
59790 MSTU(28)=0
59791 CALL PYHEPC(1)
59792 ENDIF
59793
59794 RETURN
59795 END
59796
59797C*********************************************************************
59798
59799C...PY4JTW
59800C...Auxiliary to PY4JET, to evaluate weight of configuration.
59801
59802 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
59803
59804C...Double precision and integer declarations.
59805 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59806 IMPLICIT INTEGER(I-N)
59807 INTEGER PYK,PYCHGE,PYCOMP
59808C...Commonblocks.
59809 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59810 SAVE /PYJETS/
59811
59812C...First case: when both original partons radiate.
59813C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
59814 IF(IA1.NE.0) THEN
59815 DO 100 J=1,4
59816 P(N+1,J)=P(IA1,J)+P(IA2,J)
59817 P(N+2,J)=P(IA3,J)+P(IA4,J)
59818 100 CONTINUE
59819 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59820 & P(N+1,3)**2))
59821 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59822 & P(N+2,3)**2))
59823 Z1=P(IA1,4)/P(N+1,4)
59824 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
59825 Z2=P(IA3,4)/P(N+2,4)
59826 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
59827
59828C...Second case: when one original parton radiates to three.
59829C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
59830 ELSE
59831 DO 110 J=1,4
59832 P(N+2,J)=P(IA3,J)+P(IA4,J)
59833 P(N+1,J)=P(N+2,J)+P(IA2,J)
59834 110 CONTINUE
59835 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59836 & P(N+1,3)**2))
59837 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59838 & P(N+2,3)**2))
59839 IF(K(IA2,2).EQ.21) THEN
59840 Z1=P(N+2,4)/P(N+1,4)
59841 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59842 & P(IA3,5)**2)
59843 ELSE
59844 Z1=P(IA2,4)/P(N+1,4)
59845 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
59846 & P(IA2,5)**2)
59847 ENDIF
59848 Z2=P(IA3,4)/P(N+2,4)
59849 IF(K(IA2,2).EQ.21) THEN
59850 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
59851 & P(IA3,5)**2)
59852 ELSEIF(K(IA3,2).EQ.21) THEN
59853 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
59854 ELSE
59855 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
59856 ENDIF
59857 ENDIF
59858
59859C...Total weight.
59860 PY4JTW=WT1*WT2
59861
59862 RETURN
59863 END
59864
59865C*********************************************************************
59866
59867C...PY4JTS
59868C...Auxiliary to PY4JET, to set up chosen configuration.
59869
59870 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
59871
59872C...Double precision and integer declarations.
59873 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59874 IMPLICIT INTEGER(I-N)
59875 INTEGER PYK,PYCHGE,PYCOMP
59876C...Commonblocks.
59877 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59878 SAVE /PYJETS/
59879
59880C...Reset info.
59881 DO 110 I=N+1,N+6
59882 DO 100 J=1,5
59883 K(I,J)=0
59884 V(I,J)=V(IA2,J)
59885 100 CONTINUE
59886 K(I,1)=16
59887 110 CONTINUE
59888
59889C...First case: when both original partons radiate.
59890C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
59891 IF(IA1.NE.0) THEN
59892
59893C...Set up flavour and history pointers for new partons.
59894 K(N+1,2)=K(IA1,2)
59895 K(N+2,2)=K(IA3,2)
59896 K(N+3,2)=K(IA1,2)
59897 K(N+4,2)=K(IA2,2)
59898 K(N+5,2)=K(IA3,2)
59899 K(N+6,2)=K(IA4,2)
59900 K(N+1,3)=IA1
59901 K(N+1,4)=N+3
59902 K(N+1,5)=N+4
59903 K(N+2,3)=IA3
59904 K(N+2,4)=N+5
59905 K(N+2,5)=N+6
59906 K(N+3,3)=N+1
59907 K(N+4,3)=N+1
59908 K(N+5,3)=N+2
59909 K(N+6,3)=N+2
59910
59911C...Set up momenta for new partons.
59912 DO 120 J=1,5
59913 P(N+1,J)=P(IA1,J)+P(IA2,J)
59914 P(N+2,J)=P(IA3,J)+P(IA4,J)
59915 P(N+3,J)=P(IA1,J)
59916 P(N+4,J)=P(IA2,J)
59917 P(N+5,J)=P(IA3,J)
59918 P(N+6,J)=P(IA4,J)
59919 120 CONTINUE
59920 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59921 & P(N+1,3)**2))
59922 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59923 & P(N+2,3)**2))
59924 QMAX=MIN(P(N+1,5),P(N+2,5))
59925
59926C...Second case: q radiates twice.
59927C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
59928C...IA5=N+2 does not radiate.
59929 ELSEIF(K(IA2,2).EQ.21) THEN
59930
59931C...Set up flavour and history pointers for new partons.
59932 K(N+1,2)=K(IA3,2)
59933 K(N+2,2)=K(IA5,2)
59934 K(N+3,2)=K(IA3,2)
59935 K(N+4,2)=K(IA2,2)
59936 K(N+5,2)=K(IA3,2)
59937 K(N+6,2)=K(IA4,2)
59938 K(N+1,3)=IA3
59939 K(N+1,4)=N+3
59940 K(N+1,5)=N+4
59941 K(N+2,3)=IA5
59942 K(N+3,3)=N+1
59943 K(N+3,4)=N+5
59944 K(N+3,5)=N+6
59945 K(N+4,3)=N+1
59946 K(N+5,3)=N+3
59947 K(N+6,3)=N+3
59948
59949C...Set up momenta for new partons.
59950 DO 130 J=1,5
59951 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59952 P(N+2,J)=P(IA5,J)
59953 P(N+3,J)=P(IA3,J)+P(IA4,J)
59954 P(N+4,J)=P(IA2,J)
59955 P(N+5,J)=P(IA3,J)
59956 P(N+6,J)=P(IA4,J)
59957 130 CONTINUE
59958 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59959 & P(N+1,3)**2))
59960 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
59961 & P(N+3,3)**2))
59962 QMAX=P(N+3,5)
59963
59964C...Third case: q radiates g, g branches.
59965C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
59966C...IA5=N+2 does not radiate.
59967 ELSE
59968
59969C...Set up flavour and history pointers for new partons.
59970 K(N+1,2)=K(IA2,2)
59971 K(N+2,2)=K(IA5,2)
59972 K(N+3,2)=K(IA2,2)
59973 K(N+4,2)=21
59974 K(N+5,2)=K(IA3,2)
59975 K(N+6,2)=K(IA4,2)
59976 K(N+1,3)=IA2
59977 K(N+1,4)=N+3
59978 K(N+1,5)=N+4
59979 K(N+2,3)=IA5
59980 K(N+3,3)=N+1
59981 K(N+4,3)=N+1
59982 K(N+4,4)=N+5
59983 K(N+4,5)=N+6
59984 K(N+5,3)=N+4
59985 K(N+6,3)=N+4
59986
59987C...Set up momenta for new partons.
59988 DO 140 J=1,5
59989 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
59990 P(N+2,J)=P(IA5,J)
59991 P(N+3,J)=P(IA2,J)
59992 P(N+4,J)=P(IA3,J)+P(IA4,J)
59993 P(N+5,J)=P(IA3,J)
59994 P(N+6,J)=P(IA4,J)
59995 140 CONTINUE
59996 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59997 & P(N+1,3)**2))
59998 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
59999 & P(N+4,3)**2))
60000 QMAX=P(N+4,5)
60001
60002 ENDIF
60003 N=N+6
60004
60005 RETURN
60006 END
60007
60008C*********************************************************************
60009
60010C...PYJOIN
60011C...Connects a sequence of partons with colour flow indices,
60012C...as required for subsequent shower evolution (or other operations).
60013
60014 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60015
60016C...Double precision and integer declarations.
60017 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60018 IMPLICIT INTEGER(I-N)
60019 INTEGER PYK,PYCHGE,PYCOMP
60020C...Commonblocks.
60021 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60024 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60025C...Local array.
60026 DIMENSION IJOIN(*)
60027
60028C...Check that partons are of right types to be connected.
60029 IF(NJOIN.LT.2) GOTO 120
60030 KQSUM=0
60031 DO 100 IJN=1,NJOIN
60032 I=IJOIN(IJN)
60033 IF(I.LE.0.OR.I.GT.N) GOTO 120
60034 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60035 KC=PYCOMP(K(I,2))
60036 IF(KC.EQ.0) GOTO 120
60037 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60038 IF(KQ.EQ.0) GOTO 120
60039 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60040 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60041 IF(IJN.EQ.1) KQS=KQ
60042 100 CONTINUE
60043 IF(KQSUM.NE.0) GOTO 120
60044
60045C...Connect the partons sequentially (closing for gluon loop).
60046 KCS=(9-KQS)/2
60047 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60048 DO 110 IJN=1,NJOIN
60049 I=IJOIN(IJN)
60050 K(I,1)=3
60051 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60052 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60053 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60054 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60055 K(I,KCS)=MSTU(5)*IN
60056 K(I,9-KCS)=MSTU(5)*IP
60057 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60058 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60059 110 CONTINUE
60060
60061C...Error exit: no action taken.
60062 RETURN
60063 120 CALL PYERRM(12,
60064 &'(PYJOIN:) given entries can not be joined by one string')
60065
60066 RETURN
60067 END
60068
60069C*********************************************************************
60070
60071C...PYGIVE
60072C...Sets values of commonblock variables.
60073
60074 SUBROUTINE PYGIVE(CHIN)
60075
60076C...Double precision and integer declarations.
60077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60078 IMPLICIT INTEGER(I-N)
60079 INTEGER PYK,PYCHGE,PYCOMP
60080C...Commonblocks.
60081 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60082 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60083 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60084 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60085 COMMON/PYDAT4/CHAF(500,2)
60086 CHARACTER CHAF*16
60087 COMMON/PYDATR/MRPY(6),RRPY(100)
60088 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60089 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60090 COMMON/PYINT1/MINT(400),VINT(400)
60091 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60092 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60093 COMMON/PYINT4/MWID(500),WIDS(500,5)
60094 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60095 COMMON/PYINT6/PROC(0:500)
60096 CHARACTER PROC*28
60097 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60098 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60099 &XPDIR(-6:6)
60100 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60101 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60102 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60103 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60104 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60105 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60106 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60107C...Local arrays and character variables.
60108 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60109 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60110 &CHINR*16,CHDIG*10
60111 DIMENSION MSVAR(56,8)
60112
60113C...For each variable to be translated give: name,
60114C...integer/real/character, no. of indices, lower&upper index bounds.
60115 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60116 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60117 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60118 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60119 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60120 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60121 &'ITCM','RTCM','IUED','RUED'/
60122 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60123 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60124 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60125 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60126 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60127 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60128 &1,1,1,6,4*0, 2,1,1,100,4*0,
60129 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60130 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60131 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60132 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60133 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60134 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60135 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60136 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60137 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60138 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60139 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60140 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60141 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60142
60143C...Length of character variable. Subdivide it into instructions.
60144 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60145 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60146 CHBIT=CHIN//' '
60147 LBIT=101
60148 100 LBIT=LBIT-1
60149 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60150 LTOT=0
60151 DO 110 LCOM=1,LBIT
60152 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60153 LTOT=LTOT+1
60154 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60155 110 CONTINUE
60156 LLOW=0
60157 120 LHIG=LLOW+1
60158 130 LHIG=LHIG+1
60159 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60160 LBIT=LHIG-LLOW-1
60161 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60162
60163C...Send off decay-mode on/off commands to PYONOF.
60164 IONOF=0
60165 DO 135 LDIG=1,10
60166 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60167 135 CONTINUE
60168 IF(IONOF.EQ.1) THEN
60169 CALL PYONOF(CHIN)
60170 RETURN
60171 ENDIF
60172
60173C...Peel off any text following exclamation mark.
60174 LHIG2=LBIT
60175 DO 140 LLOW2=LHIG2,1,-1
60176 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60177 140 CONTINUE
60178 IF(LBIT.EQ.0) RETURN
60179
60180C...Identify commonblock variable.
60181 LNAM=1
60182 150 LNAM=LNAM+1
60183 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60184 &LNAM.LE.6) GOTO 150
60185 CHNAM=CHBIT(1:LNAM-1)//' '
60186 DO 170 LCOM=1,LNAM-1
60187 DO 160 LALP=1,26
60188 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60189 & CHALP(2)(LALP:LALP)
60190 160 CONTINUE
60191 170 CONTINUE
60192 IVAR=0
60193 DO 180 IV=1,56
60194 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
60195 180 CONTINUE
60196 IF(IVAR.EQ.0) THEN
60197 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
60198 LLOW=LHIG
60199 IF(LLOW.LT.LTOT) GOTO 120
60200 RETURN
60201 ENDIF
60202
60203C...Identify any indices.
60204 I1=0
60205 I2=0
60206 I3=0
60207 NINDX=0
60208 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
60209 LIND=LNAM
60210 190 LIND=LIND+1
60211 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
60212 CHIND=' '
60213 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
60214 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
60215 & IVAR.EQ.37)) THEN
60216 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
60217 READ(CHIND,'(I8)') KF
60218 I1=PYCOMP(KF)
60219 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
60220 & 'c') THEN
60221 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
60222 & CHNAM)
60223 LLOW=LHIG
60224 IF(LLOW.LT.LTOT) GOTO 120
60225 RETURN
60226 ELSE
60227 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60228 READ(CHIND,'(I8)') I1
60229 ENDIF
60230 LNAM=LIND
60231 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60232 NINDX=1
60233 ENDIF
60234 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60235 LIND=LNAM
60236 200 LIND=LIND+1
60237 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
60238 CHIND=' '
60239 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60240 READ(CHIND,'(I8)') I2
60241 LNAM=LIND
60242 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
60243 NINDX=2
60244 ENDIF
60245 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
60246 LIND=LNAM
60247 210 LIND=LIND+1
60248 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
60249 CHIND=' '
60250 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
60251 READ(CHIND,'(I8)') I3
60252 LNAM=LIND+1
60253 NINDX=3
60254 ENDIF
60255
60256C...Check that indices allowed.
60257 IERR=0
60258 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
60259 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
60260 &IERR=2
60261 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
60262 &IERR=3
60263 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
60264 &IERR=4
60265 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
60266 IF(IERR.GE.1) THEN
60267 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
60268 & CHBIT(1:LNAM-1))
60269 LLOW=LHIG
60270 IF(LLOW.LT.LTOT) GOTO 120
60271 RETURN
60272 ENDIF
60273
60274C...Save old value of variable.
60275 IF(IVAR.EQ.1) THEN
60276 IOLD=N
60277 ELSEIF(IVAR.EQ.2) THEN
60278 IOLD=K(I1,I2)
60279 ELSEIF(IVAR.EQ.3) THEN
60280 ROLD=P(I1,I2)
60281 ELSEIF(IVAR.EQ.4) THEN
60282 ROLD=V(I1,I2)
60283 ELSEIF(IVAR.EQ.5) THEN
60284 IOLD=MSTU(I1)
60285 ELSEIF(IVAR.EQ.6) THEN
60286 ROLD=PARU(I1)
60287 ELSEIF(IVAR.EQ.7) THEN
60288 IOLD=MSTJ(I1)
60289 ELSEIF(IVAR.EQ.8) THEN
60290 ROLD=PARJ(I1)
60291 ELSEIF(IVAR.EQ.9) THEN
60292 IOLD=KCHG(I1,I2)
60293 ELSEIF(IVAR.EQ.10) THEN
60294 ROLD=PMAS(I1,I2)
60295 ELSEIF(IVAR.EQ.11) THEN
60296 ROLD=PARF(I1)
60297 ELSEIF(IVAR.EQ.12) THEN
60298 ROLD=VCKM(I1,I2)
60299 ELSEIF(IVAR.EQ.13) THEN
60300 IOLD=MDCY(I1,I2)
60301 ELSEIF(IVAR.EQ.14) THEN
60302 IOLD=MDME(I1,I2)
60303 ELSEIF(IVAR.EQ.15) THEN
60304 ROLD=BRAT(I1)
60305 ELSEIF(IVAR.EQ.16) THEN
60306 IOLD=KFDP(I1,I2)
60307 ELSEIF(IVAR.EQ.17) THEN
60308 CHOLD=CHAF(I1,I2)(1:8)
60309 ELSEIF(IVAR.EQ.18) THEN
60310 IOLD=MRPY(I1)
60311 ELSEIF(IVAR.EQ.19) THEN
60312 ROLD=RRPY(I1)
60313 ELSEIF(IVAR.EQ.20) THEN
60314 IOLD=MSEL
60315 ELSEIF(IVAR.EQ.21) THEN
60316 IOLD=MSUB(I1)
60317 ELSEIF(IVAR.EQ.22) THEN
60318 IOLD=KFIN(I1,I2)
60319 ELSEIF(IVAR.EQ.23) THEN
60320 ROLD=CKIN(I1)
60321 ELSEIF(IVAR.EQ.24) THEN
60322 IOLD=MSTP(I1)
60323 ELSEIF(IVAR.EQ.25) THEN
60324 ROLD=PARP(I1)
60325 ELSEIF(IVAR.EQ.26) THEN
60326 IOLD=MSTI(I1)
60327 ELSEIF(IVAR.EQ.27) THEN
60328 ROLD=PARI(I1)
60329 ELSEIF(IVAR.EQ.28) THEN
60330 IOLD=MINT(I1)
60331 ELSEIF(IVAR.EQ.29) THEN
60332 ROLD=VINT(I1)
60333 ELSEIF(IVAR.EQ.30) THEN
60334 IOLD=ISET(I1)
60335 ELSEIF(IVAR.EQ.31) THEN
60336 IOLD=KFPR(I1,I2)
60337 ELSEIF(IVAR.EQ.32) THEN
60338 ROLD=COEF(I1,I2)
60339 ELSEIF(IVAR.EQ.33) THEN
60340 IOLD=ICOL(I1,I2,I3)
60341 ELSEIF(IVAR.EQ.34) THEN
60342 ROLD=XSFX(I1,I2)
60343 ELSEIF(IVAR.EQ.35) THEN
60344 IOLD=ISIG(I1,I2)
60345 ELSEIF(IVAR.EQ.36) THEN
60346 ROLD=SIGH(I1)
60347 ELSEIF(IVAR.EQ.37) THEN
60348 IOLD=MWID(I1)
60349 ELSEIF(IVAR.EQ.38) THEN
60350 ROLD=WIDS(I1,I2)
60351 ELSEIF(IVAR.EQ.39) THEN
60352 IOLD=NGEN(I1,I2)
60353 ELSEIF(IVAR.EQ.40) THEN
60354 ROLD=XSEC(I1,I2)
60355 ELSEIF(IVAR.EQ.41) THEN
60356 CHOLD2=PROC(I1)
60357 ELSEIF(IVAR.EQ.42) THEN
60358 ROLD=SIGT(I1,I2,I3)
60359 ELSEIF(IVAR.EQ.43) THEN
60360 ROLD=XPVMD(I1)
60361 ELSEIF(IVAR.EQ.44) THEN
60362 ROLD=XPANL(I1)
60363 ELSEIF(IVAR.EQ.45) THEN
60364 ROLD=XPANH(I1)
60365 ELSEIF(IVAR.EQ.46) THEN
60366 ROLD=XPBEH(I1)
60367 ELSEIF(IVAR.EQ.47) THEN
60368 ROLD=XPDIR(I1)
60369 ELSEIF(IVAR.EQ.48) THEN
60370 IOLD=IMSS(I1)
60371 ELSEIF(IVAR.EQ.49) THEN
60372 ROLD=RMSS(I1)
60373 ELSEIF(IVAR.EQ.50) THEN
60374 ROLD=RVLAM(I1,I2,I3)
60375 ELSEIF(IVAR.EQ.51) THEN
60376 ROLD=RVLAMP(I1,I2,I3)
60377 ELSEIF(IVAR.EQ.52) THEN
60378 ROLD=RVLAMB(I1,I2,I3)
60379 ELSEIF(IVAR.EQ.53) THEN
60380 IOLD=ITCM(I1)
60381 ELSEIF(IVAR.EQ.54) THEN
60382 ROLD=RTCM(I1)
60383 ELSEIF(IVAR.EQ.55) THEN
60384 IOLD=IUED(I1)
60385 ELSEIF(IVAR.EQ.56) THEN
60386 ROLD=RUED(I1)
60387 ENDIF
60388
60389C...Print current value of variable. Loop back.
60390 IF(LNAM.GE.LBIT) THEN
60391 CHBIT(LNAM:14)=' '
60392 CHBIT(15:60)=' has the value '
60393 IF(MSVAR(IVAR,1).EQ.1) THEN
60394 WRITE(CHBIT(51:60),'(I10)') IOLD
60395 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60396 WRITE(CHBIT(47:60),'(F14.5)') ROLD
60397 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60398 CHBIT(53:60)=CHOLD
60399 ELSE
60400 CHBIT(33:60)=CHOLD
60401 ENDIF
60402 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60403 LLOW=LHIG
60404 IF(LLOW.LT.LTOT) GOTO 120
60405 RETURN
60406 ENDIF
60407
60408C...Read in new variable value.
60409 IF(MSVAR(IVAR,1).EQ.1) THEN
60410 CHINI=' '
60411 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
60412 READ(CHINI,'(I10)') INEW
60413 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60414 CHINR=' '
60415 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
60416 READ(CHINR,*) RNEW
60417 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60418 CHNEW=CHBIT(LNAM+1:LBIT)//' '
60419 ELSE
60420 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
60421 ENDIF
60422
60423C...Store new variable value.
60424 IF(IVAR.EQ.1) THEN
60425 N=INEW
60426 ELSEIF(IVAR.EQ.2) THEN
60427 K(I1,I2)=INEW
60428 ELSEIF(IVAR.EQ.3) THEN
60429 P(I1,I2)=RNEW
60430 ELSEIF(IVAR.EQ.4) THEN
60431 V(I1,I2)=RNEW
60432 ELSEIF(IVAR.EQ.5) THEN
60433 MSTU(I1)=INEW
60434 ELSEIF(IVAR.EQ.6) THEN
60435 PARU(I1)=RNEW
60436 ELSEIF(IVAR.EQ.7) THEN
60437 MSTJ(I1)=INEW
60438 ELSEIF(IVAR.EQ.8) THEN
60439 PARJ(I1)=RNEW
60440 ELSEIF(IVAR.EQ.9) THEN
60441 KCHG(I1,I2)=INEW
60442 ELSEIF(IVAR.EQ.10) THEN
60443 PMAS(I1,I2)=RNEW
60444 ELSEIF(IVAR.EQ.11) THEN
60445 PARF(I1)=RNEW
60446 ELSEIF(IVAR.EQ.12) THEN
60447 VCKM(I1,I2)=RNEW
60448 ELSEIF(IVAR.EQ.13) THEN
60449 MDCY(I1,I2)=INEW
60450 ELSEIF(IVAR.EQ.14) THEN
60451 MDME(I1,I2)=INEW
60452 ELSEIF(IVAR.EQ.15) THEN
60453 BRAT(I1)=RNEW
60454 ELSEIF(IVAR.EQ.16) THEN
60455 KFDP(I1,I2)=INEW
60456 ELSEIF(IVAR.EQ.17) THEN
60457 CHAF(I1,I2)=CHNEW
60458 ELSEIF(IVAR.EQ.18) THEN
60459 MRPY(I1)=INEW
60460 ELSEIF(IVAR.EQ.19) THEN
60461 RRPY(I1)=RNEW
60462 ELSEIF(IVAR.EQ.20) THEN
60463 MSEL=INEW
60464 ELSEIF(IVAR.EQ.21) THEN
60465 MSUB(I1)=INEW
60466 ELSEIF(IVAR.EQ.22) THEN
60467 KFIN(I1,I2)=INEW
60468 ELSEIF(IVAR.EQ.23) THEN
60469 CKIN(I1)=RNEW
60470 ELSEIF(IVAR.EQ.24) THEN
60471 MSTP(I1)=INEW
60472 ELSEIF(IVAR.EQ.25) THEN
60473 PARP(I1)=RNEW
60474 ELSEIF(IVAR.EQ.26) THEN
60475 MSTI(I1)=INEW
60476 ELSEIF(IVAR.EQ.27) THEN
60477 PARI(I1)=RNEW
60478 ELSEIF(IVAR.EQ.28) THEN
60479 MINT(I1)=INEW
60480 ELSEIF(IVAR.EQ.29) THEN
60481 VINT(I1)=RNEW
60482 ELSEIF(IVAR.EQ.30) THEN
60483 ISET(I1)=INEW
60484 ELSEIF(IVAR.EQ.31) THEN
60485 KFPR(I1,I2)=INEW
60486 ELSEIF(IVAR.EQ.32) THEN
60487 COEF(I1,I2)=RNEW
60488 ELSEIF(IVAR.EQ.33) THEN
60489 ICOL(I1,I2,I3)=INEW
60490 ELSEIF(IVAR.EQ.34) THEN
60491 XSFX(I1,I2)=RNEW
60492 ELSEIF(IVAR.EQ.35) THEN
60493 ISIG(I1,I2)=INEW
60494 ELSEIF(IVAR.EQ.36) THEN
60495 SIGH(I1)=RNEW
60496 ELSEIF(IVAR.EQ.37) THEN
60497 MWID(I1)=INEW
60498 ELSEIF(IVAR.EQ.38) THEN
60499 WIDS(I1,I2)=RNEW
60500 ELSEIF(IVAR.EQ.39) THEN
60501 NGEN(I1,I2)=INEW
60502 ELSEIF(IVAR.EQ.40) THEN
60503 XSEC(I1,I2)=RNEW
60504 ELSEIF(IVAR.EQ.41) THEN
60505 PROC(I1)=CHNEW2
60506 ELSEIF(IVAR.EQ.42) THEN
60507 SIGT(I1,I2,I3)=RNEW
60508 ELSEIF(IVAR.EQ.43) THEN
60509 XPVMD(I1)=RNEW
60510 ELSEIF(IVAR.EQ.44) THEN
60511 XPANL(I1)=RNEW
60512 ELSEIF(IVAR.EQ.45) THEN
60513 XPANH(I1)=RNEW
60514 ELSEIF(IVAR.EQ.46) THEN
60515 XPBEH(I1)=RNEW
60516 ELSEIF(IVAR.EQ.47) THEN
60517 XPDIR(I1)=RNEW
60518 ELSEIF(IVAR.EQ.48) THEN
60519 IMSS(I1)=INEW
60520 ELSEIF(IVAR.EQ.49) THEN
60521 RMSS(I1)=RNEW
60522 ELSEIF(IVAR.EQ.50) THEN
60523 RVLAM(I1,I2,I3)=RNEW
60524 ELSEIF(IVAR.EQ.51) THEN
60525 RVLAMP(I1,I2,I3)=RNEW
60526 ELSEIF(IVAR.EQ.52) THEN
60527 RVLAMB(I1,I2,I3)=RNEW
60528 ELSEIF(IVAR.EQ.53) THEN
60529 ITCM(I1)=INEW
60530 ELSEIF(IVAR.EQ.54) THEN
60531 RTCM(I1)=RNEW
60532 ELSEIF(IVAR.EQ.55) THEN
60533 IUED(I1)=INEW
60534 ELSEIF(IVAR.EQ.56) THEN
60535 RUED(I1)=RNEW
60536 ENDIF
60537
60538C...Write old and new value. Loop back.
60539 CHBIT(LNAM:14)=' '
60540 CHBIT(15:60)=' changed from to '
60541 IF(MSVAR(IVAR,1).EQ.1) THEN
60542 WRITE(CHBIT(33:42),'(I10)') IOLD
60543 WRITE(CHBIT(51:60),'(I10)') INEW
60544 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60545 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
60546 WRITE(CHBIT(29:42),'(F14.5)') ROLD
60547 WRITE(CHBIT(47:60),'(F14.5)') RNEW
60548 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60549 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
60550 CHBIT(35:42)=CHOLD
60551 CHBIT(53:60)=CHNEW
60552 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
60553 ELSE
60554 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
60555 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
60556 ENDIF
60557 LLOW=LHIG
60558 IF(LLOW.LT.LTOT) GOTO 120
60559
60560C...Format statement for output on unit MSTU(11) (by default 6).
60561 5000 FORMAT(5X,A60)
60562 5100 FORMAT(5X,A88)
60563
60564 RETURN
60565 END
60566
60567C*********************************************************************
60568
60569C...PYONOF
60570C...Switches on and off decay channel by search for match.
60571
60572 SUBROUTINE PYONOF(CHIN)
60573
60574C...Double precision and integer declarations.
60575 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60576 IMPLICIT INTEGER(I-N)
60577 INTEGER PYK,PYCHGE,PYCOMP
60578C...Commonblocks.
60579 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60580 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60581 SAVE /PYDAT1/,/PYDAT3/
60582C...Local arrays and character variables.
60583 INTEGER KFCMP(10),KFTMP(10)
60584 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
60585 &CHALP(2)*26
60586 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60587 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
60588
60589C...Determine length of character variable.
60590 CHTMP=CHIN//' '
60591 LBEG=0
60592 100 LBEG=LBEG+1
60593 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
60594 LEND=LBEG-1
60595 105 LEND=LEND+1
60596 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
60597 110 LEND=LEND-1
60598 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
60599 LEN=1+LEND-LBEG
60600 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
60601
60602C...Find colon separator and particle code.
60603 LCOLON=0
60604 120 LCOLON=LCOLON+1
60605 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
60606 CHCODE=' '
60607 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
60608 READ(CHCODE,'(I8)',ERR=300) KF
60609 KC=PYCOMP(KF)
60610
60611C...Done if unknown code or no decay channels.
60612 IF(KC.EQ.0) THEN
60613 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
60614 RETURN
60615 ENDIF
60616 IDCBEG=MDCY(KC,2)
60617 IDCLEN=MDCY(KC,3)
60618 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
60619 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
60620 RETURN
60621 ENDIF
60622
60623C...Find command name up to blank or equal sign.
60624 LSEP=LCOLON
60625 130 LSEP=LSEP+1
60626 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
60627 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
60628 CHMODE=' '
60629 LMODE=LSEP-LCOLON-1
60630 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
60631
60632C...Convert to uppercase.
60633 DO 150 LCOM=1,LMODE
60634 DO 140 LALP=1,26
60635 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
60636 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
60637 140 CONTINUE
60638 150 CONTINUE
60639
60640C...Identify command. Failed if not identified.
60641 MODE=0
60642 IF(CHMODE.EQ.'ALLOFF') MODE=1
60643 IF(CHMODE.EQ.'ALLON') MODE=2
60644 IF(CHMODE.EQ.'OFFIFANY') MODE=3
60645 IF(CHMODE.EQ.'ONIFANY') MODE=4
60646 IF(CHMODE.EQ.'OFFIFALL') MODE=5
60647 IF(CHMODE.EQ.'ONIFALL') MODE=6
60648 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
60649 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
60650 IF(MODE.EQ.0) THEN
60651 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
60652 RETURN
60653 ENDIF
60654
60655C...Simple cases when all on or all off.
60656 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
60657 WRITE(MSTU(11),1000) KF,CHMODE
60658 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
60659 IF(MDME(IDC,1).LT.0) GOTO 160
60660 MDME(IDC,1)=MODE-1
60661 160 CONTINUE
60662 RETURN
60663 ENDIF
60664
60665C...Identify matching list.
60666 NCMP=0
60667 LBEG=LSEP
60668 170 LBEG=LBEG+1
60669 IF(LBEG.GT.LEN) GOTO 190
60670 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
60671 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
60672 LEND=LBEG-1
60673 180 LEND=LEND+1
60674 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
60675 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
60676 IF(LEND.LT.LEN) LEND=LEND-1
60677 CHCODE=' '
60678 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
60679 READ(CHCODE,'(I8)',ERR=300) KFREAD
60680 NCMP=NCMP+1
60681 KFCMP(NCMP)=IABS(KFREAD)
60682 LBEG=LEND
60683 IF(NCMP.LT.10) GOTO 170
60684 190 CONTINUE
60685 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
60686
60687C...Only one matching required.
60688 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
60689 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
60690 IF(MDME(IDC,1).LT.0) GOTO 220
60691 DO 210 IKF=1,5
60692 KFNOW=IABS(KFDP(IDC,IKF))
60693 IF(KFNOW.EQ.0) GOTO 210
60694 DO 200 ICMP=1,NCMP
60695 IF(KFCMP(ICMP).EQ.KFNOW) THEN
60696 MDME(IDC,1)=MODE-3
60697 GOTO 220
60698 ENDIF
60699 200 CONTINUE
60700 210 CONTINUE
60701 220 CONTINUE
60702 RETURN
60703 ENDIF
60704
60705C...Multiple matchings required.
60706 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
60707 IF(MDME(IDC,1).LT.0) GOTO 260
60708 NTMP=NCMP
60709 DO 230 ITMP=1,NTMP
60710 KFTMP(ITMP)=KFCMP(ITMP)
60711 230 CONTINUE
60712 NFIN=0
60713 DO 250 IKF=1,5
60714 KFNOW=IABS(KFDP(IDC,IKF))
60715 IF(KFNOW.EQ.0) GOTO 250
60716 NFIN=NFIN+1
60717 DO 240 ITMP=1,NTMP
60718 IF(KFTMP(ITMP).EQ.KFNOW) THEN
60719 KFTMP(ITMP)=KFTMP(NTMP)
60720 NTMP=NTMP-1
60721 GOTO 250
60722 ENDIF
60723 240 CONTINUE
60724 250 CONTINUE
60725 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
60726 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
60727 & MDME(IDC,1)=MODE-7
60728 260 CONTINUE
60729 RETURN
60730
60731C...Error exit for impossible read of particle code.
60732 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
60733 &//CHCODE)
60734
60735C...Formats for output.
60736 1000 FORMAT(' Decays for',I8,' set ',A10)
60737 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
60738
60739 RETURN
60740 END
60741C*********************************************************************
60742
60743C...PYTUNE
60744C...Presets for a few specific underlying-event and min-bias tunes
60745C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
60746C...others require particular versions of pythia (e.g. the SCI and GAL
60747C...models). See below for details.
60748 SUBROUTINE PYTUNE(ITUNE)
60749C
60750C ITUNE NAME (detailed descriptions below)
60751C 0 Default : No settings changed => defaults.
60752C
60753C ====== Old UE, Q2-ordered showers ====================================
60754C 100 A : Rick Field's CDF Tune A (Oct 2002)
60755C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
60756C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
60757C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
60758C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
60759C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
60760C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
60761C 107 ACR : Tune A modified with new CR model (Mar 2007)
60762C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
60763C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
60764C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
60765C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
60766C 111 AW-Pro : Tune AW, -"- (Oct 2008)
60767C 112 BW-Pro : Tune BW, -"- (Oct 2008)
60768C 113 DW-Pro : Tune DW, -"- (Oct 2008)
60769C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
60770C 115 QW-Pro : Tune QW, -"- (Oct 2008)
60771C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
60772C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
60773C 118 D6-Pro : Tune D6, -"- (Oct 2008)
60774C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
60775C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
60776C 129 Pro-Q20 : Professor Q2-ordered tune (Feb 2009)
60777C
60778C ====== Intermediate and Hybrid Models ================================
60779C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
60780C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
60781C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
60782C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
60783C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
60784C
60785C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
60786C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
60787C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
60788C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
60789C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
60790C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
60791C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
60792C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
60793C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
60794C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
60795C 311 S1-Pro : S1 -"- (Oct 2008)
60796C 312 S2-Pro : S2 -"- (Oct 2008)
60797C 313 S0A-Pro : S0A -"- (Oct 2008)
60798C 314 NOCR-Pro : NOCR -"- (Oct 2008)
60799C 315 Old-Pro : Old -"- (Oct 2008)
60800C ---- Peter's Perugia Tunes : 320+ ------------------------------------
60801C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
60802C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
60803C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
60804C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
60805C balance & different scaling to LHC & RHIC (Feb 2009)
60806C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
60807C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
60808C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
60809C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
60810C 329 Pro-pT0 : Professor pT-ordered tune w. S0 CR model (Feb 2009)
60811C
60812C ======= The Uppsala models ===========================================
60813C ( NB! must be run with special modified Pythia 6.215 version )
60814C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
60815C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
60816C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
60817C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
60818C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
60819C
60820C More details;
60821C
60822C Quick Dictionary:
60823C BE : Bose-Einstein
60824C BR : Beam Remnants
60825C CR : Colour Reconnections
60826C HAD: Hadronization
60827C ISR/FSR: Initial-State Radiation / Final-State Radiation
60828C FSI: Final-State Interactions (=CR+BE)
60829C MB : Minimum-bias
60830C MI : Multiple Interactions
60831C UE : Underlying Event
60832C
60833C=======================================================================
60834C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
60835C=======================================================================
60836C
60837C A (100) and AW (101). CTEQ5L parton distributions
60838C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60839C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60840C...Key feature: extensively compared to CDF data (R.D. Field).
60841C...* Large starting scale for ISR (PARP(67)=4)
60842C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
60843C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60844C
60845C BW (102). 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...* Small starting scale for ISR (PARP(67)=1)
60851C...* BW has more radiation due to smaller mu_R choice in alpha_s.
60852C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60853C
60854C DW (103) and DWT (104). CTEQ5L parton distributions
60855C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60856C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60857C...Key feature: extensively compared to CDF data (R.D. Field).
60858C...NB: Can also be run with Pythia 6.2 or 6.312+
60859C...* Intermediate starting scale for ISR (PARP(67)=2.5)
60860C...* DWT has a different reference energy, the same as the "S" models
60861C... below, leading to more UE activity at the LHC, but less at RHIC.
60862C...* See: http://www.phys.ufl.edu/~rfield/cdf/
60863C
60864C QW (105). CTEQ61 parton distributions
60865C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60866C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60867C...Key feature: uses CTEQ61 (external pdf library must be linked)
60868C
60869C ATLAS-DC2 (106). CTEQ5L parton distributions
60870C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
60871C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
60872C...Key feature: tune used by the ATLAS collaboration.
60873C
60874C ACR (107). CTEQ5L parton distributions
60875C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
60876C...Key feature: Tune A modified to use annealing CR.
60877C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
60878C
60879C D6 (108) and D6T (109). CTEQ6L parton distributions
60880C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
60881C
60882C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
60883C Old UE model, Q2-ordered showers.
60884C...Key feature: Rick Field's family of tunes revamped with the
60885C...Professor Q2-ordered final-state shower and fragmentation tunes
60886C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
60887C...Key feature: improved descriptions of LEP data.
60888C
60889C Pro-Q20 (129). CTEQ5L parton distributions
60890C Old UE model, Q2-ordered showers.
60891C...Key feature: Complete retune of old model by Professor, including
60892C...large amounts of both LEP and Tevatron data.
60893C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
60894C...extreme in this tune, corresponding to using mu_R = pT/3 .
60895C
60896C=======================================================================
60897C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
60898C=======================================================================
60899C
60900C IM1 (200). Intermediate model, Q2-ordered showers,
60901C CTEQ5L parton distributions
60902C...Key feature: new UE model w Q2-ordered showers and no interleaving.
60903C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
60904C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
60905C
60906C APT (201). Old UE model, pT-ordered final-state showers,
60907C CTEQ5L parton distributions
60908C...Key feature: Rick Field's Tune A, but with new final-state showers
60909C
60910C APT-Pro (211). Old UE model, pT-ordered final-state showers,
60911C CTEQ5L parton distributions
60912C...Key feature: APT revamped with the Professor pT-ordered final-state
60913C...shower and fragmentation tunes presented by Hendrik Hoeth at the
60914C...Perugia MPI workshop in October 2008.
60915C
60916C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
60917C CTEQ5L parton distributions
60918C...Key feature: APT-Pro with final-state showers off the MPI,
60919C...lower ISR renormalization scale to improve agreement with the
60920C...Tevatron Drell-Yan pT measurements and with improved energy scaling
60921C...to min-bias at 630 GeV.
60922C
60923C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
60924C CTEQ6L1 parton distributions.
60925C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
60926C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
60927C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
60928C
60929C=======================================================================
60930C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
60931C=======================================================================
60932C
60933C S0 (300) and S0A (303). CTEQ5L parton distributions
60934C...Key feature: large amount of multiple interactions
60935C...* Somewhat faster than the other colour annealing scenarios.
60936C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
60937C... from Tune A, leading to less UE at the LHC, but more at RHIC.
60938C...* Small amount of radiation.
60939C...* Large amount of low-pT MI
60940C...* Low degree of proton lumpiness (broad matter dist.)
60941C...* CR Type S (driven by free triplets), of medium strength.
60942C...* See: Pythia6402 update notes or later.
60943C
60944C S1 (301). CTEQ5L parton distributions
60945C...Key feature: large amount of radiation.
60946C...* Large amount of low-pT perturbative ISR
60947C...* Large amount of FSR off ISR partons
60948C...* Small amount of low-pT multiple interactions
60949C...* Moderate degree of proton lumpiness
60950C...* Least aggressive CR type (S+S Type I), but with large strength
60951C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60952C
60953C S2 (302). CTEQ5L parton distributions
60954C...Key feature: very lumpy proton + gg string cluster formation allowed
60955C...* Small amount of radiation
60956C...* Moderate amount of low-pT MI
60957C...* High degree of proton lumpiness (more spiky matter distribution)
60958C...* Most aggressive CR type (S+S Type II), but with small strength
60959C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
60960C
60961C NOCR (304). CTEQ5L parton distributions
60962C...Key feature: no colour reconnections (NB: "Best fit" only).
60963C...* NB: <pT>(Nch) problematic in this tune.
60964C...* Small amount of radiation
60965C...* Small amount of low-pT MI
60966C...* Low degree of proton lumpiness
60967C...* Large BR composite x enhancement factor
60968C...* Most clever colour flow without CR ("Lambda ordering")
60969C
60970C ATLAS-CSC (306). CTEQ6L parton distributions
60971C...Key feature: 11-parameter ATLAS tune of the new framework.
60972C...* Old (pre-annealing) colour reconnections a la 305.
60973C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
60974C
60975C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
60976C...Key feature: the S0 family of tunes revamped with the Professor
60977C...pT-ordered final-state shower and fragmentation tunes presented by
60978C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
60979C...Key feature: improved descriptions of LEP data.
60980C
60981C Perugia-0 (320). CTEQ5L parton distributions.
60982C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
60983C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
60984C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
60985C...beam-remnant breakup (more baryon number transport), and suppression
60986C...of CR in high-pT string pieces.
60987C
60988C Perugia-HARD (321). CTEQ5L parton distributions.
60989C...Key feature: More ISR, More FSR, Less MPI, Less BR
60990C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
60991C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
60992C...baryon number transport), and more fragmentation pT.
60993C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
60994C...DY pT spectrum is HARD.
60995C
60996C Perugia-SOFT (322). CTEQ5L parton distributions.
60997C...Key feature: Less ISR, Less FSR, More MPI, More BR
60998C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
60999C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61000C...number transport), and less fragmentation pT.
61001C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61002C...DY pT spectrum is SOFT
61003C
61004C Perugia-3 (323). CTEQ5L parton distributions.
61005C...Key feature: variant of Perugia-0 with more extreme energy scaling
61006C...properties while still agreeing with Tevatron data from 630 to 1960.
61007C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61008C...allows FSR off the active end of dipoles stretched to the remnant.
61009C
61010C Perugia-NOCR (324). CTEQ5L parton distributions.
61011C...Key feature: Retune of NOCR-Pro with better scaling properties to
61012C...lower energies and somewhat better agreement with Tevatron data
61013C...at 1800/1960.
61014C
61015C Perugia-* (325). MRST LO* parton distributions for generators
61016C...Key feature: first attempt at using the LO* distributions
61017C...(external pdf library must be linked).
61018C
61019C Perugia-6 (326). CTEQ6L1 parton distributions
61020C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61021C
61022C Pro-pT0 (329). CTEQ5L parton distributions
61023C...Key feature: Complete retune of new model by Professor, including
61024C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61025C
61026C=======================================================================
61027C OTHER TUNES
61028C=======================================================================
61029C
61030C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61031C...with an unmodified Pythia distribution.
61032C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61033C
61034C ::: + Future improvements?
61035C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61036C (problem: K-factor affects everything so only works as
61037C intended for min-bias, not for UE ... probably need a
61038C better long-term solution to handle UE as well. Anyway,
61039C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61040
61041C...Global statements
61042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61043 INTEGER PYK,PYCHGE,PYCOMP
61044
61045C...Commonblocks.
61046 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61047 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61048
61049C...SCI and GAL Commonblocks
61050 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61051
61052C...SAVE statements
61053 SAVE /PYDAT1/,/PYPARS/
61054 SAVE /SCIPAR/
61055
61056C...Internal parameters
61057 PARAMETER(MXTUNS=500)
61058 CHARACTER*8 CHVERS, CHDOC
61059 PARAMETER (CHVERS='1.015 ',CHDOC='Jan 2009')
61060 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61061 CHARACTER*42 CHMSTJ(50), CHMSTP(51:100), CHPARP(61:100),
61062 & CHPARJ(1:100), CH40
61063 CHARACTER*60 CH60
61064 CHARACTER*70 CH70
61065 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61066 DATA (CHNAMS(I),I=100,119)/
61067 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61068 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61069 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61070 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61071 1 'Tune D6-Pro','Tune D6T-Pro'/
61072 DATA (CHNAMS(I),I=120,129)/
61073 & 9*' ','Pro-Q20'/
61074 DATA (CHNAMS(I),I=300,309)/
61075 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61076 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61077 DATA (CHNAMS(I),I=310,315)/
61078 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61079 & 'NOCR-Pro','Old-Pro'/
61080 DATA (CHNAMS(I),I=320,329)/
61081 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61082 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61083 & 'Perugia 6',2*' ','Pro-pT0'/
61084 DATA (CHNAMS(I),I=200,229)/
61085 & 'IM Tune 1','Tune APT',8*' ',
61086 & ' ','Tune APT-Pro',8*' ',
61087 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61088 DATA (CHNAMS(I),I=400,409)/
61089 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61090 DATA (CHMSTJ(I),I=11,20)/
61091 & 'HAD choice of fragmentation function(s)',4*' ',
61092 & 'HAD treatment of small-mass systems',4*' '/
61093 DATA (CHMSTJ(I),I=41,50)/
61094 & 'FSR type (Q2 or pT) for old framework',9*' '/
61095 DATA (CHMSTP(I),I=51,100)/
61096 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
61097 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
61098 6 'ISR coherence option for 1st emission',
61099 6 'ISR phase space choice & ME corrections',' ',
61100 7 'ISR IR regularization scheme',' ',
61101 7 'ISR scheme for FSR off ISR',8*' ',
61102 8 'UE model',
61103 8 'UE hadron transverse mass distribution',5*' ',
61104 8 'BR composite scheme','BR colour scheme',
61105 9 'BR primordial kT compensation',
61106 9 'BR primordial kT distribution',
61107 9 'BR energy partitioning scheme',2*' ',
61108 9 'FSI colour (re-)connection model',5*' '/
61109 DATA (CHPARP(I),I=61,100)/
61110 6 ' ','ISR IR cutoff',' ','ISR renormalization scale prefactor',
61111 6 2*' ','ISR Q2max factor',3*' ',
61112 7 'FSR Q2max factor for non-s-channel procs',5*' ',
61113 7 'FSI colour reco high-pT dampening strength',
61114 7 'FSI colour reconnection strength',
61115 7 'BR composite x enhancement','BR breakup suppression',
61116 8 2*'UE IR cutoff at reference ecm',
61117 8 2*'UE mass distribution parameter',
61118 8 'UE gg colour correlated fraction','UE total gg fraction',
61119 8 2*' ',
61120 8 'UE IR cutoff reference ecm','UE IR cutoff ecm scaling power',
61121 9 'BR primordial kT width <|kT|>',' ',
61122 9 'BR primordial kT UV cutoff',7*' '/
61123 DATA (CHPARJ(I),I=1,30)/
61124 & 'HAD diquark suppression','HAD strangeness suppression',
61125 & 'HAD strange diquark suppression',
61126 & 'HAD vector diquark suppression',6*' ',
61127 1 'HAD P(vector meson), u and d only',
61128 1 'HAD P(vector meson), contains s',
61129 1 'HAD P(vector meson), heavy quarks',7*' ',
61130 2 'HAD fragmentation pT',' ',' ',' ',
61131 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
61132 DATA (CHPARJ(I),I=41,90)/
61133 4 'HAD string parameter a','HAD string parameter b',3*' ',
61134 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
61135 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
61136 5 3*' ','HAD charm parameter','HAD bottom parameter',5*' ',
61137 6 10*' ',10*' ',
61138 8 'FSR Lambda_QCD scale','FSR IR cutoff',8*' '/
61139
61140C...1) Shorthand notation
61141 M13=MSTU(13)
61142 M11=MSTU(11)
61143 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
61144 CHNAME=CHNAMS(ITUNE)
61145 IF (ITUNE.EQ.0) GOTO 9999
61146 ELSE
61147 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
61148 GOTO 9999
61149 ENDIF
61150
61151C...2) Hello World
61152 IF (M13.GE.1) WRITE(M11,5000) CHVERS, CHDOC
61153
61154C...3) Tune parameters
61155
61156C=======================================================================
61157C...S0, S1, S2, S0A, NOCR, Rap,
61158C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
61159C...Perugia 0, HARD, SOFT, Perugia 3, Perugia LO*, Perugia 6
61160C...Pro-pT0
61161 IF ((ITUNE.GE.300.AND.ITUNE.LE.305)
61162 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
61163 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.326).OR.ITUNE.EQ.329) THEN
61164 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61165 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61166 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61167 & ' with tune.')
61168 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326.AND.ITUNE.NE.324.AND.
61169 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
61170 & THEN
61171 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61172 & ' with tune.')
61173 ENDIF
61174
61175C...Use Professor's LEP pars if ITUNE >= 310
61176C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
61177 IF (ITUNE.LT.310) THEN
61178C...# Old defaults
61179 MSTJ(11) = 4
61180C...# Old default flavour parameters
61181 PARJ(21) = 0.36
61182 PARJ(41) = 0.30
61183 PARJ(42) = 0.58
61184 PARJ(46) = 1.0
61185 PARJ(82) = 1.0
61186
61187 ELSEIF (ITUNE.GE.310) THEN
61188C...# Tuned flavour parameters:
61189 PARJ(1) = 0.073
61190 PARJ(2) = 0.2
61191 PARJ(3) = 0.94
61192 PARJ(4) = 0.032
61193 PARJ(11) = 0.31
61194 PARJ(12) = 0.4
61195 PARJ(13) = 0.54
61196 PARJ(25) = 0.63
61197 PARJ(26) = 0.12
61198C...# Always use pT-ordered shower:
61199 MSTJ(41) = 12
61200C...# Switch on Bowler:
61201 MSTJ(11) = 5
61202C...# Fragmentation
61203 PARJ(21) = 0.313
61204 PARJ(41) = 0.49
61205 PARJ(42) = 1.2
61206 PARJ(47) = 1.0
61207 PARJ(81) = 0.257
61208 PARJ(82) = 0.8
61209 ENDIF
61210
61211C...Remove middle digit now for Professor variants, since identical pars
61212 ITUNEB=ITUNE
61213 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
61214 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61215 ENDIF
61216
61217C...PDFs: all use CTEQ5L as starting point
61218 MSTP(52)=1
61219 MSTP(51)=7
61220 IF (ITUNE.EQ.325) THEN
61221C...MRST LO* for 325
61222 MSTP(52)=2
61223 MSTP(51)=20650
61224 ELSEIF (ITUNE.EQ.326) THEN
61225C...CTEQ6L1 for 326
61226 MSTP(52)=2
61227 MSTP(51)=10042
61228 ENDIF
61229
61230C...ISR: use Lambda_MSbar with default scale for S0(A)
61231 MSTP(64)=2
61232 PARP(64)=1D0
61233 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.
61234 & ITUNE.EQ.326) THEN
61235C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
61236 MSTP(64)=3
61237 PARP(64)=1D0
61238 ELSEIF (ITUNE.EQ.321) THEN
61239C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
61240 MSTP(64)=3
61241 PARP(64)=0.25D0
61242 ELSEIF (ITUNE.EQ.322) THEN
61243C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
61244 MSTP(64)=2
61245 PARP(64)=2D0
61246 ELSEIF (ITUNE.EQ.325) THEN
61247C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
61248 MSTP(64)=3
61249 PARP(64)=2D0
61250 ELSEIF (ITUNE.EQ.329) THEN
61251C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
61252 MSTP(64)=2
61253 PARP(64)=1.3D0
61254 ENDIF
61255
61256C...ISR : power-suppressed power showers above s_color (since 6.4.19)
61257 MSTP(67)=2
61258 PARP(67)=4D0
61259C...Perugia tunes have stronger suppression, except HARD
61260 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61261 PARP(67)=1D0
61262 IF (ITUNE.EQ.321) PARP(67)=4D0
61263 IF (ITUNE.EQ.322) PARP(67)=0.5D0
61264 ENDIF
61265
61266C...ISR IR cutoff type and FSR off ISR setting:
61267C...Smooth ISR, low FSR-off-ISR
61268 MSTP(70)=2
61269 MSTP(72)=0
61270 IF (ITUNEB.EQ.301) THEN
61271C...S1, S1-Pro: sharp ISR, high FSR
61272 MSTP(70)=0
61273 MSTP(72)=1
61274 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
61275 & .OR.ITUNE.EQ.325) THEN
61276C...Perugia default is smooth ISR, high FSR-off-ISR
61277 MSTP(70)=2
61278 MSTP(72)=1
61279 ELSEIF (ITUNE.EQ.321) THEN
61280C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
61281 MSTP(70)=0
61282 PARP(62)=1.25D0
61283 MSTP(72)=1
61284 ELSEIF (ITUNE.EQ.322) THEN
61285C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
61286 MSTP(70)=1
61287 PARP(81)=1.5D0
61288 MSTP(72)=0
61289 ELSEIF (ITUNE.EQ.323) THEN
61290C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
61291 MSTP(70)=0
61292 PARP(62)=1.25D0
61293 MSTP(72)=2
61294 ENDIF
61295
61296C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
61297C...by Professor tunes (with HARD and SOFT variations)
61298 PARP(71)=4D0
61299 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61300 PARP(71)=2D0
61301 IF (ITUNE.EQ.321) PARP(71)=4D0
61302 IF (ITUNE.EQ.322) PARP(71)=1D0
61303 ENDIF
61304 IF (ITUNE.EQ.329) PARP(71)=2D0
61305
61306C...FSR: Lambda_FSR scale (only if not using professor)
61307 IF (ITUNE.LT.310) PARJ(81)=0.23D0
61308 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
61309 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
61310
61311C...UE on, new model
61312 MSTP(81)=21
61313
61314C...UE: hadron-hadron overlap profile (expOfPow for all)
61315 MSTP(82)=5
61316C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
61317 PARP(83)=1.6D0
61318 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
61319 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
61320C...NOCR variants have very smooth distributions
61321 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
61322 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
61323 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61324C...Perugia variants have slightly smoother profiles by default
61325C...(to compensate for more tail by added radiation)
61326C...Perugia-SOFT has more peaked distribution, NOCR less peaked
61327 PARP(83)=1.7D0
61328 IF (ITUNE.EQ.322) PARP(83)=1.5D0
61329 IF (ITUNE.EQ.324) PARP(83)=1.8D0
61330 ENDIF
61331C...Professor-pT0 also has very smooth distribution
61332 IF (ITUNE.EQ.329) PARP(83)=1.8
61333
61334C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
61335 PARP(82)=1.85D0
61336 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
61337 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
61338 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
61339 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
61340 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61341C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
61342C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
61343C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
61344C...slightly higher, due to increased activity.
61345 PARP(82)=2.0D0
61346 IF (ITUNE.EQ.321) PARP(82)=2.3D0
61347 IF (ITUNE.EQ.322) PARP(82)=1.9D0
61348 IF (ITUNE.EQ.323) PARP(82)=2.2D0
61349 IF (ITUNE.EQ.324) PARP(82)=1.95D0
61350 IF (ITUNE.EQ.325) PARP(82)=2.2D0
61351 IF (ITUNE.EQ.326) PARP(82)=1.95D0
61352 ENDIF
61353C...Professor-pT0 maintains low pT0 vaue
61354 IF (ITUNE.EQ.329) PARP(82)=1.85D0
61355
61356C...UE: IR cutoff reference energy and default energy scaling pace
61357 PARP(89)=1800D0
61358 PARP(90)=0.16D0
61359C...S0A, S0A-Pro have tune A energy scaling
61360 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
61361 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61362C...Perugia tunes explicitly include MB at 630 to fix energy scaling
61363 PARP(90)=0.26
61364 IF (ITUNE.EQ.321) PARP(90)=0.30D0
61365 IF (ITUNE.EQ.322) PARP(90)=0.24D0
61366 IF (ITUNE.EQ.323) PARP(90)=0.32D0
61367 IF (ITUNE.EQ.324) PARP(90)=0.24D0
61368C...LO* and CTEQ6L1 tunes have slower energy scaling
61369 IF (ITUNE.EQ.325) PARP(90)=0.23D0
61370 IF (ITUNE.EQ.326) PARP(90)=0.22D0
61371 ENDIF
61372C...Professor-pT0 has intermediate scaling
61373 IF (ITUNE.EQ.329) PARP(90)=0.22D0
61374
61375C...BR: MPI initiator color connections rap-ordered by default
61376C...NOCR variants are Lambda-ordered, Perugia SOFT is random-ordered
61377 MSTP(89)=1
61378 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
61379 IF (ITUNE.EQ.322) MSTP(89)=0
61380
61381C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
61382 PARP(80)=0.01D0
61383 IF (ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61384C...Perugia tunes have more beam blowup by default
61385 PARP(80)=0.05D0
61386 IF (ITUNE.EQ.321) PARP(80)=0.01
61387 IF (ITUNE.EQ.323) PARP(80)=0.03
61388 IF (ITUNE.EQ.324) PARP(80)=0.01
61389 ENDIF
61390
61391C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
61392 MSTP(88)=0
61393 PARP(79)=2D0
61394 IF (ITUNEB.EQ.304) PARP(79)=3D0
61395 IF (ITUNE.EQ.329) PARP(79)=1.18
61396
61397C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
61398 MSTP(91)=1
61399 PARP(91)=2D0
61400 PARP(93)=10D0
61401C...Perugia-HARD only uses 1.0 GeV
61402 IF (ITUNE.EQ.321) PARP(91)=1.0D0
61403C...Perugia-3 only uses 1.5 GeV
61404 IF (ITUNE.EQ.323) PARP(91)=1.5D0
61405C...Professor-pT0 uses 7-GeV cutoff
61406 IF (ITUNE.EQ.329) PARP(93)=7.0
61407
61408C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
61409 MSTP(95)=6
61410C...S1, S1-Pro: use S1
61411 IF (ITUNEB.EQ.301) MSTP(95)=2
61412C...S2, S2-Pro: use S2
61413 IF (ITUNEB.EQ.302) MSTP(95)=4
61414C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
61415 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324) MSTP(95)=0
61416C..."Old" and "Old"-Pro: use old CR
61417 IF (ITUNEB.EQ.305) MSTP(95)=1
61418
61419C...FSI: CR strength and high-pT dampening, default is S0
61420 IF (ITUNE.LT.320.OR.ITUNE.EQ.329) THEN
61421 PARP(78)=0.2D0
61422 PARP(77)=0D0
61423 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
61424 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
61425 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
61426 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
61427 IF (ITUNE.EQ.329) PARP(78)=0.17D0
61428 ELSE
61429C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
61430 PARP(78)=0.33
61431 PARP(77)=0.9D0
61432 IF (ITUNE.EQ.321) THEN
61433C...HARD has HIGH amount of CR
61434 PARP(78)=0.37D0
61435 PARP(77)=0.4D0
61436 ELSEIF (ITUNE.EQ.322) THEN
61437C...SOFT has LOW amount of CR
61438 PARP(78)=0.15D0
61439 PARP(77)=0.5D0
61440 ELSEIF (ITUNE.EQ.323) THEN
61441C...Scaling variant appears to need slightly more than default
61442 PARP(78)=0.35D0
61443 PARP(77)=0.6D0
61444 ELSEIF (ITUNE.EQ.324) THEN
61445C...NOCR has no CR
61446 PARP(78)=0D0
61447 PARP(77)=0D0
61448 ENDIF
61449 ENDIF
61450
61451C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
61452 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
61453 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
61454
61455C...Switch off trial joinings
61456 MSTP(96)=0
61457
61458C...S0 (300), S0A (303)
61459 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
61460 IF (M13.GE.1) THEN
61461 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61462 WRITE(M11,5030) CH60
61463 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
61464 WRITE(M11,5030) CH60
61465 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61466 WRITE(M11,5030) CH60
61467 IF (ITUNE.GE.310) THEN
61468 CH60='LEP parameters tuned by Professor'
61469 WRITE(M11,5030) CH60
61470 ENDIF
61471 ENDIF
61472
61473C...S1 (301)
61474 ELSEIF(ITUNEB.EQ.301) THEN
61475 IF (M13.GE.1) THEN
61476 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61477 WRITE(M11,5030) CH60
61478 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61479 WRITE(M11,5030) CH60
61480 IF (ITUNE.GE.310) THEN
61481 CH60='LEP parameters tuned with Professor'
61482 WRITE(M11,5030) CH60
61483 ENDIF
61484 ENDIF
61485
61486C...S2 (302)
61487 ELSEIF(ITUNEB.EQ.302) THEN
61488 IF (M13.GE.1) THEN
61489 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
61490 WRITE(M11,5030) CH60
61491 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61492 WRITE(M11,5030) CH60
61493 IF (ITUNE.GE.310) THEN
61494 CH60='LEP parameters tuned by Professor'
61495 WRITE(M11,5030) CH60
61496 ENDIF
61497 ENDIF
61498
61499C...NOCR (304)
61500 ELSEIF(ITUNEB.EQ.304) THEN
61501 IF (M13.GE.1) THEN
61502 CH60='"best try" without colour reconnections'
61503 WRITE(M11,5030) CH60
61504 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
61505 WRITE(M11,5030) CH60
61506 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61507 WRITE(M11,5030) CH60
61508 IF (ITUNE.GE.310) THEN
61509 CH60='LEP parameters tuned by Professor'
61510 WRITE(M11,5030) CH60
61511 ENDIF
61512 ENDIF
61513
61514C..."Lo FSR" retune (305)
61515 ELSEIF(ITUNEB.EQ.305) THEN
61516 IF (M13.GE.1) THEN
61517 CH60='"Lo FSR retune" with primitive colour reconnections'
61518 WRITE(M11,5030) CH60
61519 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
61520 WRITE(M11,5030) CH60
61521 IF (ITUNE.GE.310) THEN
61522 CH60='LEP parameters tuned by Professor'
61523 WRITE(M11,5030) CH60
61524 ENDIF
61525 ENDIF
61526
61527C...Perugia Tunes (320-326)
61528 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.326) THEN
61529 IF (M13.GE.1) THEN
61530 CH60='P. Skands, Perugia MPI workshop October 2008'
61531 WRITE(M11,5030) CH60
61532 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61533 WRITE(M11,5030) CH60
61534 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
61535 WRITE(M11,5030) CH60
61536 CH60='LEP parameters tuned by Professor'
61537 WRITE(M11,5030) CH60
61538 IF (ITUNE.EQ.325) THEN
61539 CH70='NB! This tune requires MRST LO* pdfs to be '//
61540 & 'externally linked'
61541 WRITE(M11,5035) CH70
61542 ELSEIF (ITUNE.EQ.326) THEN
61543 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
61544 & 'externally linked'
61545 WRITE(M11,5035) CH70
61546 ELSEIF (ITUNE.EQ.321) THEN
61547 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
61548 WRITE(M11,5030) CH60
61549 ELSEIF (ITUNE.EQ.322) THEN
61550 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
61551 WRITE(M11,5030) CH60
61552 ENDIF
61553 ENDIF
61554
61555C...Professor-pT0 (329)
61556 ELSEIF(ITUNE.EQ.329) THEN
61557 IF (M13.GE.1) THEN
61558 CH60='See T. Sjostrand & P. Skands, hep-ph/0408302'
61559 WRITE(M11,5030) CH60
61560 CH60='and M. Sandhoff & P. Skands, in hep-ph/0604120'
61561 WRITE(M11,5030) CH60
61562 CH60='LEP/Tevatron parameters tuned by Professor'
61563 WRITE(M11,5030) CH60
61564 ENDIF
61565
61566 ENDIF
61567
61568C...Output
61569 IF (M13.GE.1) THEN
61570 WRITE(M11,5030) ' '
61571 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61572 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61573 IF (MSTP(70).EQ.0) THEN
61574 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
61575 ELSEIF (MSTP(70).EQ.1) THEN
61576 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
61577 CH60='(Note: PARP(81) replaces PARP(62).)'
61578 WRITE(M11,5030) CH60
61579 ENDIF
61580 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
61581 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61582 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
61583 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
61584 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61585 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61586 WRITE(M11,5030) CH60
61587 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61588 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61589 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61590 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61591 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
61592 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61593 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61594 IF (MSTP(70).EQ.2) THEN
61595 CH60='(Note: PARP(82) replaces PARP(62).)'
61596 WRITE(M11,5030) CH60
61597 ENDIF
61598 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61599 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61600 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61601 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61602 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61603 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61604 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61605 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61606 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
61607 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
61608 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61609 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61610 IF (MSTP(95).GE.1) THEN
61611 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61612 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
61613 ENDIF
61614 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61615 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61616 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61617 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61618 IF (MSTJ(11).LE.3) THEN
61619 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61620 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61621 ELSE
61622 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61623 ENDIF
61624 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61625 ENDIF
61626
61627C=======================================================================
61628C...ATLAS-CSC 11-parameter tune (By A. Moraes)
61629 ELSEIF (ITUNE.EQ.306) THEN
61630 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
61631 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
61632 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
61633 & ' with tune.')
61634 ENDIF
61635
61636C...PDFs
61637 MSTP(52)=2
61638 MSTP(54)=2
61639 MSTP(51)=10042
61640 MSTP(53)=10042
61641C...ISR
61642C PARP(64)=1D0
61643C...UE on, new model.
61644 MSTP(81)=21
61645C...Energy scaling
61646 PARP(89)=1800D0
61647 PARP(90)=0.22D0
61648C...Switch off trial joinings
61649 MSTP(96)=0
61650C...Primordial kT cutoff
61651
61652 IF (M13.GE.1) THEN
61653 CH60='see presentations by A. Moraes (ATLAS),'
61654 WRITE(M11,5030) CH60
61655 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
61656 WRITE(M11,5030) CH60
61657 WRITE(M11,5030) ' '
61658 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61659 & 'externally linked'
61660 WRITE(M11,5035) CH70
61661 ENDIF
61662C...Smooth ISR, low FSR
61663 MSTP(70)=2
61664 MSTP(72)=0
61665C...pT0
61666 PARP(82)=1.9D0
61667C...Transverse density profile.
61668 MSTP(82)=4
61669 PARP(83)=0.3D0
61670 PARP(84)=0.5D0
61671C...ISR & FSR in interactions after the first (default)
61672 MSTP(84)=1
61673 MSTP(85)=1
61674C...No double-counting (default)
61675 MSTP(86)=2
61676C...Companion quark parent gluon (1-x) power
61677 MSTP(87)=4
61678C...Primordial kT compensation along chaings (default = 0 : uniform)
61679 MSTP(90)=1
61680C...Colour Reconnections
61681 MSTP(95)=1
61682 PARP(78)=0.2D0
61683C...Lambda_FSR scale.
61684 PARJ(81)=0.23D0
61685C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
61686 MSTP(89)=1
61687 MSTP(88)=0
61688C PARP(79)=2D0
61689 PARP(80)=0.01D0
61690C...Peterson charm frag, and c and b hadr parameters
61691 MSTJ(11)=3
61692 PARJ(54)=-0.07
61693 PARJ(55)=-0.006
61694C... Output
61695 IF (M13.GE.1) THEN
61696 WRITE(M11,5030) ' '
61697 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
61698 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
61699 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
61700 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
61701 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
61702 WRITE(M11,5030) CH60
61703 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
61704 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
61705 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
61706 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
61707 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
61708 WRITE(M11,5030) CH60
61709 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
61710 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
61711 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
61712 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
61713 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
61714 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
61715 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
61716 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
61717 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
61718 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
61719 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
61720 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
61721 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
61722 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
61723 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
61724 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
61725 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
61726 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
61727 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
61728 IF (MSTJ(11).LE.3) THEN
61729 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
61730 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
61731 ELSE
61732 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
61733 ENDIF
61734 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
61735 ENDIF
61736
61737C=======================================================================
61738C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
61739C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
61740C...A-Pro, DW-Pro, etc (100-119), and Pro-Q20 (129)
61741 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
61742 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
61743 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
61744 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
61745 WRITE(M11,5010) ITUNE, CHNAME
61746 CH60='see R.D. Field, in hep-ph/0610012'
61747 WRITE(M11,5030) CH60
61748 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61749 WRITE(M11,5030) CH60
61750 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61751 CH60='LEP parameters tuned by Professor'
61752 WRITE(M11,5030) CH60
61753 ENDIF
61754 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
61755 WRITE(M11,5010) ITUNE, CHNAME
61756 CH60='See T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61757 WRITE(M11,5030) CH60
61758 CH60='LEP/Tevatron parameters tuned by Professor'
61759 WRITE(M11,5030) CH60
61760 ENDIF
61761
61762C...Make sure we start from old default fragmentation parameters
61763 PARJ(81) = 0.29
61764 PARJ(82) = 1.0
61765
61766C...Use Professor's LEP pars if ITUNE >= 110
61767C...(i.e., for A-Pro, DW-Pro etc)
61768 IF (ITUNE.LT.110) THEN
61769C...# Old defaults
61770 MSTJ(11) = 4
61771C...# Old default flavour parameters
61772 PARJ(21) = 0.36
61773 PARJ(41) = 0.30
61774 PARJ(42) = 0.58
61775 PARJ(46) = 1.0
61776 PARJ(82) = 1.0
61777 ELSE
61778C...# Tuned flavour parameters:
61779 PARJ(1) = 0.073
61780 PARJ(2) = 0.2
61781 PARJ(3) = 0.94
61782 PARJ(4) = 0.032
61783 PARJ(11) = 0.31
61784 PARJ(12) = 0.4
61785 PARJ(13) = 0.54
61786 PARJ(25) = 0.63
61787 PARJ(26) = 0.12
61788C...# Switch on Bowler:
61789 MSTJ(11) = 5
61790C...# Fragmentation
61791 PARJ(21) = 0.325
61792 PARJ(41) = 0.5
61793 PARJ(42) = 0.6
61794 PARJ(47) = 0.67
61795 PARJ(81) = 0.29
61796 PARJ(82) = 1.65
61797 ENDIF
61798
61799C...Remove middle digit now for Professor variants, since identical pars
61800 ITUNEB=ITUNE
61801 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
61802 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
61803 ENDIF
61804
61805C...Multiple interactions on, old framework
61806 MSTP(81)=1
61807C...Fast IR cutoff energy scaling by default
61808 PARP(89)=1800D0
61809 PARP(90)=0.25D0
61810C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
61811 MSTP(51)=7
61812 MSTP(52)=1
61813 IF (ITUNEB.EQ.105) THEN
61814 MSTP(51)=10150
61815 MSTP(52)=2
61816 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61817 MSTP(52)=2
61818 MSTP(54)=2
61819 MSTP(51)=10042
61820 MSTP(53)=10042
61821 ENDIF
61822C...Double Gaussian matter distribution.
61823 MSTP(82)=4
61824 PARP(83)=0.5D0
61825 PARP(84)=0.4D0
61826C...FSR activity.
61827 PARP(71)=4D0
61828C...Fragmentation functions and c and b parameters
61829C...(only if not using Professor)
61830 IF (ITUNE.LE.109) THEN
61831 MSTJ(11)=4
61832 PARJ(54)=-0.05
61833 PARJ(55)=-0.005
61834 ENDIF
61835
61836C...Tune A and AW
61837 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
61838C...pT0.
61839 PARP(82)=2.0D0
61840c...String drawing almost completely minimizes string length.
61841 PARP(85)=0.9D0
61842 PARP(86)=0.95D0
61843C...ISR cutoff, muR scale factor, and phase space size
61844 PARP(62)=1D0
61845 PARP(64)=1D0
61846 PARP(67)=4D0
61847C...Intrinsic kT, size, and max
61848 MSTP(91)=1
61849 PARP(91)=1D0
61850 PARP(93)=5D0
61851C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
61852 IF (ITUNEB.EQ.101) THEN
61853 PARP(62)=1.25D0
61854 PARP(64)=0.2D0
61855 PARP(91)=2.1D0
61856 PARP(92)=15.0D0
61857 ENDIF
61858
61859C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
61860 ELSEIF (ITUNEB.EQ.102) THEN
61861C...pT0.
61862 PARP(82)=1.9D0
61863c...String drawing completely minimizes string length.
61864 PARP(85)=1.0D0
61865 PARP(86)=1.0D0
61866C...ISR cutoff, muR scale factor, and phase space size
61867 PARP(62)=1.25D0
61868 PARP(64)=0.2D0
61869 PARP(67)=1D0
61870C...Intrinsic kT, size, and max
61871 MSTP(91)=1
61872 PARP(91)=2.1D0
61873 PARP(93)=15D0
61874
61875C...Tune DW
61876 ELSEIF (ITUNEB.EQ.103) THEN
61877C...pT0.
61878 PARP(82)=1.9D0
61879c...String drawing completely minimizes string length.
61880 PARP(85)=1.0D0
61881 PARP(86)=1.0D0
61882C...ISR cutoff, muR scale factor, and phase space size
61883 PARP(62)=1.25D0
61884 PARP(64)=0.2D0
61885 PARP(67)=2.5D0
61886C...Intrinsic kT, size, and max
61887 MSTP(91)=1
61888 PARP(91)=2.1D0
61889 PARP(93)=15D0
61890
61891C...Tune DWT
61892 ELSEIF (ITUNEB.EQ.104) THEN
61893C...pT0.
61894 PARP(82)=1.9409D0
61895C...Run II ref scale and slow scaling
61896 PARP(89)=1960D0
61897 PARP(90)=0.16D0
61898c...String drawing completely minimizes string length.
61899 PARP(85)=1.0D0
61900 PARP(86)=1.0D0
61901C...ISR cutoff, muR scale factor, and phase space size
61902 PARP(62)=1.25D0
61903 PARP(64)=0.2D0
61904 PARP(67)=2.5D0
61905C...Intrinsic kT, size, and max
61906 MSTP(91)=1
61907 PARP(91)=2.1D0
61908 PARP(93)=15D0
61909
61910C...Tune QW
61911 ELSEIF(ITUNEB.EQ.105) THEN
61912 IF (M13.GE.1) THEN
61913 WRITE(M11,5030) ' '
61914 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
61915 & 'externally linked'
61916 WRITE(M11,5035) CH70
61917 ENDIF
61918C...pT0.
61919 PARP(82)=1.1D0
61920c...String drawing completely minimizes string length.
61921 PARP(85)=1.0D0
61922 PARP(86)=1.0D0
61923C...ISR cutoff, muR scale factor, and phase space size
61924 PARP(62)=1.25D0
61925 PARP(64)=0.2D0
61926 PARP(67)=2.5D0
61927C...Intrinsic kT, size, and max
61928 MSTP(91)=1
61929 PARP(91)=2.1D0
61930 PARP(93)=15D0
61931
61932C...Tune D6 and D6T
61933 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
61934 IF (M13.GE.1) THEN
61935 WRITE(M11,5030) ' '
61936 CH70='NB! This tune requires CTEQ6L pdfs to be '//
61937 & 'externally linked'
61938 WRITE(M11,5035) CH70
61939 ENDIF
61940C...The "Rick" proton, double gauss with 0.5/0.4
61941 MSTP(82)=4
61942 PARP(83)=0.5D0
61943 PARP(84)=0.4D0
61944c...String drawing completely minimizes string length.
61945 PARP(85)=1.0D0
61946 PARP(86)=1.0D0
61947 IF (ITUNEB.EQ.108) THEN
61948C...D6: pT0, Run I ref scale, and fast energy scaling
61949 PARP(82)=1.8D0
61950 PARP(89)=1800D0
61951 PARP(90)=0.25D0
61952 ELSE
61953C...D6T: pT0, Run II ref scale, and slow energy scaling
61954 PARP(82)=1.8387D0
61955 PARP(89)=1960D0
61956 PARP(90)=0.16D0
61957 ENDIF
61958C...ISR cutoff, muR scale factor, and phase space size
61959 PARP(62)=1.25D0
61960 PARP(64)=0.2D0
61961 PARP(67)=2.5D0
61962C...Intrinsic kT, size, and max
61963 MSTP(91)=1
61964 PARP(91)=2.1D0
61965 PARP(93)=15D0
61966
61967C...Old ATLAS-DC2 5-parameter tune
61968 ELSEIF(ITUNEB.EQ.106) THEN
61969 IF (M13.GE.1) THEN
61970 WRITE(M11,5010) ITUNE, CHNAME
61971 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
61972 WRITE(M11,5030) CH60
61973 CH60=' R. Field in hep-ph/0610012,'
61974 WRITE(M11,5030) CH60
61975 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
61976 WRITE(M11,5030) CH60
61977 ENDIF
61978C... pT0.
61979 PARP(82)=1.8D0
61980C... Different ref and rescaling pacee
61981 PARP(89)=1000D0
61982 PARP(90)=0.16D0
61983C... Parameters of mass distribution
61984 PARP(83)=0.5D0
61985 PARP(84)=0.5D0
61986C... Old default string drawing
61987 PARP(85)=0.33D0
61988 PARP(86)=0.66D0
61989C... ISR, phase space equivalent to Tune B
61990 PARP(62)=1D0
61991 PARP(64)=1D0
61992 PARP(67)=1D0
61993C... FSR
61994 PARP(71)=4D0
61995C... Intrinsic kT
61996 MSTP(91)=1
61997 PARP(91)=1D0
61998 PARP(93)=5D0
61999
62000C...Professor's Pro-Q20 Tune
62001 ELSEIF(ITUNE.EQ.129) THEN
62002 IF (M13.GE.1) THEN
62003 CH60='see H. Hoeth, Perugia MPI workshop, Oct 2008'
62004 WRITE(M11,5030) CH60
62005 ENDIF
62006 PARP(62)=2.9
62007 PARP(64)=0.14
62008 PARP(67)=2.65
62009 PARP(82)=1.9
62010 PARP(83)=0.83
62011 PARP(84)=0.6
62012 PARP(85)=0.86
62013 PARP(86)=0.93
62014 PARP(89)=1800D0
62015 PARP(90)=0.22
62016 MSTP(91)=1
62017 PARP(91)=2.1
62018 PARP(93)=5.0
62019
62020 ENDIF
62021
62022C... Output
62023 IF (M13.GE.1) THEN
62024 WRITE(M11,5030) ' '
62025 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62026 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62027 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62028 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62029 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62030 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62031 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62032 WRITE(M11,5030) CH60
62033 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62034 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62035 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62036 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62037 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62038 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62039 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62040 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62041 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62042 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62043 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62044 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62045 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62046 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62047 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62048 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62049 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62050 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62051 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62052 IF (MSTJ(11).LE.3) THEN
62053 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62054 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62055 ELSE
62056 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62057 ENDIF
62058 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62059 ENDIF
62060
62061C=======================================================================
62062C... ACR, tune A with new CR (107)
62063 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
62064 IF (M13.GE.1) THEN
62065 WRITE(M11,5010) ITUNE, CHNAME
62066 CH60='Tune A modified with new colour reconnections'
62067 WRITE(M11,5030) CH60
62068 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
62069 WRITE(M11,5030) CH60
62070 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
62071 WRITE(M11,5030) CH60
62072 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
62073 WRITE(M11,5030) CH60
62074 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62075 WRITE(M11,5030) CH60
62076 IF (ITUNE.EQ.117) THEN
62077 CH60='LEP parameters tuned by Professor'
62078 WRITE(M11,5030) CH60
62079 ENDIF
62080 ENDIF
62081 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
62082 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62083 & ' with tune. Using defaults.')
62084 GOTO 100
62085 ENDIF
62086
62087C...Make sure we start from old default fragmentation parameters
62088 PARJ(81) = 0.29
62089 PARJ(82) = 1.0
62090
62091C...Use Professor's LEP pars if ITUNE >= 110
62092C...(i.e., for A-Pro, DW-Pro etc)
62093 IF (ITUNE.LT.110) THEN
62094C...# Old defaults
62095 MSTJ(11) = 4
62096C...# Old default flavour parameters
62097 PARJ(21) = 0.36
62098 PARJ(41) = 0.30
62099 PARJ(42) = 0.58
62100 PARJ(46) = 1.0
62101 PARJ(82) = 1.0
62102 ELSE
62103C...# Tuned flavour parameters:
62104 PARJ(1) = 0.073
62105 PARJ(2) = 0.2
62106 PARJ(3) = 0.94
62107 PARJ(4) = 0.032
62108 PARJ(11) = 0.31
62109 PARJ(12) = 0.4
62110 PARJ(13) = 0.54
62111 PARJ(25) = 0.63
62112 PARJ(26) = 0.12
62113C...# Switch on Bowler:
62114 MSTJ(11) = 5
62115C...# Fragmentation
62116 PARJ(21) = 0.325
62117 PARJ(41) = 0.5
62118 PARJ(42) = 0.6
62119 PARJ(47) = 0.67
62120 PARJ(81) = 0.29
62121 PARJ(82) = 1.65
62122 ENDIF
62123
62124 MSTP(81)=1
62125 PARP(89)=1800D0
62126 PARP(90)=0.25D0
62127 MSTP(82)=4
62128 PARP(83)=0.5D0
62129 PARP(84)=0.4D0
62130 MSTP(51)=7
62131 MSTP(52)=1
62132 PARP(71)=4D0
62133 PARP(82)=2.0D0
62134 PARP(85)=0.0D0
62135 PARP(86)=0.66D0
62136 PARP(62)=1D0
62137 PARP(64)=1D0
62138 PARP(67)=4D0
62139 MSTP(91)=1
62140 PARP(91)=1D0
62141 PARP(93)=5D0
62142 MSTP(95)=6
62143C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
62144 PARP(78)=0.09D0
62145C...Frag functions (only if not using Professor)
62146 IF (ITUNE.LE.109) THEN
62147 MSTJ(11)=4
62148 PARJ(54)=-0.05
62149 PARJ(55)=-0.005
62150 ENDIF
62151
62152C...Output
62153 IF (M13.GE.1) THEN
62154 WRITE(M11,5030) ' '
62155 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62156 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62157 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62158 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62159 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62160 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62161 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62162 WRITE(M11,5030) CH60
62163 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62164 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62165 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62166 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62167 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62168 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62169 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62170 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62171 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62172 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62173 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62174 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62175 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62176 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62177 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62178 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62179 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62180 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62181 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62182 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62183 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62184 IF (MSTJ(11).LE.3) THEN
62185 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62186 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62187 ELSE
62188 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62189 ENDIF
62190 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62191 ENDIF
62192
62193C=======================================================================
62194C...Intermediate model. Rap tune
62195C...(retuned to post-6.406 IR factorization)
62196 ELSEIF(ITUNE.EQ.200) THEN
62197 IF (M13.GE.1) THEN
62198 WRITE(M11,5010) ITUNE, CHNAME
62199 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
62200 WRITE(M11,5030) CH60
62201 ENDIF
62202 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62203 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62204 & ' with tune.')
62205 ENDIF
62206C...PDF
62207 MSTP(51)=7
62208 MSTP(52)=1
62209C...ISR
62210 PARP(62)=1D0
62211 PARP(64)=1D0
62212 PARP(67)=4D0
62213C...FSR
62214 PARP(71)=4D0
62215 PARJ(81)=0.29D0
62216C...UE
62217 MSTP(81)=11
62218 PARP(82)=2.25D0
62219 PARP(89)=1800D0
62220 PARP(90)=0.25D0
62221C... ExpOfPow(1.8) overlap profile
62222 MSTP(82)=5
62223 PARP(83)=1.8D0
62224C... Valence qq
62225 MSTP(88)=0
62226C... Rap Tune
62227 MSTP(89)=1
62228C... Default diquark, BR-g-BR supp
62229 PARP(79)=2D0
62230 PARP(80)=0.01D0
62231C... Final state reconnect.
62232 MSTP(95)=1
62233 PARP(78)=0.55D0
62234C...Fragmentation functions and c and b parameters
62235 MSTJ(11)=4
62236 PARJ(54)=-0.05
62237 PARJ(55)=-0.005
62238C... Output
62239 IF (M13.GE.1) THEN
62240 WRITE(M11,5030) ' '
62241 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62242 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62243 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62244 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62245 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62246 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62247 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62248 WRITE(M11,5030) CH60
62249 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62250 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62251 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62252 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62253 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62254 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62255 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62256 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62257 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62258 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62259 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62260 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62261 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62262 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62263 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62264 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62265 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62266 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62267 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62268 IF (MSTJ(11).LE.3) THEN
62269 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62270 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62271 ELSE
62272 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62273 ENDIF
62274 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62275 ENDIF
62276
62277C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
62278C...Old model for ISR and UE, new pT-ordered model for FSR
62279 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
62280 & .ITUNE.EQ.226) THEN
62281 IF (M13.GE.1) THEN
62282 WRITE(M11,5010) ITUNE, CHNAME
62283 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
62284 WRITE(M11,5030) CH60
62285 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
62286 WRITE(M11,5030) CH60
62287 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62288 WRITE(M11,5030) CH60
62289 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
62290 WRITE(M11,5030) CH60
62291 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
62292 CH60='LEP parameters tuned by Professor'
62293 WRITE(M11,5030) CH60
62294 ENDIF
62295 ENDIF
62296 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
62297 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62298 & ' with tune.')
62299 ENDIF
62300C...First set as if Pythia tune A
62301C...Multiple interactions on, old framework
62302 MSTP(81)=1
62303C...Fast IR cutoff energy scaling by default
62304 PARP(89)=1800D0
62305 PARP(90)=0.25D0
62306C...Default CTEQ5L (internal)
62307 MSTP(51)=7
62308 MSTP(52)=1
62309C...Double Gaussian matter distribution.
62310 MSTP(82)=4
62311 PARP(83)=0.5D0
62312 PARP(84)=0.4D0
62313C...FSR activity.
62314 PARP(71)=4D0
62315c...String drawing almost completely minimizes string length.
62316 PARP(85)=0.9D0
62317 PARP(86)=0.95D0
62318C...ISR cutoff, muR scale factor, and phase space size
62319 PARP(62)=1D0
62320 PARP(64)=1D0
62321 PARP(67)=4D0
62322C...Intrinsic kT, size, and max
62323 MSTP(91)=1
62324 PARP(91)=1D0
62325 PARP(93)=5D0
62326C...Use 2 GeV of primordial kT for "Perugia" version
62327 IF (ITUNE.EQ.221) THEN
62328 PARP(91)=2D0
62329 PARP(93)=10D0
62330 ENDIF
62331C...Use pT-ordered FSR
62332 MSTJ(41)=12
62333C...Lambda_FSR scale for pT-ordering
62334 PARJ(81)=0.23D0
62335C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
62336 PARP(82)=2.05D0
62337C...Fragmentation functions and c and b parameters
62338C...(overwritten for 211, i.e., if using Professor pars)
62339 PARJ(54)=-0.05
62340 PARJ(55)=-0.005
62341
62342C...Use Professor's LEP pars if ITUNE == 211, 221, 226
62343 IF (ITUNE.LT.210) THEN
62344C...# Old defaults
62345 MSTJ(11) = 4
62346C...# Old default flavour parameters
62347 PARJ(21) = 0.36
62348 PARJ(41) = 0.30
62349 PARJ(42) = 0.58
62350 PARJ(46) = 1.0
62351 PARJ(82) = 1.0
62352 ELSE
62353C...# Tuned flavour parameters:
62354 PARJ(1) = 0.073
62355 PARJ(2) = 0.2
62356 PARJ(3) = 0.94
62357 PARJ(4) = 0.032
62358 PARJ(11) = 0.31
62359 PARJ(12) = 0.4
62360 PARJ(13) = 0.54
62361 PARJ(25) = 0.63
62362 PARJ(26) = 0.12
62363C...# Always use pT-ordered shower:
62364 MSTJ(41) = 12
62365C...# Switch on Bowler:
62366 MSTJ(11) = 5
62367C...# Fragmentation
62368 PARJ(21) = 3.1327e-01
62369 PARJ(41) = 4.8989e-01
62370 PARJ(42) = 1.2018e+00
62371 PARJ(47) = 1.0000e+00
62372 PARJ(81) = 2.5696e-01
62373 PARJ(82) = 8.0000e-01
62374 ENDIF
62375
62376C...221, 226 : Perugia-APT and Perugia-APT6
62377 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
62378
62379 PARP(64)=0.5D0
62380 PARP(82)=2.05D0
62381 PARP(90)=0.26D0
62382 PARP(91)=2.0D0
62383C...The Perugia variants use Steve's showers off the old MPI
62384 MSTP(152)=1
62385C...And use a lower PARP(71) as suggested by Professor tunings
62386C...(although not certain that applies to Q2-pT2 hybrid)
62387 PARP(71)=2.5D0
62388
62389C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
62390 IF (ITUNE.EQ.226) THEN
62391 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
62392 & 'externally linked'
62393 WRITE(M11,5035) CH70
62394 MSTP(52)=2
62395 MSTP(51)=10042
62396 PARP(82)=1.95D0
62397 ENDIF
62398
62399 ENDIF
62400
62401C... Output
62402 IF (M13.GE.1) THEN
62403 WRITE(M11,5030) ' '
62404 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62405 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62406 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62407 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62408 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62409 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62410 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62411 WRITE(M11,5030) CH60
62412 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
62413 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62414 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62415 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62416 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62417 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62418 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62419 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62420 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62421 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62422 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
62423 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
62424 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62425 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62426 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62427 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
62428 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
62429 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
62430 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62431 IF (MSTJ(11).LE.3) THEN
62432 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
62433 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
62434 ELSE
62435 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
62436 ENDIF
62437 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
62438 ENDIF
62439
62440C======================================================================
62441C...Uppsala models: Generalized Area Law and Soft Colour Interactions
62442 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
62443 IF (M13.GE.1) THEN
62444 WRITE(M11,5010) ITUNE, CHNAME
62445 CH60='see J. Rathsman, PLB452(1999)364'
62446 WRITE(M11,5030) CH60
62447C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
62448C ? WRITE(M11,5030)
62449 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62450 WRITE(M11,5030) CH60
62451 WRITE(M11,5030) ' '
62452 CH70='NB! The GAL model must be run with modified '//
62453 & 'Pythia v6.215:'
62454 WRITE(M11,5035) CH70
62455 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62456 WRITE(M11,5035) CH70
62457 WRITE(M11,5030) ' '
62458 ENDIF
62459C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
62460 MSWI(2) = 3
62461 PARSCI(2) = 0.10
62462 MSWI(1) = 2
62463 PARSCI(1) = 0.44
62464 MSTJ(16) = 0
62465 PARJ(42) = 0.45
62466 PARJ(82) = 2.0
62467 PARP(62) = 2.0
62468 MSTP(81) = 1
62469 MSTP(82) = 1
62470 PARP(81) = 1.9
62471 MSTP(92) = 1
62472 IF(CHNAME.EQ.'GAL Tune 1') THEN
62473C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
62474 MSTP(82)=4
62475 PARP(83)=0.25D0
62476 PARP(84)=0.5D0
62477 PARP(82) = 1.75
62478 IF (M13.GE.1) THEN
62479 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62480 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62481 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62482 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62483 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62484 ENDIF
62485 ELSE
62486 IF (M13.GE.1) THEN
62487 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62488 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62489 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62490 ENDIF
62491 ENDIF
62492C...Output
62493 IF (M13.GE.1) THEN
62494 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62495 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62496 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62497 CH40='FSI SCI/GAL selection'
62498 WRITE(M11,6040) 1, MSWI(1), CH40
62499 CH40='FSI SCI/GAL sea quark treatment'
62500 WRITE(M11,6040) 2, MSWI(2), CH40
62501 CH40='FSI SCI/GAL sea quark treatment parm'
62502 WRITE(M11,6050) 1, PARSCI(1), CH40
62503 CH40='FSI SCI/GAL string reco probability R_0'
62504 WRITE(M11,6050) 2, PARSCI(2), CH40
62505 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
62506 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62507 ENDIF
62508 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
62509 IF (M13.GE.1) THEN
62510 WRITE(M11,5010) ITUNE, CHNAME
62511 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
62512 WRITE(M11,5030) CH60
62513 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
62514 WRITE(M11,5030) CH60
62515 WRITE(M11,5030) ' '
62516 CH70='NB! The SCI model must be run with modified '//
62517 & 'Pythia v6.215:'
62518 WRITE(M11,5035) CH70
62519 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
62520 WRITE(M11,5035) CH70
62521 WRITE(M11,5030) ' '
62522 ENDIF
62523C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
62524 MSTP(81)=1
62525 MSTP(82)=1
62526 PARP(81)=2.2
62527 MSTP(92)=1
62528 MSWI(2)=2
62529 PARSCI(2)=0.50
62530 MSWI(1)=2
62531 PARSCI(1)=0.44
62532 MSTJ(16)=0
62533 IF (CHNAME.EQ.'SCI Tune 1') THEN
62534C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
62535 MSTP(81) = 1
62536 MSTP(82) = 3
62537 PARP(82) = 2.4
62538 PARP(83) = 0.5D0
62539 PARP(62) = 1.5
62540 PARP(84)=0.25D0
62541 IF (M13.GE.1) THEN
62542 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62543 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62544 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62545 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62546 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62547 ENDIF
62548 ELSE
62549 IF (M13.GE.1) THEN
62550 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62551 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
62552 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62553 ENDIF
62554 ENDIF
62555C...Output
62556 IF (M13.GE.1) THEN
62557 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
62558 CH40='FSI SCI/GAL selection'
62559 WRITE(M11,6040) 1, MSWI(1), CH40
62560 CH40='FSI SCI/GAL sea quark treatment'
62561 WRITE(M11,6040) 2, MSWI(2), CH40
62562 CH40='FSI SCI/GAL sea quark treatment parm'
62563 WRITE(M11,6050) 1, PARSCI(1), CH40
62564 CH40='FSI SCI/GAL string reco probability R_0'
62565 WRITE(M11,6050) 2, PARSCI(2), CH40
62566 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
62567 ENDIF
62568
62569 ELSE
62570 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
62571
62572 ENDIF
62573
62574 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
62575
62576 9999 RETURN
62577
62578 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE v',A6,' : ',
62579 & 'Presets for underlying-event (and min-bias)',13x,'*'/' *',
62580 & 20x,'Last Change : ',A8,' - P. Skands',22x,'*'/' *',76x,'*')
62581 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
62582 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
62583 5030 FORMAT(' *',3x,10x,A60,3x,'*')
62584 5035 FORMAT(' *',3x,A70,3x,'*')
62585 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
62586 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
62587 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
62588 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
62589 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
62590 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
62591 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
62592 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
62593 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
62594
62595 END
62596
62597C*********************************************************************
62598
62599C...PYEXEC
62600C...Administrates the fragmentation and decay chain.
62601
62602 SUBROUTINE PYEXEC
62603
62604C...Double precision and integer declarations.
62605 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62606 IMPLICIT INTEGER(I-N)
62607 INTEGER PYK,PYCHGE,PYCOMP
62608C...Commonblocks.
62609 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62610 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62611 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62612 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62613 COMMON/PYINT1/MINT(400),VINT(400)
62614 COMMON/PYINT4/MWID(500),WIDS(500,5)
62615 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
62616C...Local array.
62617 DIMENSION PS(2,6),IJOIN(100)
62618
62619C...Initialize and reset.
62620 MSTU(24)=0
62621 IF(MSTU(12).NE.12345) CALL PYLIST(0)
62622 MSTU(29)=0
62623 MSTU(31)=MSTU(31)+1
62624 MSTU(1)=0
62625 MSTU(2)=0
62626 MSTU(3)=0
62627 IF(MSTU(17).LE.0) MSTU(90)=0
62628 MCONS=1
62629
62630C...Sum up momentum, energy and charge for starting entries.
62631 NSAV=N
62632 DO 110 I=1,2
62633 DO 100 J=1,6
62634 PS(I,J)=0D0
62635 100 CONTINUE
62636 110 CONTINUE
62637 DO 130 I=1,N
62638 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
62639 DO 120 J=1,4
62640 PS(1,J)=PS(1,J)+P(I,J)
62641 120 CONTINUE
62642 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
62643 130 CONTINUE
62644 PARU(21)=PS(1,4)
62645
62646C...Start by all decays of coloured resonances involved in shower.
62647 NORIG=N
62648 DO 140 I=1,NORIG
62649 IF(K(I,1).EQ.3) THEN
62650 KC=PYCOMP(K(I,2))
62651 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
62652 ENDIF
62653 140 CONTINUE
62654
62655C...Prepare system for subsequent fragmentation/decay.
62656 CALL PYPREP(0)
62657 IF(MINT(51).NE.0) RETURN
62658
62659C...Loop through jet fragmentation and particle decays.
62660 MBE=0
62661 150 MBE=MBE+1
62662 IP=0
62663 160 IP=IP+1
62664 KC=0
62665 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
62666 IF(KC.EQ.0) THEN
62667
62668C...Deal with any remaining undecayed resonance
62669C...(normally the task of PYEVNT, so seldom used).
62670 ELSEIF(MWID(KC).NE.0) THEN
62671 IBEG=IP
62672 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
62673 IBEG=IP+1
62674 170 IBEG=IBEG-1
62675 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
62676 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
62677 IEND=IP-1
62678 180 IEND=IEND+1
62679 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
62680 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
62681 NJOIN=0
62682 DO 190 I=IBEG,IEND
62683 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
62684 NJOIN=NJOIN+1
62685 IJOIN(NJOIN)=I
62686 ENDIF
62687 190 CONTINUE
62688 ENDIF
62689 CALL PYRESD(IP)
62690 CALL PYPREP(IBEG)
62691 IF(MINT(51).NE.0) RETURN
62692
62693C...Particle decay if unstable and allowed. Save long-lived particle
62694C...decays until second pass after Bose-Einstein effects.
62695 ELSEIF(KCHG(KC,2).EQ.0) THEN
62696 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
62697 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
62698 & CALL PYDECY(IP)
62699
62700C...Decay products may develop a shower.
62701 IF(MSTJ(92).GT.0) THEN
62702 IP1=MSTJ(92)
62703 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
62704 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
62705 MINT(33)=0
62706 CALL PYSHOW(IP1,IP1+1,QMAX)
62707 CALL PYPREP(IP1)
62708 IF(MINT(51).NE.0) RETURN
62709 MSTJ(92)=0
62710 ELSEIF(MSTJ(92).LT.0) THEN
62711 IP1=-MSTJ(92)
62712 MINT(33)=0
62713 CALL PYSHOW(IP1,-3,P(IP,5))
62714 CALL PYPREP(IP1)
62715 IF(MINT(51).NE.0) RETURN
62716 MSTJ(92)=0
62717 ENDIF
62718
62719C...Jet fragmentation: string or independent fragmentation.
62720 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
62721 MFRAG=MSTJ(1)
62722 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
62723 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
62724 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
62725 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
62726 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
62727 ENDIF
62728 ENDIF
62729 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
62730 IF(MFRAG.EQ.2) CALL PYINDF(IP)
62731 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
62732 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
62733 ENDIF
62734
62735C...Loop back if enough space left in PYJETS and no error abort.
62736 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
62737 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
62738 GOTO 160
62739 ELSEIF(IP.LT.N) THEN
62740 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
62741 ENDIF
62742
62743C...Include simple Bose-Einstein effect parametrization if desired.
62744 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
62745 CALL PYBOEI(NSAV)
62746 GOTO 150
62747 ENDIF
62748
62749C...Check that momentum, energy and charge were conserved.
62750 DO 210 I=1,N
62751 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
62752 DO 200 J=1,4
62753 PS(2,J)=PS(2,J)+P(I,J)
62754 200 CONTINUE
62755 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
62756 210 CONTINUE
62757 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
62758 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
62759 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
62760 &'(PYEXEC:) four-momentum was not conserved')
62761 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
62762 &'(PYEXEC:) charge was not conserved')
62763
62764 RETURN
62765 END
62766
62767C*********************************************************************
62768
62769C...PYPREP
62770C...Rearranges partons along strings.
62771C...Special considerations for systems with junctions, with
62772C...possibility of junction-antijunction annihilation.
62773C...Allows small systems to collapse into one or two particles.
62774C...Checks flavours and colour singlet invariant masses.
62775
62776 SUBROUTINE PYPREP(IP)
62777
62778C...Double precision and integer declarations.
62779 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
62780 INTEGER PYK,PYCHGE,PYCOMP
62781C...Commonblocks.
62782 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
62783 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
62784 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
62785 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
62786 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
62787 COMMON/PYINT1/MINT(400),VINT(400)
62788C...The common block of colour tags.
62789 COMMON/PYCTAG/NCT,MCT(4000,2)
62790 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
62791 &/PYPARS/
62792 DATA NERRPR/0/
62793 SAVE NERRPR
62794C...Local arrays.
62795 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
62796 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
62797 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
62798 &IJCP(0:6),TJUOLD(5)
62799 CHARACTER CHTMP*6
62800
62801C...Function to give four-product.
62802 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)
62803
62804C...Rearrange parton shower product listing along strings: begin loop.
62805 MSTU(24)=0
62806 NOLD=N
62807 I1=N
62808 NJUNC=0
62809 NPIECE=0
62810 NJJSTR=0
62811 MSTU32=MSTU(32)+1
62812 DO 100 I=MAX(1,IP),N
62813C...First store junction positions.
62814 IF(K(I,1).EQ.42) THEN
62815 NJUNC=NJUNC+1
62816 IJUNC(NJUNC,0)=I
62817 IJUNC(NJUNC,4)=0
62818 ENDIF
62819 100 CONTINUE
62820
62821 DO 250 MQGST=1,3
62822 DO 240 I=MAX(1,IP),N
62823C...Special treatment for junctions
62824 IF (K(I,1).LE.0) GOTO 240
62825 IF(K(I,1).EQ.42) THEN
62826C...MQGST=2: Look for junction-junction strings (not detected in the
62827C...main search below).
62828 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
62829 IF (NJJSTR.EQ.0) THEN
62830 NJJSTR = (3*NJUNC-NPIECE)/2
62831 ENDIF
62832C...Check how many already identified strings end on this junction
62833 ILC=0
62834 DO 110 J=1,NPIECE
62835 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
62836 110 CONTINUE
62837C...If less than 3, remaining must be to another junction
62838 IF (ILC.LT.3) THEN
62839 IF (ILC.NE.2) THEN
62840C...Multiple j-j connections not handled yet.
62841 CALL PYERRM(2,
62842 & '(PYPREP:) Too many junction-junction strings.')
62843 MINT(51)=1
62844 RETURN
62845 ENDIF
62846C...The colour information in the junction is unreadable for the
62847C...colour space search further down in this routine, so we must
62848C...start on the colour mother of this junction and then "artificially"
62849C...prevent the colour mother from connecting here again.
62850 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
62851 KCS=4
62852 IF (MOD(ITJUNC,2).EQ.0) KCS=5
62853C...Switch colour if the junction-junction leg is presumably a
62854C...junction mother leg rather than a junction daughter leg.
62855 IF (ITJUNC.GE.3) KCS=9-KCS
62856 IF (MINT(33).EQ.0) THEN
62857C...Find the unconnected leg and reorder junction daughter pointers so
62858C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
62859C...piece.
62860 IA=MOD(K(I,4),MSTU(5))
62861 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
62862 ITMP=MOD(K(I,5),MSTU(5))
62863 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
62864 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
62865 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
62866 ELSE
62867 K(I,5)=K(I,5)+(IA-ITMP)
62868 ENDIF
62869 K(I,4)=K(I,4)+(ITMP-IA)
62870 IA=ITMP
62871 ENDIF
62872 IF (ITJUNC.LE.2) THEN
62873C...Beam baryon junction
62874 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
62875 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
62876C...Else 1 -> 2 decay junction
62877 ELSE
62878 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
62879 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
62880 ENDIF
62881 I1BEG = I1
62882 NSTP = 0
62883 GOTO 170
62884C...Alternatively use colour tag information.
62885 ELSE
62886C...Find a final state parton with appropriate dangling colour tag.
62887 JCT=0
62888 IA=0
62889 IJUMO=K(I,3)
62890 DO 140 J1=MAX(1,IP),N
62891 IF (K(J1,1).NE.3) GOTO 140
62892C...Check for matching final-state colour tag
62893 IMATCH=0
62894 DO 120 J2=MAX(1,IP),N
62895 IF (K(J2,1).NE.3) GOTO 120
62896 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
62897 120 CONTINUE
62898 IF (IMATCH.EQ.1) GOTO 140
62899C...Check whether this colour tag belongs to the present junction
62900C...by seeing whether any parton with this colour tag has the same
62901C...mother as the junction.
62902 JCT=MCT(J1,KCS-3)
62903 IMATCH=0
62904 DO 130 J2=MINT(84)+1,N
62905 IMO2=K(J2,3)
62906C...First scattering partons have IMO1 = 3 and 4.
62907 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
62908 & IMO2=IMO2-2
62909 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
62910 & IMATCH=1
62911 130 CONTINUE
62912 IF (IMATCH.EQ.0) GOTO 140
62913 IA=J1
62914 140 CONTINUE
62915C...Check for junction-junction strings without intermediate final state
62916C...glue (not detected above).
62917 IF (IA.EQ.0) THEN
62918 DO 160 MJU=1,NJUNC
62919 IJU2=IJUNC(MJU,0)
62920 IF (IJU2.EQ.I) GOTO 160
62921 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
62922C...Only opposite types of junctions can connect to each other.
62923 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
62924 IS=0
62925 DO 150 J=1,NPIECE
62926 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
62927 150 CONTINUE
62928 IF (IS.EQ.3) GOTO 160
62929 IB=I
62930 IA=IJU2
62931 160 CONTINUE
62932 ENDIF
62933C...Switch to other side of adjacent parton and step from there.
62934 KCS=9-KCS
62935 I1BEG = I1
62936 NSTP = 0
62937 GOTO 170
62938 ENDIF
62939 ELSE IF (ILC.NE.3) THEN
62940 ENDIF
62941 ENDIF
62942 ENDIF
62943
62944C...Look for coloured string endpoint, or (later) leftover gluon.
62945 IF(K(I,1).NE.3) GOTO 240
62946 KC=PYCOMP(K(I,2))
62947 IF(KC.EQ.0) GOTO 240
62948 KQ=KCHG(KC,2)
62949 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
62950
62951C...Pick up loose string end.
62952 KCS=4
62953 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
62954 IA=I
62955 IB=I
62956 I1BEG=I1
62957 NSTP=0
62958 170 NSTP=NSTP+1
62959 IF(NSTP.GT.4*N) THEN
62960 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
62961 MINT(51)=1
62962 RETURN
62963 ENDIF
62964
62965C...Copy undecayed parton. Finished if reached string endpoint.
62966 IF(K(IA,1).EQ.3) THEN
62967 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
62968 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62969 MINT(51)=1
62970 MSTU(24)=1
62971 RETURN
62972 ENDIF
62973 I1=I1+1
62974 K(I1,1)=2
62975 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
62976 K(I1,2)=K(IA,2)
62977 K(I1,3)=IA
62978 K(I1,4)=0
62979 K(I1,5)=0
62980 DO 180 J=1,5
62981 P(I1,J)=P(IA,J)
62982 V(I1,J)=V(IA,J)
62983 180 CONTINUE
62984 K(IA,1)=K(IA,1)+10
62985 IF(K(I1,1).EQ.1) GOTO 240
62986 ENDIF
62987
62988C...Also finished (for now) if reached junction; then copy to end.
62989 IF(K(IA,1).EQ.42) THEN
62990 NCOPY=I1-I1BEG
62991 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
62992 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
62993 MINT(51)=1
62994 MSTU(24)=1
62995 RETURN
62996 ENDIF
62997 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
62998 DO 200 ICOPY=1,NCOPY
62999 DO 190 J=1,5
63000 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
63001 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
63002 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
63003 190 CONTINUE
63004 200 CONTINUE
63005 ENDIF
63006C...For junction-junction strings, find end leg and reorder junction
63007C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
63008C...junction-junction string piece.
63009 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
63010 ITMP=MOD(K(IA,4),MSTU(5))
63011 IF (ITMP.NE.IB) THEN
63012 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
63013 K(IA,5)=K(IA,5)+(ITMP-IB)
63014 ELSE
63015 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
63016 ENDIF
63017 K(IA,4)=K(IA,4)+(IB-ITMP)
63018 ENDIF
63019 ENDIF
63020 NPIECE=NPIECE+1
63021C...IPIECE:
63022C...0: endpoint in original ER
63023C...1:
63024C...2:
63025C...3: Parton immediately next to junction
63026C...4: Junction
63027 IPIECE(NPIECE,0)=I
63028 IPIECE(NPIECE,1)=MSTU32+1
63029 IPIECE(NPIECE,2)=MSTU32+NCOPY
63030 IPIECE(NPIECE,3)=IB
63031 IPIECE(NPIECE,4)=IA
63032 MSTU32=MSTU32+NCOPY
63033 I1=I1BEG
63034 GOTO 240
63035 ENDIF
63036
63037C...GOTO next parton in colour space.
63038 IB=IA
63039 IF (MINT(33).EQ.0) THEN
63040 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
63041 & )).NE.0) THEN
63042 IA=MOD(K(IB,KCS),MSTU(5))
63043 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
63044 MREV=0
63045 ELSE
63046 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
63047 & MSTU(5)).EQ.0) KCS=9-KCS
63048 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
63049 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
63050 MREV=1
63051 ENDIF
63052 IF(IA.LE.0.OR.IA.GT.N) THEN
63053 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
63054 IF(NERRPR.LT.5) THEN
63055 NERRPR=NERRPR+1
63056 WRITE(MSTU(11),*) 'started at:', I
63057 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
63058 WRITE(MSTU(11),*) 'MQGST =',MQGST
63059 CALL PYLIST(4)
63060 ENDIF
63061 MINT(51)=1
63062 RETURN
63063 ENDIF
63064 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
63065 & ,MSTU(5)).EQ.IB) THEN
63066 IF(MREV.EQ.1) KCS=9-KCS
63067 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
63068 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
63069 ELSE
63070 IF(MREV.EQ.0) KCS=9-KCS
63071 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
63072 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
63073 ENDIF
63074 IF(IA.NE.I) GOTO 170
63075C...Use colour tag information
63076 ELSE
63077C...First create colour tags starting on IB if none already present.
63078 IF (MCT(IB,KCS-3).EQ.0) THEN
63079 CALL PYCTTR(IB,KCS,IB)
63080 IF(MINT(51).NE.0) RETURN
63081 ENDIF
63082 JCT=MCT(IB,KCS-3)
63083 IFOUND=0
63084C...Find final state tag partner
63085 DO 210 IT=MAX(1,IP),N
63086 IF (IT.EQ.IB) GOTO 210
63087 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
63088 & .0) THEN
63089 IFOUND=IFOUND+1
63090 IA=IT
63091 ENDIF
63092 210 CONTINUE
63093C...Just copy and goto next if exactly one partner found.
63094 IF (IFOUND.EQ.1) THEN
63095 GOTO 170
63096C...When no match found, match is presumably junction.
63097 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
63098C...Check whether this colour tag matches a junction
63099C...by seeing whether any parton with this colour tag has the same
63100C...mother as a junction.
63101C...NB: Only type 1 and 2 junctions handled presently.
63102 DO 230 IJU=1,NJUNC
63103 IJUMO=K(IJUNC(IJU,0),3)
63104 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
63105C...Colours only connect to junctions, anti-colours to antijunctions:
63106 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
63107 IMATCH=0
63108 DO 220 J1=MAX(1,IP),N
63109 IF (K(J1,1).LE.0) GOTO 220
63110C...First scattering partons have IMO1 = 3 and 4.
63111 IMO=K(J1,3)
63112 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
63113 & IMO=IMO-2
63114 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
63115 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
63116 & IMATCH=1
63117C...Attempt at handling type > 3 junctions also. Not tested.
63118 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
63119 & .IJUMO) IMATCH=1
63120 220 CONTINUE
63121 IF (IMATCH.EQ.0) GOTO 230
63122 IA=IJUNC(IJU,0)
63123 IFOUND=IFOUND+1
63124 230 CONTINUE
63125
63126 IF (IFOUND.EQ.1) THEN
63127 GOTO 170
63128 ELSEIF (IFOUND.EQ.0) THEN
63129 WRITE(CHTMP,*) JCT
63130 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
63131 & //CHTMP)
63132 IF(NERRPR.LT.5) THEN
63133 NERRPR=NERRPR+1
63134 CALL PYLIST(4)
63135 ENDIF
63136 MINT(51)=1
63137 RETURN
63138 ENDIF
63139 ELSEIF (IFOUND.GE.2) THEN
63140 WRITE(CHTMP,*) JCT
63141 CALL PYERRM(12
63142 & ,'(PYPREP:) too many occurences of colour line: '//
63143 & CHTMP)
63144 IF(NERRPR.LT.5) THEN
63145 NERRPR=NERRPR+1
63146 CALL PYLIST(4)
63147 ENDIF
63148 MINT(51)=1
63149 RETURN
63150 ENDIF
63151 ENDIF
63152 K(I1,1)=1
63153 240 CONTINUE
63154 250 CONTINUE
63155
63156C...Junction systems remain.
63157 IJU=0
63158 IJUS=0
63159 IJUCNT=0
63160 MREV=0
63161 IJJSTR=0
63162 260 IJUCNT=IJUCNT+1
63163 IF (IJUCNT.LE.NJUNC) THEN
63164C...If we are not processing a j-j string, treat this junction as new.
63165 IF (IJJSTR.EQ.0) THEN
63166 IJU=IJUNC(IJUCNT,0)
63167 MREV=0
63168C...If junction has already been read, ignore it.
63169 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
63170C...If we are on a j-j string, goto second j-j junction.
63171 ELSE
63172 IJUCNT=IJUCNT-1
63173 IJU=IJUS
63174 ENDIF
63175C...Mark selected junction read.
63176 DO 270 J=1,NJUNC
63177 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
63178 270 CONTINUE
63179C...Determine junction type
63180 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
63181C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
63182C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
63183C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
63184 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
63185 IHK=0
63186 280 IHK=IHK+1
63187C...Find which quarks belong to given junction.
63188 IHF=0
63189 DO 290 IPC=1,NPIECE
63190 IF (IPIECE(IPC,4).EQ.IJU) THEN
63191 IHF=IHF+1
63192 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
63193 ENDIF
63194 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
63195 290 CONTINUE
63196C...IHK = 3 is special. Either normal string piece, or j-j string.
63197 IF(IHK.EQ.3) THEN
63198 IF (MREV.NE.1) THEN
63199 DO 300 IPC=1,NPIECE
63200C...If there is a j-j string starting on the present junction which has
63201C...zero length, insert next junction immediately.
63202 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
63203 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
63204 IJJSTR = 1
63205 GOTO 340
63206 ENDIF
63207 300 CONTINUE
63208 MREV = 1
63209C...If MREV is 1 and IHK is 3 we are finished with this system.
63210 ELSE
63211 MREV=0
63212 GOTO 260
63213 ENDIF
63214 ENDIF
63215
63216C...If we've gotten this far, then either IHK < 3, or
63217C...an interjunction string exists, or just a third normal string.
63218 IJUNC(IJUCNT,IHK)=0
63219 IJJSTR = 0
63220C..Order pieces belonging to this junction. Also look for j-j.
63221 DO 310 IPC=1,NPIECE
63222 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
63223 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
63224 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
63225 IJUNC(IJUCNT,IHK)=IPC
63226 IJJSTR = 1
63227 MREV = 0
63228 ENDIF
63229 310 CONTINUE
63230C...Copy back chains in proper order. MREV=0/1 : descending/ascending
63231 IPC=IJUNC(IJUCNT,IHK)
63232C...Temporary solution to cover for bug.
63233 IF(IPC.LE.0) THEN
63234 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
63235 MINT(51)=1
63236 RETURN
63237 ENDIF
63238 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
63239 I1=I1+1
63240 DO 320 J=1,5
63241 K(I1,J)=K(MSTU(4)-ICP,J)
63242 P(I1,J)=P(MSTU(4)-ICP,J)
63243 V(I1,J)=V(MSTU(4)-ICP,J)
63244 320 CONTINUE
63245 330 CONTINUE
63246 K(I1,1)=2
63247C...Mark last quark.
63248 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
63249C...Do not insert junctions at wrong places.
63250 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
63251C...Insert junction.
63252 340 IJUS = IJU
63253 IF (IHK.EQ.3) THEN
63254C...Shift to end junction if a j-j string has been processed.
63255 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
63256 MREV= 1
63257 ENDIF
63258 I1=I1+1
63259 DO 350 J=1,5
63260 K(I1,J)=0
63261 P(I1,J)=0.
63262 V(I1,J)=0.
63263 350 CONTINUE
63264 K(I1,1)=41
63265 K(IJUS,1)=K(IJUS,1)+10
63266 K(I1,2)=K(IJUS,2)
63267 K(I1,3)=IJUS
63268 360 IF (IHK.LT.3) GOTO 280
63269 ELSE
63270 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
63271 MINT(51)=1
63272 RETURN
63273 ENDIF
63274 IF (IJUCNT.NE.NJUNC) GOTO 260
63275 ENDIF
63276 N=I1
63277
63278C...Rearrange three strings from junction, e.g. in case one has been
63279C...shortened by shower, so the last is the largest-energy one.
63280 IF(NJUNC.GE.1) THEN
63281C...Find systems with exactly one junction.
63282 MJUN1=0
63283 NBEG=NOLD+1
63284 DO 470 I=NOLD+1,N
63285 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
63286 ELSEIF(K(I,1).EQ.41) THEN
63287 MJUN1=MJUN1+1
63288 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
63289 MJUN1=0
63290 NBEG=I+1
63291 ELSE
63292 NEND=I
63293C...Sum up energy-momentum in each junction string.
63294 DO 370 J=1,5
63295 PJU(1,J)=0D0
63296 PJU(2,J)=0D0
63297 PJU(3,J)=0D0
63298 370 CONTINUE
63299 NJU=0
63300 DO 390 I1=NBEG,NEND
63301 IF(K(I1,2).NE.21) THEN
63302 NJU=NJU+1
63303 IJUR(NJU)=I1
63304 ENDIF
63305 DO 380 J=1,5
63306 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
63307 380 CONTINUE
63308 390 CONTINUE
63309C...Find which of them has highest energy (minus mass) in rest frame.
63310 DO 400 J=1,5
63311 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
63312 400 CONTINUE
63313 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
63314 & PJU(4,3)**2))
63315 DO 410 I2=1,3
63316 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
63317 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
63318 410 CONTINUE
63319 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
63320C...Decide how to rearrange so that new last has highest energy.
63321 IF(PJU(1,6).LT.PJU(2,6)) THEN
63322 IRNG(1,1)=IJUR(1)
63323 IRNG(1,2)=IJUR(2)-1
63324 IRNG(2,1)=IJUR(4)
63325 IRNG(2,2)=IJUR(3)+1
63326 IRNG(4,1)=IJUR(3)-1
63327 IRNG(4,2)=IJUR(2)
63328 ELSE
63329 IRNG(1,1)=IJUR(4)
63330 IRNG(1,2)=IJUR(3)+1
63331 IRNG(2,1)=IJUR(2)
63332 IRNG(2,2)=IJUR(3)-1
63333 IRNG(4,1)=IJUR(2)-1
63334 IRNG(4,2)=IJUR(1)
63335 ENDIF
63336 IRNG(3,1)=IJUR(3)
63337 IRNG(3,2)=IJUR(3)
63338C...Copy in correct order below bottom of current event record.
63339 I2=N
63340 DO 440 II=1,4
63341 DO 430 I1=IRNG(II,1),IRNG(II,2),
63342 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
63343 I2=I2+1
63344 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
63345 CALL PYERRM(11,
63346 & '(PYPREP:) no more memory left in PYJETS')
63347 MINT(51)=1
63348 MSTU(24)=1
63349 RETURN
63350 ENDIF
63351 DO 420 J=1,5
63352 K(I2,J)=K(I1,J)
63353 P(I2,J)=P(I1,J)
63354 V(I2,J)=V(I1,J)
63355 420 CONTINUE
63356 IF(K(I2,1).EQ.1) K(I2,1)=2
63357 430 CONTINUE
63358 440 CONTINUE
63359 K(I2,1)=1
63360C...Copy back up, overwriting but now in correct order.
63361 DO 460 I1=NBEG,NEND
63362 I2=I1-NBEG+N+1
63363 DO 450 J=1,5
63364 K(I1,J)=K(I2,J)
63365 P(I1,J)=P(I2,J)
63366 V(I1,J)=V(I2,J)
63367 450 CONTINUE
63368 460 CONTINUE
63369 ENDIF
63370 MJUN1=0
63371 NBEG=I+1
63372 ENDIF
63373 470 CONTINUE
63374
63375C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
63376C...to two q-qbar systems.
63377C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
63378 IF (MSTJ(19).NE.1) THEN
63379 MJUN1 = 0
63380 JJGLUE = 0
63381 NBEG = NOLD+1
63382C...Force collapse when MSTJ(19)=2.
63383 IF (MSTJ(19).EQ.2) THEN
63384 DELMJJ = 1D9
63385 DELMQQ = 0D0
63386 ENDIF
63387C...Find systems with exactly two junctions.
63388 DO 700 I=NOLD+1,N
63389C...Count junctions
63390 IF (K(I,1).EQ.41) THEN
63391 MJUN1 = MJUN1+1
63392C...Check for interjunction gluons
63393 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
63394 JJGLUE = 1
63395 ENDIF
63396 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
63397C...If end of system reached with either zero or one junction, restart
63398C...with next system.
63399 MJUN1 = 0
63400 JJGLUE = 0
63401 NBEG = I+1
63402 ELSEIF(K(I,1).EQ.1) THEN
63403C...If end of system reached with exactly two junctions, compute string
63404C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
63405C...length measure for the (q-qbar)(q-qbar) topology.
63406 NEND=I
63407C...Loop down through chain.
63408 ISID=0
63409 DO 480 I1=NBEG,NEND
63410C...Store string piece division locations in event record
63411 IF (K(I1,2).NE.21) THEN
63412 ISID = ISID+1
63413 IJCP(ISID) = I1
63414 ENDIF
63415 480 CONTINUE
63416C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
63417 ISW=0
63418 IF (PYR(0).LT.0.5D0) ISW=1
63419C...Randomly choose which qqbar string gets the jj gluons.
63420 IGS=1
63421 IF (PYR(0).GT.0.5D0) IGS=2
63422C...Only compute string lengths when no topology forced.
63423 IF (MSTJ(19).EQ.0) THEN
63424C...Repeat following for each junction
63425 DO 570 IJU=1,2
63426C...Initialize iterative procedure for finding JRF
63427 IJRFIT=0
63428 DO 490 IX=1,3
63429 TJUOLD(IX)=0D0
63430 490 CONTINUE
63431 TJUOLD(4)=1D0
63432C...Start iteration. Sum up momenta in string pieces
63433 500 DO 540 IJS=1,3
63434C...JD=-1 for first junction, +1 for second junction.
63435C...Find out where piece starts and ends and which direction to go.
63436 JD=2*IJU-3
63437 IF (IJS.LE.2) THEN
63438 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
63439 IB = IJCP((IJU-1)*7 - JD*IJS)
63440 ELSEIF (IJS.EQ.3) THEN
63441 JD =-JD
63442 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
63443 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
63444 ENDIF
63445C...Initialize junction pull 4-vector.
63446 DO 510 J=1,5
63447 PUL(IJS,J)=0D0
63448 510 CONTINUE
63449C...Initialize weight
63450 PWT = 0D0
63451 PWTOLD = 0D0
63452C...Sum up (weighted) momenta along each string piece
63453 DO 530 ISP=IA,IB,JD
63454C...If present parton not last in chain
63455 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
63456C...If last parton was a junction, store present weight
63457 IF (K(ISP-JD,2).EQ.88) THEN
63458 PWTOLD = PWT
63459C...If last parton was a quark, reset to stored weight.
63460 ELSEIF (K(ISP-JD,2).NE.21) THEN
63461 PWT = PWTOLD
63462 ENDIF
63463 ENDIF
63464C...Skip next parton if weight already large
63465 IF (PWT.GT.10D0) GOTO 530
63466C...Compute momentum in TJUOLD frame:
63467 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
63468 & )*P(ISP,3)
63469 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
63470 DO 520 J=1,3
63471 TMP=P(ISP,J)+TJUOLD(J)*BFC
63472 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
63473 520 CONTINUE
63474C...Boosted energy
63475 TMP=TJUOLD(4)*P(ISP,4)+TDP
63476 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
63477C...Update weight
63478 PWT=PWT+TMP/PARJ(48)
63479C...Put |p| rather than m in 5th slot
63480 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
63481 & +PUL(IJS,3)**2)
63482 530 CONTINUE
63483 540 CONTINUE
63484C...Compute boost
63485 IJRFIT=IJRFIT+1
63486 CALL PYJURF(PUL,T)
63487C...Combine new boost (T) with old boost (TJUOLD)
63488 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
63489 DO 550 IX=1,3
63490 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
63491 & ))
63492 550 CONTINUE
63493 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
63494 & **2)
63495C...If last boost small, accept JRF, else iterate.
63496C...Also prevent possibility of infinite loop.
63497 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
63498 & IJRFIT.LT.MSTJ(18))THEN
63499 GOTO 500
63500 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
63501 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
63502 ENDIF
63503C...Store final boost, with change of sign since TJJ motion vector.
63504 DO 560 IX=1,3
63505 TJJ(IJU,IX)=-TJUOLD(IX)
63506 560 CONTINUE
63507 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
63508 & +TJJ(IJU,3)**2)
63509 570 CONTINUE
63510C...String length measure for (q-qbar)(q-qbar) topology.
63511C...Note only momenta of nearest partons used (since rest of system
63512C...identical).
63513 IF (JJGLUE.EQ.0) THEN
63514 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
63515 & -1,IJCP(5-ISW)+1)
63516 ELSE
63517C...Put jj gluons on selected string (IGS selected randomly above).
63518 IF (IGS.EQ.1) THEN
63519 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63520 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
63521 ELSE
63522 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
63523 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
63524 & ,IJCP(5-ISW)+1)
63525 ENDIF
63526 ENDIF
63527C...String length measure for q-q-j-j-q-q topology.
63528 T1G1=0D0
63529 T2G2=0D0
63530 T1T2=0D0
63531 T1P1=0D0
63532 T1P2=0D0
63533 T2P3=0D0
63534 T2P4=0D0
63535 ISGN=-1
63536C...Note only momenta of nearest partons used (since rest of system
63537C...identical).
63538 DO 580 IX=1,4
63539 IF (IX.EQ.4) ISGN=1
63540 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
63541 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
63542 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
63543 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
63544 IF (JJGLUE.EQ.0) THEN
63545C...Junction motion vector dot product gives length when inter-junction
63546C...gluons absent.
63547 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
63548 ELSE
63549C...Junction motion vector dot products with gluon momenta give length
63550C...when inter-junction gluons present.
63551 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
63552 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
63553 ENDIF
63554 580 CONTINUE
63555 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
63556 IF (JJGLUE.EQ.0) THEN
63557 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
63558 ELSE
63559 DELMJJ=DELMJJ*4D0*T1G1*T2G2
63560 ENDIF
63561 ENDIF
63562C...If delmjj > delmqq collapse string system to q-qbar q-qbar
63563C...(Always the case for MSTJ(19)=2 due to initialization above)
63564 IF (DELMJJ.GT.DELMQQ) THEN
63565C...Put new system at end of event record
63566 NCOP=N
63567 DO 650 IST=1,2
63568 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
63569 NCOP=NCOP+1
63570 DO 590 IX=1,5
63571 P(NCOP,IX)=P(ICOP,IX)
63572 K(NCOP,IX)=K(ICOP,IX)
63573 590 CONTINUE
63574 600 CONTINUE
63575 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
63576C...Insert inter-junction gluon string piece (reversed)
63577 NJJGL=0
63578 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
63579 NJJGL=NJJGL+1
63580 NCOP=NCOP+1
63581 DO 610 IX=1,5
63582 P(NCOP,IX)=P(ICOP,IX)
63583 K(NCOP,IX)=K(ICOP,IX)
63584 610 CONTINUE
63585 620 CONTINUE
63586 ENDIF
63587 IFC=-2*IST+3
63588 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
63589 NCOP=NCOP+1
63590 DO 630 IX=1,5
63591 P(NCOP,IX)=P(ICOP,IX)
63592 K(NCOP,IX)=K(ICOP,IX)
63593 630 CONTINUE
63594 640 CONTINUE
63595 K(NCOP,1)=1
63596 650 CONTINUE
63597C...Copy system back in right order
63598 DO 670 ICOP=NBEG,NEND-2
63599 DO 660 IX=1,5
63600 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
63601 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
63602 660 CONTINUE
63603 670 CONTINUE
63604C...Shift down rest of event record
63605 DO 690 ICOP=NEND+1,N
63606 DO 680 IX=1,5
63607 P(ICOP-2,IX)=P(ICOP,IX)
63608 K(ICOP-2,IX)=K(ICOP,IX)
63609 680 CONTINUE
63610 690 CONTINUE
63611C...Update length of event record.
63612 N=N-2
63613 ENDIF
63614 MJUN1=0
63615 NBEG=I+1
63616 ENDIF
63617 700 CONTINUE
63618 ENDIF
63619 ENDIF
63620
63621C...Done if no checks on small-mass systems.
63622 IF(MSTJ(14).LT.0) RETURN
63623 IF(MSTJ(14).EQ.0) GOTO 1140
63624
63625C...Find lowest-mass colour singlet jet system.
63626 NS=N
63627 710 NSIN=N-NS
63628 PDMIN=1D0+PARJ(32)
63629 IC=0
63630 DO 770 I=MAX(1,IP),N
63631 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
63632 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
63633 NSIN=NSIN+1
63634 IC=I
63635 DO 720 J=1,4
63636 DPS(J)=P(I,J)
63637 720 CONTINUE
63638 MSTJ(93)=1
63639 DPS(5)=PYMASS(K(I,2))
63640 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
63641 DO 730 J=1,4
63642 DPS(J)=DPS(J)+P(I,J)
63643 730 CONTINUE
63644 MSTJ(93)=1
63645 DPS(5)=DPS(5)+PYMASS(K(I,2))
63646 ELSEIF(K(I,1).EQ.2) THEN
63647 DO 740 J=1,4
63648 DPS(J)=DPS(J)+P(I,J)
63649 740 CONTINUE
63650 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63651 DO 750 J=1,4
63652 DPS(J)=DPS(J)+P(I,J)
63653 750 CONTINUE
63654 MSTJ(93)=1
63655 DPS(5)=DPS(5)+PYMASS(K(I,2))
63656 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
63657 & DPS(5)
63658 IF(PD.LT.PDMIN) THEN
63659 PDMIN=PD
63660 DO 760 J=1,5
63661 DPC(J)=DPS(J)
63662 760 CONTINUE
63663 IC1=IC
63664 IC2=I
63665 ENDIF
63666 IC=0
63667 ELSE
63668 NSIN=NSIN+1
63669 ENDIF
63670 770 CONTINUE
63671
63672C...Done if lowest-mass system above threshold for string frag.
63673 IF(PDMIN.GE.PARJ(32)) GOTO 1140
63674
63675C...Fill small-mass system as cluster.
63676 NSAV=N
63677 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
63678 K(N+1,1)=11
63679 K(N+1,2)=91
63680 K(N+1,3)=IC1
63681 P(N+1,1)=DPC(1)
63682 P(N+1,2)=DPC(2)
63683 P(N+1,3)=DPC(3)
63684 P(N+1,4)=DPC(4)
63685 P(N+1,5)=PECM
63686
63687C...Set up history, assuming cluster -> 2 hadrons.
63688 NBODY=2
63689 K(N+1,4)=N+2
63690 K(N+1,5)=N+3
63691 K(N+2,1)=1
63692 K(N+3,1)=1
63693 IF(MSTU(16).NE.2) THEN
63694 K(N+2,3)=N+1
63695 K(N+3,3)=N+1
63696 ELSE
63697 K(N+2,3)=IC1
63698 K(N+3,3)=IC2
63699 ENDIF
63700 K(N+2,4)=0
63701 K(N+3,4)=0
63702 K(N+2,5)=0
63703 K(N+3,5)=0
63704 V(N+1,5)=0D0
63705 V(N+2,5)=0D0
63706 V(N+3,5)=0D0
63707
63708C...Find total flavour content - complicated by presence of junctions.
63709 NQ=0
63710 NDIQ=0
63711 DO 780 I=IC1,IC2
63712 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
63713 NQ=NQ+1
63714 KFQ(NQ)=K(I,2)
63715 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
63716 ENDIF
63717 780 CONTINUE
63718
63719C...If several diquarks, split up one to give even number of flavours.
63720 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
63721 I1=3
63722 IF(IABS(KFQ(3)).LT.1000) I1=1
63723 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
63724 KFQ(I1)=KFQ(I1)/1000
63725 NQ=4
63726 NDIQ=NDIQ-1
63727 ENDIF
63728
63729C...If four quark ends, join two to diquark.
63730 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
63731 I1=1
63732 I2=2
63733 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
63734 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
63735 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63736 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63737 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63738 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63739 KFQ(I2)=KFQ(4)
63740 NQ=3
63741 NDIQ=1
63742 ENDIF
63743
63744C...If two quark ends, plus quark or diquark, join quarks to diquark.
63745 IF(NQ.EQ.3) THEN
63746 I1=1
63747 I2=2
63748 IF(IABS(KFQ(I1)).GT.1000) I1=3
63749 IF(IABS(KFQ(I2)).GT.1000) I2=3
63750 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
63751 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
63752 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
63753 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
63754 KFQ(I2)=KFQ(3)
63755 NQ=2
63756 NDIQ=NDIQ+1
63757 ENDIF
63758
63759C...Form two particles from flavours of lowest-mass system, if feasible.
63760 NTRY = 0
63761 790 NTRY = NTRY + 1
63762
63763C...Open string with two specified endpoint flavours.
63764 IF(NQ.EQ.2) THEN
63765 KC1=PYCOMP(KFQ(1))
63766 KC2=PYCOMP(KFQ(2))
63767 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
63768 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63769 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63770 IF(KQ1+KQ2.NE.0) GOTO 1140
63771C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
63772 800 K1=KFQ(1)
63773 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
63774 MSTU(125)=0
63775 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
63776 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
63777 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
63778
63779C...Open string with four specified flavours.
63780 ELSEIF(NQ.EQ.4) THEN
63781 KC1=PYCOMP(KFQ(1))
63782 KC2=PYCOMP(KFQ(2))
63783 KC3=PYCOMP(KFQ(3))
63784 KC4=PYCOMP(KFQ(4))
63785 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
63786 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
63787 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
63788 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
63789 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
63790 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
63791C...Combine flavours pairwise to form two hadrons.
63792 810 I1=1
63793 I2=2
63794 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63795 & IABS(KFQ(2)).GT.1000)) I2=3
63796 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
63797 & IABS(KFQ(3)).GT.1000))) I2=4
63798 I3=3
63799 IF(I2.EQ.3) I3=2
63800 I4=10-I1-I2-I3
63801 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
63802 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
63803 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
63804
63805C...Closed string.
63806 ELSE
63807 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
63808C...No room for popcorn mesons in closed string -> 2 hadrons.
63809 MSTU(125)=0
63810 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
63811 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
63812 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
63813 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
63814 ENDIF
63815 P(N+2,5)=PYMASS(K(N+2,2))
63816 P(N+3,5)=PYMASS(K(N+3,2))
63817
63818C...If it does not work: try again (a number of times), give up (if no
63819C...place to shuffle momentum or too many flavours), or form one hadron.
63820 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
63821 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
63822 GOTO 790
63823 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
63824 GOTO 1140
63825 ELSE
63826 GOTO 890
63827 END IF
63828 END IF
63829
63830C...Perform two-particle decay of jet system.
63831C...First step: find reference axis in decaying system rest frame.
63832C...(Borrow slot N+2 for temporary direction.)
63833 DO 830 J=1,4
63834 P(N+2,J)=P(IC1,J)
63835 830 CONTINUE
63836 DO 850 I=IC1+1,IC2-1
63837 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
63838 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
63be39ca 63839 IF (ABS(FOUR(IC1,I)+FOUR(IC2,I)).GT.0.D0) THEN
63840 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
63841 ELSE
63842 FRAC1 = 1.D0
63843 ENDIF
02626a96 63844 DO 840 J=1,4
63845 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
63846 840 CONTINUE
63847 ENDIF
63848 850 CONTINUE
63849 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
63850 &-DPC(3)/DPC(4))
63851 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
63852 PHI1=PYANGL(P(N+2,1),P(N+2,2))
63853
63854C...Second step: generate isotropic/anisotropic decay.
63855 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
63856 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
63857 860 UE(3)=PYR(0)
63858 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
63859 PT2=(1D0-UE(3)**2)*PA**2
63860 IF(MSTJ(16).LE.0) THEN
63861 PREV=0.5D0
63862 ELSE
63863 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
63864 PR1=P(N+2,5)**2+PT2
63865 PR2=P(N+3,5)**2+PT2
63866 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
63867 PREVCF=PARJ(42)
63868 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
63869 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
63870 ENDIF
63871 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
63872 PHI=PARU(2)*PYR(0)
63873 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
63874 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
63875 DO 870 J=1,3
63876 P(N+2,J)=PA*UE(J)
63877 P(N+3,J)=-PA*UE(J)
63878 870 CONTINUE
63879 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
63880 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
63881
63882C...Third step: move back to event frame and set production vertex.
63883 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
63884 &DPC(3)/DPC(4))
63885 DO 880 J=1,4
63886 V(N+1,J)=V(IC1,J)
63887 V(N+2,J)=V(IC1,J)
63888 V(N+3,J)=V(IC2,J)
63889 880 CONTINUE
63890 N=N+3
63891 GOTO 1120
63892
63893C...Else form one particle, if possible.
63894 890 NBODY=1
63895 K(N+1,5)=N+2
63896 DO 900 J=1,4
63897 V(N+1,J)=V(IC1,J)
63898 V(N+2,J)=V(IC1,J)
63899 900 CONTINUE
63900
63901C...Select hadron flavour from available quark flavours.
63902 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
63903 GOTO 1140
63904 ELSEIF(NQ.EQ.2) THEN
63905 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
63906 ELSE
63907 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
63908 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
63909 ENDIF
63910 IF(K(N+2,2).EQ.0) GOTO 910
63911 P(N+2,5)=PYMASS(K(N+2,2))
63912
63913C...Use old algorithm for E/p conservation? (EN)
63914 IF (MSTJ(16).LE.0) GOTO 1080
63915
63916C...Find the string piece closest to the cluster by a loop
63917C...over the undecayed partons not in present cluster. (EN)
63918 DGLOMI=1D30
63919 IBEG=0
63920 I0=0
63921 NJUNC=0
63922 DO 940 I1=MAX(1,IP),N-1
63923 IF(K(I1,1).EQ.1) NJUNC=0
63924 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
63925 IF(K(I1,1).EQ.41) GOTO 940
63926 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
63927 I0=0
63928 ELSEIF(K(I1,1).EQ.2) THEN
63929 IF(I0.EQ.0) I0=I1
63930 I2=I1
63931 920 I2=I2+1
63932 IF(K(I2,1).EQ.41) GOTO 940
63933 IF(K(I2,1).GT.10) GOTO 920
63934 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
63935 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
63936 & NJUNC.EQ.0) GOTO 940
63937 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
63938 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
63939 & K(I2,1).NE.1)) GOTO 940
63940
63941C...Define velocity vectors e1, e2, ecl and differences e3, e4.
63942 DO 930 J=1,3
63943 E1(J)=P(I1,J)/P(I1,4)
63944 E2(J)=P(I2,J)/P(I2,4)
63945 ECL(J)=P(N+1,J)/P(N+1,4)
63946 E3(J)=E2(J)-E1(J)
63947 E4(J)=ECL(J)-E1(J)
63948 930 CONTINUE
63949
63950C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
63951 E3S=E3(1)**2+E3(2)**2+E3(3)**2
63952 E4S=E4(1)**2+E4(2)**2+E4(3)**2
63953 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
63954 IF(E34.LE.0D0) THEN
63955 DDMIN=E4S
63956 ELSEIF(E34.LT.E3S) THEN
63957 DDMIN=E4S-E34**2/E3S
63958 ELSE
63959 DDMIN=E4S-2D0*E34+E3S
63960 ENDIF
63961
63962C...Is this the smallest so far?
63963 IF(DDMIN.LT.DGLOMI) THEN
63964 DGLOMI=DDMIN
63965 IBEG=I0
63966 IPCS=I1
63967 ENDIF
63968 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
63969 I0=0
63970 ENDIF
63971 940 CONTINUE
63972
63973C... Check if there are any strings to connect to the new gluon. (EN)
63974 IF (IBEG.EQ.0) GOTO 1080
63975
63976C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
63977 IF (P(N+1,5).GE.P(N+2,5)) THEN
63978
63979C...Construct 'gluon' that is needed to put hadron on the mass shell.
63980 FRAC=P(N+2,5)/P(N+1,5)
63981 DO 950 J=1,5
63982 P(N+2,J)=FRAC*P(N+1,J)
63983 PG(J)=(1D0-FRAC)*P(N+1,J)
63984 950 CONTINUE
63985
63986C... Copy string with new gluon put in.
63987 N=N+2
63988 I=IBEG-1
63989 960 I=I+1
63990 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
63991 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
63992 N=N+1
63993 DO 970 J=1,5
63994 K(N,J)=K(I,J)
63995 P(N,J)=P(I,J)
63996 V(N,J)=V(I,J)
63997 970 CONTINUE
63998 K(I,1)=K(I,1)+10
63999 K(I,4)=N
64000 K(I,5)=N
64001 K(N,3)=I
64002 IF(I.EQ.IPCS) THEN
64003 N=N+1
64004 DO 980 J=1,5
64005 K(N,J)=K(N-1,J)
64006 P(N,J)=PG(J)
64007 V(N,J)=V(N-1,J)
64008 980 CONTINUE
64009 K(N,2)=21
64010 K(N,3)=NSAV+1
64011 ENDIF
64012 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
64013 GOTO 1120
64014
64015C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
64016C...from string piece endpoints.
64017 ELSE
64018
64019C...Begin by copying string that should give energy to cluster.
64020 N=N+2
64021 I=IBEG-1
64022 990 I=I+1
64023 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
64024 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
64025 N=N+1
64026 DO 1000 J=1,5
64027 K(N,J)=K(I,J)
64028 P(N,J)=P(I,J)
64029 V(N,J)=V(I,J)
64030 1000 CONTINUE
64031 K(I,1)=K(I,1)+10
64032 K(I,4)=N
64033 K(I,5)=N
64034 K(N,3)=I
64035 IF(I.EQ.IPCS) I1=N
64036 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
64037 I2=I1+1
64038
64039C...Set initial Phad.
64040 DO 1010 J=1,4
64041 P(NSAV+2,J)=P(NSAV+1,J)
64042 1010 CONTINUE
64043
64044C...Calculate Pg, a part of which will be added to Phad later. (EN)
64045 1020 IF(MSTJ(16).EQ.1) THEN
64046 ALPHA=1D0
64047 BETA=1D0
64048 ELSE
63be39ca 64049 IF (ABS(FOUR(I1,I2)).GT.0.D0) THEN
64050 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
64051 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
64052 ELSE
64053 ALPHA=1D0
64054 BETA=1D0
64055 ENDIF
02626a96 64056 ENDIF
64057 DO 1030 J=1,4
64058 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
64059 1030 CONTINUE
64060 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
64061
64062C..Solve 2nd order equation, use the best (smallest) solution. (EN)
64063 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
64064 & P(NSAV+2,3)**2
64065 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
64066 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
64067 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
64068
64069C...If all gluon energy eaten, zero it and take a step back.
64070 ITER=0
64071 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
64072 ITER=1
64073 DO 1040 J=1,4
64074 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
64075 P(I1,J)=0D0
64076 1040 CONTINUE
64077 P(I1,5)=0D0
64078 K(I1,1)=K(I1,1)+10
64079 I1=I1-1
64080 IF(K(I1,1).EQ.41) ITER=-1
64081 ENDIF
64082 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
64083 ITER=1
64084 DO 1050 J=1,4
64085 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
64086 P(I2,J)=0D0
64087 1050 CONTINUE
64088 P(I2,5)=0D0
64089 K(I2,1)=K(I2,1)+10
64090 I2=I2+1
64091 IF(K(I2,1).EQ.41) ITER=-1
64092 ENDIF
64093 IF(ITER.EQ.1) GOTO 1020
64094
64095C...If also all endpoint energy eaten, revert to old procedure.
64096 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
64097 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
64098 DO 1060 I=NSAV+3,N
64099 IM=K(I,3)
64100 K(IM,1)=K(IM,1)-10
64101 K(IM,4)=0
64102 K(IM,5)=0
64103 1060 CONTINUE
64104 N=NSAV
64105 GOTO 1080
64106 ENDIF
64107
64108C... Construct the collapsed hadron and modified string partons.
64109 DO 1070 J=1,4
64110 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
64111 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
64112 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
64113 1070 CONTINUE
64114 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
64115 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
64116
64117C...Finished with string collapse in new scheme.
64118 GOTO 1120
64119 ENDIF
64120
64121C... Use old algorithm; by choice or when in trouble.
64122 1080 CONTINUE
64123C...Find parton/particle which combines to largest extra mass.
64124 IR=0
64125 HA=0D0
64126 HSM=0D0
64127 DO 1100 MCOMB=1,3
64128 IF(IR.NE.0) GOTO 1100
64129 DO 1090 I=MAX(1,IP),N
64130 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
64131 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
64132 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
64133 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
64134 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
64135 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
64136 & GOTO 1090
64137 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
64138 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
64139 IF(HSR.GT.HSM) THEN
64140 IR=I
64141 HA=HCR
64142 HSM=HSR
64143 ENDIF
64144 1090 CONTINUE
64145 1100 CONTINUE
64146
64147C...Shuffle energy and momentum to put new particle on mass shell.
64148 IF(IR.NE.0) THEN
64149 HB=PECM**2+HA
64150 HC=P(N+2,5)**2+HA
64151 HD=P(IR,5)**2+HA
64152 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
64153 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
64154 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
64155 DO 1110 J=1,4
64156 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
64157 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
64158 1110 CONTINUE
64159 N=N+2
64160 ELSE
64161 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
64162 RETURN
64163 ENDIF
64164
64165C...Mark collapsed system and store daughter pointers. Iterate.
64166 1120 DO 1130 I=IC1,IC2
64167 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
64168 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
64169 K(I,1)=K(I,1)+10
64170 IF(MSTU(16).NE.2) THEN
64171 K(I,4)=NSAV+1
64172 K(I,5)=NSAV+1
64173 ELSE
64174 K(I,4)=NSAV+2
64175 K(I,5)=NSAV+1+NBODY
64176 ENDIF
64177 ENDIF
64178 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
64179 1130 CONTINUE
64180 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
64181
64182C...Check flavours and invariant masses in parton systems.
64183 1140 NP=0
64184 KFN=0
64185 KQS=0
64186 NJU=0
64187 DO 1150 J=1,5
64188 DPS(J)=0D0
64189 1150 CONTINUE
64190 DO 1180 I=MAX(1,IP),N
64191 IF(K(I,1).EQ.41) NJU=NJU+1
64192 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
64193 KC=PYCOMP(K(I,2))
64194 IF(KC.EQ.0) GOTO 1180
64195 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64196 IF(KQ.EQ.0) GOTO 1180
64197 NP=NP+1
64198 IF(KQ.NE.2) THEN
64199 KFN=KFN+1
64200 KQS=KQS+KQ
64201 MSTJ(93)=1
64202 DPS(5)=DPS(5)+PYMASS(K(I,2))
64203 ENDIF
64204 DO 1160 J=1,4
64205 DPS(J)=DPS(J)+P(I,J)
64206 1160 CONTINUE
64207 IF(K(I,1).EQ.1) THEN
64208 NFERR=0
64209 IF(NJU.EQ.0.AND.NP.NE.1) THEN
64210 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
64211 ELSEIF(NJU.EQ.1) THEN
64212 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
64213 ELSEIF(NJU.EQ.2) THEN
64214 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
64215 ELSEIF(NJU.GE.3) THEN
64216 NFERR=1
64217 ENDIF
64218 IF(NFERR.EQ.1) THEN
64219 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
64220 MINT(51)=1
64221 RETURN
64222 ENDIF
64223 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
64224 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
64225 & '(PYPREP:) too small mass in jet system')
64226 NP=0
64227 KFN=0
64228 KQS=0
64229 NJU=0
64230 DO 1170 J=1,5
64231 DPS(J)=0D0
64232 1170 CONTINUE
64233 ENDIF
64234 1180 CONTINUE
64235
64236 RETURN
64237 END
64238
64239C*********************************************************************
64240
64241C...PYSTRF
64242C...Handles the fragmentation of an arbitrary colour singlet
64243C...jet system according to the Lund string fragmentation model.
64244
64245 SUBROUTINE PYSTRF(IP)
64246
64247C...Double precision and integer declarations.
64248 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64249 IMPLICIT INTEGER(I-N)
64250 INTEGER PYK,PYCHGE,PYCOMP
64251C...Commonblocks.
64252 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64253 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64254 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64255 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
64256C...Local arrays. All MOPS variables ends with MO
64257 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
64258 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
64259 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
64260 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
64261 &PBST(3,5),TJUOLD(5)
64262
64263C...Function: four-product of two vectors.
64264 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)
64265 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
64266 &DP(I,3)*DP(J,3)
64267
64268C...Reset counters.
64269 MSTJ(91)=0
64270 NSAV=N
64271 MSTU90=MSTU(90)
64272 NP=0
64273 KQSUM=0
64274 DO 100 J=1,5
64275 DPS(J)=0D0
64276 100 CONTINUE
64277 MJU(1)=0
64278 MJU(2)=0
64279 NTRYFN=0
64280 IJUORI(1)=0
64281 IJUORI(2)=0
64282
64283C...Identify parton system.
64284 I=IP-1
64285 110 I=I+1
64286 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
64287 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
64288 IF(MSTU(21).GE.1) RETURN
64289 ENDIF
64290 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
64291 KC=PYCOMP(K(I,2))
64292 IF(KC.EQ.0) GOTO 110
64293 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
64294 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
64295 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
64296 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64297 IF(MSTU(21).GE.1) RETURN
64298 ENDIF
64299
64300C...Take copy of partons to be considered. Check flavour sum.
64301 NP=NP+1
64302 DO 120 J=1,5
64303 K(N+NP,J)=K(I,J)
64304 P(N+NP,J)=P(I,J)
64305 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
64306 120 CONTINUE
64307 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
64308 K(N+NP,3)=I
64309 IF(KQ.NE.2) KQSUM=KQSUM+KQ
64310 IF(K(I,1).EQ.41) THEN
64311 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
64312 MJU(1)=N+NP
64313 IJUORI(1)=I
64314 ELSE
64315 MJU(2)=N+NP
64316 IJUORI(2)=I
64317 ENDIF
64318 ENDIF
64319 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
64320 IF(MOD(KQSUM,3).NE.0) THEN
64321 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
64322 IF(MSTU(21).GE.1) RETURN
64323 ENDIF
64324 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
64325
64326C...Boost copied system to CM frame (for better numerical precision).
64327 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
64328 MBST=0
64329 MSTU(33)=1
64330 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
64331 & -DPS(3)/DPS(4))
64332 ELSE
64333 MBST=1
64334 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
64335 DO 130 I=N+1,N+NP
64336 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
64337 IF(P(I,3).GT.0D0) THEN
64338 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
64339 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
64340 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64341 ELSE
64342 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
64343 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
64344 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
64345 ENDIF
64346 130 CONTINUE
64347 ENDIF
64348
64349C...Search for very nearby partons that may be recombined.
64350 NTRYR=0
64351 NTRYWR=0
64352 PARU12=PARU(12)
64353 PARU13=PARU(13)
64354 MJU(3)=MJU(1)
64355 MJU(4)=MJU(2)
64356 NR=NP
64357 NRMIN=2
64358 IF(MJU(1).GT.0) NRMIN=NRMIN+2
64359 IF(MJU(2).GT.0) NRMIN=NRMIN+2
64360 140 IF(NR.GT.NRMIN) THEN
64361 PDRMIN=2D0*PARU12
64362 DO 150 I=N+1,N+NR
64363 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
64364 I1=I+1
64365 IF(I.EQ.N+NR) I1=N+1
64366 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
64367 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
64368 & GOTO 150
64369 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
64370 & GOTO 150
64371 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
64372 & P(I1,2)**2+P(I1,3)**2))
64373 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
64374 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
64375 IF(PDR.LT.PDRMIN) THEN
64376 IR=I
64377 PDRMIN=PDR
64378 ENDIF
64379 150 CONTINUE
64380
64381C...Recombine very nearby partons to avoid machine precision problems.
64382 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
64383 DO 160 J=1,4
64384 P(N+1,J)=P(N+1,J)+P(N+NR,J)
64385 160 CONTINUE
64386 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
64387 & P(N+1,3)**2))
64388 NR=NR-1
64389 GOTO 140
64390 ELSEIF(PDRMIN.LT.PARU12) THEN
64391 DO 170 J=1,4
64392 P(IR,J)=P(IR,J)+P(IR+1,J)
64393 170 CONTINUE
64394 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
64395 & P(IR,3)**2))
64396 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
64397 DO 190 I=IR+1,N+NR-1
64398 K(I,1)=K(I+1,1)
64399 K(I,2)=K(I+1,2)
64400 DO 180 J=1,5
64401 P(I,J)=P(I+1,J)
64402 180 CONTINUE
64403 190 CONTINUE
64404 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
64405 NR=NR-1
64406 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
64407 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
64408 GOTO 140
64409 ENDIF
64410 ENDIF
64411 NTRYR=NTRYR+1
64412
64413C...Reset particle counter. Skip ahead if no junctions are present;
64414C...this is usually the case!
64415 NRS=MAX(5*NR+11,NP)
64416 NTRY=0
64417 200 NTRY=NTRY+1
64418 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64419 PARU12=4D0*PARU12
64420 PARU13=2D0*PARU13
64421 GOTO 140
64422 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
64423 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64424 IF(MSTU(21).GE.1) RETURN
64425 ENDIF
64426 I=N+NRS
64427 MSTU(90)=MSTU90
64428 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
64429 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
64430 & ' junction strings not handled by MSTJ(12)>3 options')
64431 DO 640 JT=1,2
64432 NJS(JT)=0
64433 IF(MJU(JT).EQ.0) GOTO 640
64434 JS=3-2*JT
64435
64436C++SKANDS
64437C...Find and sum up momentum on three sides of junction.
64438C...Begin with previous boost = zero.
64439 IJRFIT=0
64440 DO 210 IX=1,3
64441 TJUOLD(IX)=0D0
64442 210 CONTINUE
64443C...Prevent IJU (specifically IJU(5)) from containing junk below
64444 DO 215 IU=1,6
64445 IJU(IU)=0
64446 215 CONTINUE
64447 TJUOLD(4)=1D0
64448 220 IU=0
64449C...Beginning and end of string system in event record.
64450 I1BEG=N+1+(JT-1)*(NR-1)
64451 I1END=N+NR+(JT-1)*(1-NR)
64452C...Look for junction string piece end points
64453 DO 230 I1=I1BEG,I1END,JS
64454 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
64455C...Store junction string piece end points.
64456C 1-junction systems 2-junction systems
64457C IU : 1 2 3 4 1 2 3 4 5 6
64458C 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
64459 IU=IU+1
64460 IJU(IU)=I1
64461 ENDIF
64462C...Sum over momenta, from junction outwards.
64463 230 CONTINUE
64464 DO 280 IU=1,3
64465 PWT=0D0
64466C...Initialize junction drag and string piece 4-vectors.
64467 DO 240 J=1,5
64468 PBST(IU,J)=0D0
64469 PJU(IU,J)=0D0
64470 240 CONTINUE
64471C...First two branches. Inwards out means opposite direction to JS.
64472C...(JS is 1 for JT=1, -1 for JT=2)
64473 IF (IU.LT.3) THEN
64474 I1A=IJU(IU+1)-JS
64475 I1B=IJU(IU)
64476 IDIR=-JS
64477C...Last branch (gq or gjgqgq). Direction now reversed.
64478 ELSE
64479 I1A=IJU(IU)+JS
64480 I1B=I1END
64481 IDIR=JS
64482 ENDIF
64483 DO 270 I1=I1A,I1B,IDIR
64484C...Sum up momentum directions with exponential suppression
64485C...for use in finding junction rest frame below.
64486 IF (K(I1,2).EQ.88) THEN
64487C...gjgqgq type system encountered. Use current PWT as start
64488C...for both strings.
64489 PWTOLD=PWT
64490 ELSE
64491 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
64492C...Sum up string piece (boosted) 4-momenta.
64493 DO 250 J=1,4
64494 PJU(IU,J)=PJU(IU,J)+P(I1,J)
64495 250 CONTINUE
64496C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
64497C...boost is zero, see above). Skip parton if suppression factor large.
64498 IF (PWT.GT.10D0) GOTO 270
64499C...Compute momentum in current frame:
64500 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
64501 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
64502 DO 260 J=1,3
64503 PTMP=P(I1,J)+TJUOLD(J)*BFC
64504 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
64505 260 CONTINUE
64506C...Boosted energy
64507 PTMP=TJUOLD(4)*P(I1,4)+TDP
64508 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
64509 PWT=PWT+PTMP/PARJ(48)
64510 ENDIF
64511 270 CONTINUE
64512C...Put |p| rather than m in 5th slot.
64513 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
64514 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
64515 280 CONTINUE
64516
64517C...Calculate boost from present frame to next JRF candidate.
64518 IJRFIT=IJRFIT+1
64519 CALL PYJURF(PBST,TJU)
64520
64521C...After some iterations do not take full step in new direction.
64522 IF(IJRFIT.GT.5) THEN
64523 REDUCE=0.8D0**(IJRFIT-5)
64524 TJU(1)=REDUCE*TJU(1)
64525 TJU(2)=REDUCE*TJU(2)
64526 TJU(3)=REDUCE*TJU(3)
64527 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64528 ENDIF
64529
64530C...Combine new boost (TJU) with old boost (TJUOLD)
64531 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
64532 DO 290 IX=1,3
64533 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
64534 290 CONTINUE
64535 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
64536
64537C...If last boost small, accept JRF, else iterate.
64538C...Also prevent possibility of infinite loop.
64539 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
64540 & IJRFIT.LT.MSTJ(18)) THEN
64541 GOTO 220
64542 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
64543 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
64544 ENDIF
64545
64546C...Now store total boost in TJU and change perception.
64547C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
64548C...TJU = junction motion vector in string CM, so the sign changes.
64549 DO 300 J=1,3
64550 TJU(J)=-TJUOLD(J)
64551 300 CONTINUE
64552 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
64553
64554C--SKANDS
64555
64556C...Calculate string piece energies in junction rest frame.
64557 DO 310 IU=1,3
64558 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
64559 & TJU(3)*PJU(IU,3)
64560 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
64561 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
64562 310 CONTINUE
64563
64564C...Start preparing for fragmentation of two strings from junction.
64565 ISTA=I
64566 NTRYER=0
64567 320 NTRYER=NTRYER+1
64568 I=ISTA
64569 DO 620 IU=1,2
64570 NS=IABS(IJU(IU+1)-IJU(IU))
64571
64572C...Junction strings: find longitudinal string directions.
64573 DO 350 IS=1,NS
64574 IS1=IJU(IU)+JS*(IS-1)
64575 IS2=IJU(IU)+JS*IS
64576 DO 330 J=1,5
64577 DP(1,J)=0.5D0*P(IS1,J)
64578 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
64579 DP(2,J)=0.5D0*P(IS2,J)
64580 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
64581 & (PJU(IU,5)/PBST(IU,5))
64582 330 CONTINUE
64583 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
64584 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
64585 DP(3,5)=DFOUR(1,1)
64586 DP(4,5)=DFOUR(2,2)
64587 DHKC=DFOUR(1,2)
64588 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
64589 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64590 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64591 DP(3,5)=0D0
64592 DP(4,5)=0D0
64593 DHKC=DFOUR(1,2)
64594 ENDIF
64595 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64596 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64597 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64598 IN1=N+NR+4*IS-3
64599 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64600 DO 340 J=1,4
64601 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64602 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64603 340 CONTINUE
64604 350 CONTINUE
64605
64606C...Junction strings: initialize flavour, momentum and starting pos.
64607 ISAV=I
64608 MSTU91=MSTU(90)
64609 360 NTRY=NTRY+1
64610 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64611 PARU12=4D0*PARU12
64612 PARU13=2D0*PARU13
64613 GOTO 140
64614 ELSEIF(NTRY.GT.100) THEN
64615 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64616 IF(MSTU(21).GE.1) RETURN
64617 ENDIF
64618 I=ISAV
64619 MSTU(90)=MSTU91
64620 IRANKJ=0
64621 IE(1)=K(N+1+(JT/2)*(NP-1),3)
64622 IF (MOD(JT+IU,2).NE.0) THEN
64623 IE(1)=K(IJU(IU),3)
64624 IF (NP-NR.NE.0) THEN
64625C...If gluons have disappeared. Original IJU must be used.
64626 IT=IP
64627 NE=1
64628 370 IT=IT+1
64629 IF (K(IT,2).NE.21) THEN
64630 NE=NE+1
64631 ENDIF
64632 IF (NE.EQ.IU+4*(JT-1)) THEN
64633 IE(1)=IT
64634 ELSEIF (IT.LE.IP+NP) THEN
64635 GOTO 370
64636 ELSE
64637 CALL PYERRM(14,'(PYSTRF:) '//
64638 & 'Original IJU could not be reconstructed!')
64639 ENDIF
64640 ENDIF
64641 ENDIF
64642 IN(4)=N+NR+1
64643 IN(5)=IN(4)+1
64644 IN(6)=N+NR+4*NS+1
64645 DO 390 JQ=1,2
64646 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
64647 P(IN1,1)=2-JQ
64648 P(IN1,2)=JQ-1
64649 P(IN1,3)=1D0
64650 380 CONTINUE
64651 390 CONTINUE
64652 KFL(1)=K(IJU(IU),2)
64653 PX(1)=0D0
64654 PY(1)=0D0
64655 GAM(1)=0D0
64656 DO 400 J=1,5
64657 PJU(IU+3,J)=0D0
64658 400 CONTINUE
64659
64660C...Junction strings: find initial transverse directions.
64661 DO 410 J=1,4
64662 DP(1,J)=P(IN(4),J)
64663 DP(2,J)=P(IN(4)+1,J)
64664 DP(3,J)=0D0
64665 DP(4,J)=0D0
64666 410 CONTINUE
64667 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64668 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64669 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64670 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64671 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64672 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64673 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64674 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64675 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64676 DHC12=DFOUR(1,2)
64677 DHCX1=DFOUR(3,1)/DHC12
64678 DHCX2=DFOUR(3,2)/DHC12
64679 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64680 DHCY1=DFOUR(4,1)/DHC12
64681 DHCY2=DFOUR(4,2)/DHC12
64682 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64683 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64684 DO 420 J=1,4
64685 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64686 P(IN(6),J)=DP(3,J)
64687 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64688 & DHCYX*DP(3,J))
64689 420 CONTINUE
64690
64691C...Junction strings: produce new particle, origin.
64692 430 I=I+1
64693 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
64694 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
64695 IF(MSTU(21).GE.1) RETURN
64696 ENDIF
64697 IRANKJ=IRANKJ+1
64698 K(I,1)=1
64699 K(I,3)=IE(1)
64700 K(I,4)=0
64701 K(I,5)=0
64702
64703C...Junction strings: generate flavour, hadron, pT, z and Gamma.
64704 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
64705 IF(K(I,2).EQ.0) GOTO 360
64706 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
64707 & IABS(KFL(3)).GT.10) THEN
64708 IF(PYR(0).GT.PARJ(19)) GOTO 440
64709 ENDIF
64710 P(I,5)=PYMASS(K(I,2))
64711 CALL PYPTDI(KFL(1),PX(3),PY(3))
64712 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
64713 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
64714 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
64715 & MSTU(90).LT.8) THEN
64716 MSTU(90)=MSTU(90)+1
64717 MSTU(90+MSTU(90))=I
64718 PARU(90+MSTU(90))=Z
64719 ENDIF
64720 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
64721 DO 450 J=1,3
64722 IN(J)=IN(3+J)
64723 450 CONTINUE
64724
64725C...Junction strings: stepping within 'low' string region.
64726 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
64727 & P(IN(1),5)**2.GE.PR(1)) THEN
64728 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
64729 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
64730 DO 460 J=1,4
64731 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
64732 460 CONTINUE
64733 GOTO 560
64734C...Has used up energy of junction string, i.e. no more hadrons in it.
64735 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
64736 DO 470 J=1,5
64737 P(I,J)=0D0
64738 470 CONTINUE
64739 GOTO 600
64740C...Stepping from 'low' string region
64741 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
64742 P(IN(2)+2,4)=P(IN(2)+2,3)
64743 P(IN(2)+2,1)=1D0
64744 IN(2)=IN(2)+4
64745 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64746 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64747 P(IN(1)+2,4)=P(IN(1)+2,3)
64748 P(IN(1)+2,1)=0D0
64749 IN(1)=IN(1)+4
64750 ENDIF
64751 ENDIF
64752
64753C...Junction strings: find new transverse directions.
64754 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
64755 & IN(1).GT.IN(2)) GOTO 360
64756 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
64757 DO 490 J=1,4
64758 DP(1,J)=P(IN(1),J)
64759 DP(2,J)=P(IN(2),J)
64760 DP(3,J)=0D0
64761 DP(4,J)=0D0
64762 490 CONTINUE
64763 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
64764 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
64765 DHC12=DFOUR(1,2)
64766 IF(DHC12.LE.1D-2) THEN
64767 P(IN(1)+2,4)=P(IN(1)+2,3)
64768 P(IN(1)+2,1)=0D0
64769 IN(1)=IN(1)+4
64770 GOTO 480
64771 ENDIF
64772 IN(3)=N+NR+4*NS+5
64773 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
64774 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
64775 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
64776 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
64777 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
64778 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
64779 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
64780 DHCX1=DFOUR(3,1)/DHC12
64781 DHCX2=DFOUR(3,2)/DHC12
64782 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
64783 DHCY1=DFOUR(4,1)/DHC12
64784 DHCY2=DFOUR(4,2)/DHC12
64785 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
64786 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
64787 DO 500 J=1,4
64788 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
64789 P(IN(3),J)=DP(3,J)
64790 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
64791 & DHCYX*DP(3,J))
64792 500 CONTINUE
64793C...Express pT with respect to new axes, if sensible.
64794 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
64795 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
64796 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
64797 PX(3)=PXP
64798 PY(3)=PYP
64799 ENDIF
64800 ENDIF
64801
64802C...Junction strings: sum up known four-momentum, coefficients for m2.
64803 DO 530 J=1,4
64804 DHG(J)=0D0
64805 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
64806 & PY(3)*P(IN(3)+1,J)
64807 DO 510 IN1=IN(4),IN(1)-4,4
64808 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
64809 510 CONTINUE
64810 DO 520 IN2=IN(5),IN(2)-4,4
64811 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
64812 520 CONTINUE
64813 530 CONTINUE
64814 DHM(1)=FOUR(I,I)
64815 DHM(2)=2D0*FOUR(I,IN(1))
64816 DHM(3)=2D0*FOUR(I,IN(2))
64817 DHM(4)=2D0*FOUR(IN(1),IN(2))
64818
64819C...Junction strings: find coefficients for Gamma expression.
64820 DO 550 IN2=IN(1)+1,IN(2),4
64821 DO 540 IN1=IN(1),IN2-1,4
64822 DHC=2D0*FOUR(IN1,IN2)
64823 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
64824 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
64825 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
64826 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
64827 540 CONTINUE
64828 550 CONTINUE
64829
64830C...Junction strings: solve (m2, Gamma) equation system for energies.
64831 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
64832 IF(ABS(DHS1).LT.1D-4) GOTO 360
64833 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
64834 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
64835 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
64836 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
64837 & ABS(DHS1)-DHS2/DHS1)
64838 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
64839 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
64840 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
64841
64842C...Junction strings: step to new region if necessary.
64843 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
64844 P(IN(2)+2,4)=P(IN(2)+2,3)
64845 P(IN(2)+2,1)=1D0
64846 IN(2)=IN(2)+4
64847 IF(IN(2).GT.N+NR+4*NS) GOTO 360
64848 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
64849 P(IN(1)+2,4)=P(IN(1)+2,3)
64850 P(IN(1)+2,1)=0D0
64851 IN(1)=IN(1)+4
64852 ENDIF
64853 GOTO 480
64854 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
64855 P(IN(1)+2,4)=P(IN(1)+2,3)
64856 P(IN(1)+2,1)=0D0
64857 IN(1)=IN(1)+4
64858 GOTO 480
64859 ENDIF
64860
64861C...Junction strings: particle four-momentum, remainder, loop back.
64862 560 DO 570 J=1,4
64863 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
64864 & P(IN(2)+2,4)*P(IN(2),J)
64865 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
64866 570 CONTINUE
64867 IF(P(I,4).LT.P(I,5)) GOTO 360
64868 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64869 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64870 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
64871 KFL(1)=-KFL(3)
64872 PX(1)=-PX(3)
64873 PY(1)=-PY(3)
64874 GAM(1)=GAM(3)
64875 IF(IN(3).NE.IN(6)) THEN
64876 DO 580 J=1,4
64877 P(IN(6),J)=P(IN(3),J)
64878 P(IN(6)+1,J)=P(IN(3)+1,J)
64879 580 CONTINUE
64880 ENDIF
64881 DO 590 JQ=1,2
64882 IN(3+JQ)=IN(JQ)
64883 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
64884 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
64885 590 CONTINUE
64886 GOTO 430
64887 ENDIF
64888
64889C...Junction strings: save quantities left after each string.
64890 IF(IABS(KFL(1)).GT.10) GOTO 360
64891 600 I=I-1
64892 KFJH(IU)=KFL(1)
64893 DO 610 J=1,4
64894 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
64895 610 CONTINUE
64896
64897C...Junction strings: loopback if much unused energy in both strings.
64898 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
64899 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
64900 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
64901 620 CONTINUE
64902 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
64903 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
64904 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
64905 & .AND.NTRYER.LT.10) GOTO 320
64906
64907C...Junction strings: put together to new effective string endpoint.
64908 NJS(JT)=I-ISTA
64909 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
64910 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
64911 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
64912 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
64913 DO 630 J=1,4
64914 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
64915 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
64916 630 CONTINUE
64917 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
64918 & PJS(JT,3)**2))
64919 PJS(JT+2,5)=0D0
64920 640 CONTINUE
64921
64922C...Open versus closed strings. Choose breakup region for latter.
64923 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
64924 NS=MJU(2)-MJU(1)
64925 NB=MJU(1)-N
64926 ELSEIF(MJU(1).NE.0) THEN
64927 NS=N+NR-MJU(1)
64928 NB=MJU(1)-N
64929 ELSEIF(MJU(2).NE.0) THEN
64930 NS=MJU(2)-N
64931 NB=1
64932 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
64933 NS=NR-1
64934 NB=1
64935 ELSE
64936 NS=NR+1
64937 W2SUM=0D0
64938 DO 660 IS=1,NR
64939 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
64940 W2SUM=W2SUM+P(N+NR+IS,1)
64941 660 CONTINUE
64942 W2RAN=PYR(0)*W2SUM
64943 NB=0
64944 670 NB=NB+1
64945 W2SUM=W2SUM-P(N+NR+NB,1)
64946 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
64947 ENDIF
64948
64949C...Find longitudinal string directions (i.e. lightlike four-vectors).
64950 DO 700 IS=1,NS
64951 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
64952 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
64953 DO 680 J=1,5
64954 DP(1,J)=P(IS1,J)
64955 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
64956 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
64957 DP(2,J)=P(IS2,J)
64958 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
64959 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
64960 680 CONTINUE
64961 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
64962 & DP(1,2)**2-DP(1,3)**2))
64963 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
64964 & DP(2,2)**2-DP(2,3)**2))
64965 DP(3,5)=DFOUR(1,1)
64966 DP(4,5)=DFOUR(2,2)
64967 DHKC=DFOUR(1,2)
64968 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
64969 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
64970 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
64971 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
64972 IN1=N+NR+4*IS-3
64973 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
64974 DO 690 J=1,4
64975 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
64976 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
64977 690 CONTINUE
64978 700 CONTINUE
64979
64980C...Begin initialization: sum up energy, set starting position.
64981 ISAV=I
64982 MSTU91=MSTU(90)
64983 710 NTRY=NTRY+1
64984 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
64985 PARU12=4D0*PARU12
64986 PARU13=2D0*PARU13
64987 GOTO 140
64988 ELSEIF(NTRY.GT.100) THEN
64989 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
64990 IF(MSTU(21).GE.1) RETURN
64991 ENDIF
64992 I=ISAV
64993 MSTU(90)=MSTU91
64994 DO 730 J=1,4
64995 P(N+NRS,J)=0D0
64996 DO 720 IS=1,NR
64997 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
64998 720 CONTINUE
64999 730 CONTINUE
65000 DO 750 JT=1,2
65001 IRANK(JT)=0
65002 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
65003 IF(NS.GT.NR) IRANK(JT)=1
65004 IBARRK(JT)=0
65005 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
65006 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
65007 IN(3*JT+2)=IN(3*JT+1)+1
65008 IN(3*JT+3)=N+NR+4*NS+2*JT-1
65009 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
65010 P(IN1,1)=2-JT
65011 P(IN1,2)=JT-1
65012 P(IN1,3)=1D0
65013 740 CONTINUE
65014 750 CONTINUE
65015
65016C.. MOPS variables and switches
65017 NRVMO=0
65018 XBMO=1D0
65019 MSTU(121)=0
65020 MSTU(122)=0
65021
65022C...Initialize flavour and pT variables for open string.
65023 IF(NS.LT.NR) THEN
65024 PX(1)=0D0
65025 PY(1)=0D0
65026 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
65027 PX(2)=-PX(1)
65028 PY(2)=-PY(1)
65029 DO 760 JT=1,2
65030 KFL(JT)=K(IE(JT),2)
65031 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
65032 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
65033 MSTJ(93)=1
65034 PMQ(JT)=PYMASS(KFL(JT))
65035 GAM(JT)=0D0
65036 760 CONTINUE
65037
65038C...Closed string: random initial breakup flavour, pT and vertex.
65039 ELSE
65040 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65041 IBMO=0
65042 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
65043C.. Closed string: first vertex diq attempt => enforced second
65044C.. vertex diq
65045 IF(IABS(KFL(1)).GT.10)THEN
65046 IBMO=1
65047 MSTU(121)=0
65048 GOTO 770
65049 ENDIF
65050 IF(IBMO.EQ.1) MSTU(121)=-1
65051 KFL(2)=-KFL(1)
65052 CALL PYPTDI(KFL(1),PX(1),PY(1))
65053 PX(2)=-PX(1)
65054 PY(2)=-PY(1)
65055 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
65056 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
65057 ZR=PR3/(Z*P(N+NR+1,5)**2)
65058 IF(ZR.GE.1D0) GOTO 780
65059 DO 790 JT=1,2
65060 MSTJ(93)=1
65061 PMQ(JT)=PYMASS(KFL(JT))
65062 GAM(JT)=PR3*(1D0-Z)/Z
65063 IN1=N+NR+3+4*(JT/2)*(NS-1)
65064 P(IN1,JT)=1D0-Z
65065 P(IN1,3-JT)=JT-1
65066 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
65067 P(IN1+1,JT)=ZR
65068 P(IN1+1,3-JT)=2-JT
65069 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
65070 790 CONTINUE
65071 ENDIF
65072C.. MOPS variables
65073 DO 800 JT=1,2
65074 XTMO(JT)=1D0
65075 PM2QMO(JT)=PMQ(JT)**2
65076 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
65077 800 CONTINUE
65078
65079C...Find initial transverse directions (i.e. spacelike four-vectors).
65080 DO 840 JT=1,2
65081 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
65082 IN1=IN(3*JT+1)
65083 IN3=IN(3*JT+3)
65084 DO 810 J=1,4
65085 DP(1,J)=P(IN1,J)
65086 DP(2,J)=P(IN1+1,J)
65087 DP(3,J)=0D0
65088 DP(4,J)=0D0
65089 810 CONTINUE
65090 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65091 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65092 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65093 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65094 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65095 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65096 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65097 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65098 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65099 DHC12=DFOUR(1,2)
65100 DHCX1=DFOUR(3,1)/DHC12
65101 DHCX2=DFOUR(3,2)/DHC12
65102 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65103 DHCY1=DFOUR(4,1)/DHC12
65104 DHCY2=DFOUR(4,2)/DHC12
65105 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65106 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65107 DO 820 J=1,4
65108 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65109 P(IN3,J)=DP(3,J)
65110 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65111 & DHCYX*DP(3,J))
65112 820 CONTINUE
65113 ELSE
65114 DO 830 J=1,4
65115 P(IN3+2,J)=P(IN3,J)
65116 P(IN3+3,J)=P(IN3+1,J)
65117 830 CONTINUE
65118 ENDIF
65119 840 CONTINUE
65120
65121C...Remove energy used up in junction string fragmentation.
65122 IF(MJU(1)+MJU(2).GT.0) THEN
65123 DO 860 JT=1,2
65124 IF(NJS(JT).EQ.0) GOTO 860
65125 DO 850 J=1,4
65126 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
65127 850 CONTINUE
65128 860 CONTINUE
65129 PARJST=PARJ(33)
65130 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65131 WMIN=PARJST+PMQ(1)+PMQ(2)
65132 WREM2=FOUR(N+NRS,N+NRS)
65133 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
65134 NTRYWR=NTRYWR+1
65135 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
65136 GOTO 140
65137 ENDIF
65138 ENDIF
65139
65140C...Produce new particle: side, origin.
65141 870 I=I+1
65142 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
65143 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65144 IF(MSTU(21).GE.1) RETURN
65145 ENDIF
65146C.. New side priority for popcorn systems
65147 IF(MSTU(121).LE.0)THEN
65148 JT=1.5D0+PYR(0)
65149 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
65150 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
65151 ENDIF
65152 JR=3-JT
65153 JS=3-2*JT
65154 IRANK(JT)=IRANK(JT)+1
65155 K(I,1)=1
65156 K(I,4)=0
65157 K(I,5)=0
65158
65159C...Generate flavour, hadron and pT.
65160 880 K(I,3)=IE(JT)
65161 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
65162 IF(K(I,2).EQ.0) GOTO 710
65163 MU90MO=MSTU(90)
65164 IF(MSTU(121).EQ.-1) GOTO 910
65165 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
65166 &IABS(KFL(3)).GT.10) THEN
65167 IF(PYR(0).GT.PARJ(19)) GOTO 880
65168 ENDIF
65169 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65170 &K(I,3)=IJUORI(JT)
65171 P(I,5)=PYMASS(K(I,2))
65172 CALL PYPTDI(KFL(JT),PX(3),PY(3))
65173 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
65174
65175C...Final hadrons for small invariant mass.
65176 MSTJ(93)=1
65177 PMQ(3)=PYMASS(KFL(3))
65178 PARJST=PARJ(33)
65179 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
65180 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
65181 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
65182 &WMIN-0.5D0*PARJ(36)*PMQ(3)
65183 WREM2=FOUR(N+NRS,N+NRS)
65184 IF(WREM2.LT.0.10D0) GOTO 710
65185 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
65186 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
65187
65188C...Choose z, which gives Gamma. Shift z for heavy flavours.
65189 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
65190 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
65191 &MSTU(90).LT.8) THEN
65192 MSTU(90)=MSTU(90)+1
65193 MSTU(90+MSTU(90))=I
65194 PARU(90+MSTU(90))=Z
65195 ENDIF
65196 KFL1A=IABS(KFL(1))
65197 KFL2A=IABS(KFL(2))
65198 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65199 &MOD(KFL2A/1000,10)).GE.4) THEN
65200 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65201 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
65202 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
65203 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65204 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
65205 ENDIF
65206 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
65207
65208C.. MOPS baryon model modification
65209 XTMO3=(1D0-Z)*XTMO(JT)
65210 IF(IABS(KFL(3)).LE.10) NRVMO=0
65211 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
65212 GTSTMO=1D0
65213 PTSTMO=1D0
65214 RTSTMO=PYR(0)
65215 IF(IABS(KFL(JT)).LE.10)THEN
65216 XBMO=MIN(XTMO3,1D0-(2D-10))
65217 GBMO=GAM(3)
65218 PMMO=0D0
65219 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
65220 GTSTMO=1D0-PARF(192)**PGMO
65221 ELSE
65222 IF(IRANK(JT).EQ.1) THEN
65223 GBMO=GAM(JT)
65224 PMMO=0D0
65225 XBMO=1D0
65226 ENDIF
65227 IF(XBMO.LT.1D0-(1D-10))THEN
65228 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
65229 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
65230 PGMO=PGNMO
65231 ENDIF
65232 IF(MSTJ(12).GE.5)THEN
65233 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
65234 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
65235 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
65236 PMMO=PMNMO
65237 ENDIF
65238 ENDIF
65239
65240C.. MOPS Accepting popcorn system hadron.
65241 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
65242 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
65243 NRVMO=I-N-NR
65244 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
65245 CALL PYERRM(11,
65246 & '(PYSTRF:) no more memory left in PYJETS')
65247 IF(MSTU(21).GE.1) RETURN
65248 ENDIF
65249 IMO=I
65250 KFLMO=KFL(JT)
65251 PMQMO=PMQ(JT)
65252 PXMO=PX(JT)
65253 PYMO=PY(JT)
65254 GAMMO=GAM(JT)
65255 IRMO=IRANK(JT)
65256 XMO=XTMO(JT)
65257 DO 900 J=1,9
65258 IF(J.LE.5) THEN
65259 DO 890 LINE=1,I-N-NR
65260 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
65261 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
65262 890 CONTINUE
65263 ENDIF
65264 INMO(J)=IN(J)
65265 900 CONTINUE
65266 ENDIF
65267 ELSE
65268C..Reject popcorn system, flag=-1 if enforcing new one
65269 MSTU(121)=-1
65270 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
65271 ENDIF
65272 ENDIF
65273
65274
65275C..Lift restoring string outside MOPS block
65276 910 IF(MSTU(121).LT.0) THEN
65277 IF(MSTU(121).EQ.-2) MSTU(121)=0
65278 MSTU(90)=MU90MO
65279 NRVMO=0
65280 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
65281 I=IMO
65282 KFL(JT)=KFLMO
65283 PMQ(JT)=PMQMO
65284 PX(JT)=PXMO
65285 PY(JT)=PYMO
65286 GAM(JT)=GAMMO
65287 IRANK(JT)=IRMO
65288 XTMO(JT)=XMO
65289 DO 930 J=1,9
65290 IF(J.LE.5) THEN
65291 DO 920 LINE=1,I-N-NR
65292 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
65293 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
65294 920 CONTINUE
65295 ENDIF
65296 IN(J)=INMO(J)
65297 930 CONTINUE
65298 GOTO 880
65299 ENDIF
65300 XTMO(JT)=XTMO3
65301C.. MOPS end of modification
65302
65303 DO 940 J=1,3
65304 IN(J)=IN(3*JT+J)
65305 940 CONTINUE
65306
65307C...Stepping within or from 'low' string region easy.
65308 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
65309 &P(IN(1),5)**2.GE.PR(JT)) THEN
65310 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
65311 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
65312 DO 950 J=1,4
65313 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
65314 950 CONTINUE
65315 GOTO 1040
65316 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
65317 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65318 P(IN(JR)+2,JT)=1D0
65319 IN(JR)=IN(JR)+4*JS
65320 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65321 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65322 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65323 P(IN(JT)+2,JT)=0D0
65324 IN(JT)=IN(JT)+4*JS
65325 ENDIF
65326 ENDIF
65327
65328C...Find new transverse directions (i.e. spacelike string vectors).
65329 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
65330 &IN(1).GT.IN(2)) GOTO 710
65331 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
65332 DO 970 J=1,4
65333 DP(1,J)=P(IN(1),J)
65334 DP(2,J)=P(IN(2),J)
65335 DP(3,J)=0D0
65336 DP(4,J)=0D0
65337 970 CONTINUE
65338 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
65339 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
65340 DHC12=DFOUR(1,2)
65341 IF(DHC12.LE.1D-2) THEN
65342 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65343 P(IN(JT)+2,JT)=0D0
65344 IN(JT)=IN(JT)+4*JS
65345 GOTO 960
65346 ENDIF
65347 IN(3)=N+NR+4*NS+5
65348 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
65349 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
65350 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
65351 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
65352 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
65353 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
65354 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
65355 DHCX1=DFOUR(3,1)/DHC12
65356 DHCX2=DFOUR(3,2)/DHC12
65357 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
65358 DHCY1=DFOUR(4,1)/DHC12
65359 DHCY2=DFOUR(4,2)/DHC12
65360 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
65361 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
65362 DO 980 J=1,4
65363 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
65364 P(IN(3),J)=DP(3,J)
65365 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
65366 & DHCYX*DP(3,J))
65367 980 CONTINUE
65368C...Express pT with respect to new axes, if sensible.
65369 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
65370 & FOUR(IN(3*JT+3)+1,IN(3)))
65371 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
65372 & FOUR(IN(3*JT+3)+1,IN(3)+1))
65373 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
65374 PX(3)=PXP
65375 PY(3)=PYP
65376 ENDIF
65377 ENDIF
65378
65379C...Sum up known four-momentum. Gives coefficients for m2 expression.
65380 DO 1010 J=1,4
65381 DHG(J)=0D0
65382 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
65383 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
65384 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
65385 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
65386 990 CONTINUE
65387 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
65388 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
65389 1000 CONTINUE
65390 1010 CONTINUE
65391 DHM(1)=FOUR(I,I)
65392 DHM(2)=2D0*FOUR(I,IN(1))
65393 DHM(3)=2D0*FOUR(I,IN(2))
65394 DHM(4)=2D0*FOUR(IN(1),IN(2))
65395
65396C...Find coefficients for Gamma expression.
65397 DO 1030 IN2=IN(1)+1,IN(2),4
65398 DO 1020 IN1=IN(1),IN2-1,4
65399 DHC=2D0*FOUR(IN1,IN2)
65400 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
65401 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
65402 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
65403 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
65404 1020 CONTINUE
65405 1030 CONTINUE
65406
65407C...Solve (m2, Gamma) equation system for energies taken.
65408 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
65409 IF(ABS(DHS1).LT.1D-4) GOTO 710
65410 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
65411 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
65412 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
65413 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
65414 &ABS(DHS1)-DHS2/DHS1)
65415 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
65416 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
65417 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
65418
65419C...Step to new region if necessary.
65420 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
65421 P(IN(JR)+2,4)=P(IN(JR)+2,3)
65422 P(IN(JR)+2,JT)=1D0
65423 IN(JR)=IN(JR)+4*JS
65424 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
65425 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
65426 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65427 P(IN(JT)+2,JT)=0D0
65428 IN(JT)=IN(JT)+4*JS
65429 ENDIF
65430 GOTO 960
65431 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
65432 P(IN(JT)+2,4)=P(IN(JT)+2,3)
65433 P(IN(JT)+2,JT)=0D0
65434 IN(JT)=IN(JT)+4*JS
65435 GOTO 960
65436 ENDIF
65437
65438C...Four-momentum of particle. Remaining quantities. Loop back.
65439 1040 DO 1050 J=1,4
65440 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
65441 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
65442 1050 CONTINUE
65443 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
65444 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
65445 &GOTO 200
65446 IF(P(I,4).LT.P(I,5)) GOTO 710
65447 KFL(JT)=-KFL(3)
65448 PMQ(JT)=PMQ(3)
65449 PX(JT)=-PX(3)
65450 PY(JT)=-PY(3)
65451 GAM(JT)=GAM(3)
65452 IF(IN(3).NE.IN(3*JT+3)) THEN
65453 DO 1060 J=1,4
65454 P(IN(3*JT+3),J)=P(IN(3),J)
65455 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
65456 1060 CONTINUE
65457 ENDIF
65458 DO 1070 JQ=1,2
65459 IN(3*JT+JQ)=IN(JQ)
65460 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
65461 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
65462 1070 CONTINUE
65463 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65464 &IBARRK(JT)=0
65465 GOTO 870
65466
65467C...Final hadron: side, flavour, hadron, mass.
65468 1080 I=I+1
65469 K(I,1)=1
65470 K(I,3)=IE(JR)
65471 K(I,4)=0
65472 K(I,5)=0
65473 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
65474 IF(K(I,2).EQ.0) GOTO 710
65475 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
65476 &IBARRK(JT)=0
65477 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65478 &K(I,3)=IJUORI(JT)
65479 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
65480 &K(I,3)=IJUORI(JR)
65481 P(I,5)=PYMASS(K(I,2))
65482 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
65483
65484C...Final two hadrons: find common setup of four-vectors.
65485 JQ=1
65486 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
65487 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
65488 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
65489 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
65490 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
65491 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
65492 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
65493 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
65494 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
65495 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
65496 ENDIF
65497
65498C...Solve kinematics for final two hadrons, if possible.
65499 WREM2=2D0*DHR1*DHR2*DHC12
65500 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
65501 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
65502 IF(FD.GE.1D0) GOTO 710
65503 FA=WREM2+PR(JT)-PR(JR)
65504 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
65505 PREVCF=PARJ(42)
65506 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65507 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
65508 FB=SIGN(FB,JS*(PYR(0)-PREV))
65509 KFL1A=IABS(KFL(1))
65510 KFL2A=IABS(KFL(2))
65511 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
65512 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
65513 &4D0*WREM2*PR(JT))),DBLE(JS))
65514 DO 1090 J=1,4
65515 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
65516 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
65517 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
65518 P(I,J)=P(N+NRS,J)-P(I-1,J)
65519 1090 CONTINUE
65520 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
65521 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
65522 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
65523 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
65524 NTRYFN=NTRYFN+1
65525 IF(NTRYFN.LT.100) GOTO 140
65526 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
65527 ENDIF
65528
65529C...Mark jets as fragmented and give daughter pointers.
65530 N=I-NRS+1
65531 DO 1100 I=NSAV+1,NSAV+NP
65532 IM=K(I,3)
65533 K(IM,1)=K(IM,1)+10
65534 IF(MSTU(16).NE.2) THEN
65535 K(IM,4)=NSAV+1
65536 K(IM,5)=NSAV+1
65537 ELSE
65538 K(IM,4)=NSAV+2
65539 K(IM,5)=N
65540 ENDIF
65541 1100 CONTINUE
65542
65543C...Document string system. Move up particles.
65544 NSAV=NSAV+1
65545 K(NSAV,1)=11
65546 K(NSAV,2)=92
65547 K(NSAV,3)=IP
65548 K(NSAV,4)=NSAV+1
65549 K(NSAV,5)=N
65550 DO 1110 J=1,4
65551 P(NSAV,J)=DPS(J)
65552 V(NSAV,J)=V(IP,J)
65553 1110 CONTINUE
65554 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
65555 V(NSAV,5)=0D0
65556 DO 1130 I=NSAV+1,N
65557 DO 1120 J=1,5
65558 K(I,J)=K(I+NRS-1,J)
65559 P(I,J)=P(I+NRS-1,J)
65560 V(I,J)=0D0
65561 1120 CONTINUE
65562 1130 CONTINUE
65563 MSTU91=MSTU(90)
65564 DO 1140 IZ=MSTU90+1,MSTU91
65565 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
65566 PARU9T(IZ)=PARU(90+IZ)
65567 1140 CONTINUE
65568 MSTU(90)=MSTU90
65569
65570C...Order particles in rank along the chain. Update mother pointer.
65571 DO 1160 I=NSAV+1,N
65572 DO 1150 J=1,5
65573 K(I-NSAV+N,J)=K(I,J)
65574 P(I-NSAV+N,J)=P(I,J)
65575 1150 CONTINUE
65576 1160 CONTINUE
65577 I1=NSAV
65578 DO 1190 I=N+1,2*N-NSAV
65579 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
65580 I1=I1+1
65581 DO 1170 J=1,5
65582 K(I1,J)=K(I,J)
65583 P(I1,J)=P(I,J)
65584 1170 CONTINUE
65585 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65586 DO 1180 IZ=MSTU90+1,MSTU91
65587 IF(MSTU9T(IZ).EQ.I) THEN
65588 MSTU(90)=MSTU(90)+1
65589 MSTU(90+MSTU(90))=I1
65590 PARU(90+MSTU(90))=PARU9T(IZ)
65591 ENDIF
65592 1180 CONTINUE
65593 1190 CONTINUE
65594 DO 1220 I=2*N-NSAV,N+1,-1
65595 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
65596 I1=I1+1
65597 DO 1200 J=1,5
65598 K(I1,J)=K(I,J)
65599 P(I1,J)=P(I,J)
65600 1200 CONTINUE
65601 IF(MSTU(16).NE.2) K(I1,3)=NSAV
65602 DO 1210 IZ=MSTU90+1,MSTU91
65603 IF(MSTU9T(IZ).EQ.I) THEN
65604 MSTU(90)=MSTU(90)+1
65605 MSTU(90+MSTU(90))=I1
65606 PARU(90+MSTU(90))=PARU9T(IZ)
65607 ENDIF
65608 1210 CONTINUE
65609 1220 CONTINUE
65610
65611C...Boost back particle system. Set production vertices.
65612 IF(MBST.EQ.0) THEN
65613 MSTU(33)=1
65614 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
65615 & DPS(3)/DPS(4))
65616 ELSE
65617 DO 1230 I=NSAV+1,N
65618 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65619 IF(P(I,3).GT.0D0) THEN
65620 HHPEZ=(P(I,4)+P(I,3))*HHBZ
65621 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65622 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65623 ELSE
65624 HHPEZ=(P(I,4)-P(I,3))/HHBZ
65625 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65626 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65627 ENDIF
65628 1230 CONTINUE
65629 ENDIF
65630 DO 1250 I=NSAV+1,N
65631 DO 1240 J=1,4
65632 V(I,J)=V(IP,J)
65633 1240 CONTINUE
65634 1250 CONTINUE
65635
65636 RETURN
65637 END
65638
65639C*********************************************************************
65640
65641C...PYJURF
65642C...From three given input vectors in PJU the boost VJU from
65643C...the "lab frame" to the junction rest frame is constructed.
65644
65645 SUBROUTINE PYJURF(PJU,VJU)
65646
65647C...Double precision and integer declarations.
65648 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65649 IMPLICIT INTEGER(I-N)
65650
65651C...Input, output and local arrays.
65652 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
65653 DATA TWOPI/6.283186D0/
65654
65655C...Calculate masses and other invariants.
65656 DO 100 J=1,4
65657 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
65658 100 CONTINUE
65659 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
65660 PSUM(5)=SQRT(PSUM2)
65661 DO 120 I=1,3
65662 DO 110 J=1,3
65663 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
65664 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
65665 110 CONTINUE
65666 120 CONTINUE
65667
65668C...Pick I to be most massive parton and J to be the one closest to I.
65669 ITRY=0
65670 I=1
65671 IF(A(2,2).GT.A(1,1)) I=2
65672 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
65673 130 ITRY=ITRY+1
65674 J=1+MOD(I,3)
65675 K=1+MOD(J,3)
65676 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
65677 K=1+MOD(I,3)
65678 J=1+MOD(K,3)
65679 ENDIF
65680 PMI2=A(I,I)
65681 PMJ2=A(J,J)
65682 PMK2=A(K,K)
65683 AIJ=A(I,J)
65684 AIK=A(I,K)
65685 AJK=A(J,K)
65686
65687C...Trivial find new parton energies if all three partons are massless.
65688 IF(PMI2.LT.1D-4) THEN
65689 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
65690 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
65691 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
65692
65693C...Else find momentum range for parton I and values at extremes.
65694 ELSE
65695 PAIMIN=0D0
65696 PEIMIN=SQRT(PMI2)
65697 PEJMIN=AIJ/PEIMIN
65698 PEKMIN=AIK/PEIMIN
65699 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
65700 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
65701 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
65702 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
65703 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
65704 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
65705 HI=PEIMAX**2-0.25D0*PAIMAX**2
65706 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
65707 & 0.5D0*PAIMAX*AIJ)/HI
65708 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
65709 & 0.5D0*PAIMAX*AIK)/HI
65710 PEJMAX=SQRT(PAJMAX**2+PMJ2)
65711 PEKMAX=SQRT(PAKMAX**2+PMK2)
65712 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
65713
65714C...If unexpected values at upper endpoint then pick another parton.
65715 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
65716 I1=1+MOD(I,3)
65717 IF(A(I1,I1).GE.1D-4) THEN
65718 I=I1
65719 GOTO 130
65720 ENDIF
65721 ITRY=ITRY+1
65722 I1=1+MOD(I,3)
65723 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
65724 I=I1
65725 GOTO 130
65726 ENDIF
65727 ENDIF
65728
65729C..Start binary + linear search to find solution inside range.
65730 ITER=0
65731 ITMIN=0
65732 ITMAX=0
65733 PAI=0.5D0*(PAIMIN+PAIMAX)
65734 140 ITER=ITER+1
65735
65736C...Derive momentum of other two partons and distance to root.
65737 PEI=SQRT(PAI**2+PMI2)
65738 HI=PEI**2-0.25D0*PAI**2
65739 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
65740 PEJ=SQRT(PAJ**2+PMJ2)
65741 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
65742 PEK=SQRT(PAK**2+PMK2)
65743 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
65744
65745C...Pick next I momentum to explore, hopefully closer to root.
65746 IF(FNOW.GT.0D0) THEN
65747 PAIMIN=PAI
65748 FMIN=FNOW
65749 ITMIN=ITMIN+1
65750 ELSE
65751 PAIMAX=PAI
65752 FMAX=FNOW
65753 ITMAX=ITMAX+1
65754 ENDIF
65755 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
65756 & THEN
65757 PAI=0.5D0*(PAIMIN+PAIMAX)
65758 GOTO 140
65759 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
65760 & ABS(FNOW).GT.1D-12*PSUM2) THEN
65761 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
65762 GOTO 140
65763 ENDIF
65764 ENDIF
65765
65766C...Now know energies in junction rest frame.
65767 PENEW(I)=PEI
65768 PENEW(J)=PEJ
65769 PENEW(K)=PEK
65770
65771C...Boost (copy of) partons to their rest frame.
65772 VXCM=-PSUM(1)/PSUM(5)
65773 VYCM=-PSUM(2)/PSUM(5)
65774 VZCM=-PSUM(3)/PSUM(5)
65775 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
65776 DO 150 I=1,3
65777 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
65778 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
65779 PCM(I,1)=PJU(I,1)+FAC2*VXCM
65780 PCM(I,2)=PJU(I,2)+FAC2*VYCM
65781 PCM(I,3)=PJU(I,3)+FAC2*VZCM
65782 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
65783 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65784 150 CONTINUE
65785
65786C...Construct difference vectors and boost to junction rest frame.
65787 DO 160 J=1,3
65788 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
65789 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
65790 160 CONTINUE
65791 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
65792 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
65793 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
65794 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
65795 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
65796 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
65797 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
65798 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
65799 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
65800 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
65801 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
65802
65803C...Add two boosts, giving final result.
65804 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
65805 VJU(1)=VXJU+FCM*VXCM
65806 VJU(2)=VYJU+FCM*VYCM
65807 VJU(3)=VZJU+FCM*VZCM
65808 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
65809 VJU(5)=1D0
65810
65811C...In case of error in reconstruction: revert to CM frame of system.
65812 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65813 &(PCM(1,5)*PCM(2,5))
65814 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65815 &(PCM(1,5)*PCM(3,5))
65816 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65817 &(PCM(2,5)*PCM(3,5))
65818 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65819 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65820 DO 170 I=1,3
65821 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
65822 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
65823 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
65824 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
65825 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
65826 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
65827 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
65828 170 CONTINUE
65829 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
65830 &(PCM(1,5)*PCM(2,5))
65831 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
65832 &(PCM(1,5)*PCM(3,5))
65833 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
65834 &(PCM(2,5)*PCM(3,5))
65835 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
65836 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
65837 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
65838 VJU(1)=VXCM
65839 VJU(2)=VYCM
65840 VJU(3)=VZCM
65841 VJU(4)=GAMCM
65842 ENDIF
65843
65844 RETURN
65845 END
65846
65847C*********************************************************************
65848
65849C...PYINDF
65850C...Handles the fragmentation of a jet system (or a single
65851C...jet) according to independent fragmentation models.
65852
65853 SUBROUTINE PYINDF(IP)
65854
65855C...Double precision and integer declarations.
65856 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65857 IMPLICIT INTEGER(I-N)
65858 INTEGER PYK,PYCHGE,PYCOMP
65859C...Commonblocks.
65860 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65863 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65864C...Local arrays.
65865 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
65866 &KFLO(2),PXO(2),PYO(2),WO(2)
65867
65868C.. MOPS error message
65869 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
65870 &' are not treated as expected in independent fragmentation')
65871
65872C...Reset counters. Identify parton system and take copy. Check flavour.
65873 NSAV=N
65874 MSTU90=MSTU(90)
65875 NJET=0
65876 KQSUM=0
65877 DO 100 J=1,5
65878 DPS(J)=0D0
65879 100 CONTINUE
65880 I=IP-1
65881 110 I=I+1
65882 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65883 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
65884 IF(MSTU(21).GE.1) RETURN
65885 ENDIF
65886 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
65887 KC=PYCOMP(K(I,2))
65888 IF(KC.EQ.0) GOTO 110
65889 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65890 IF(KQ.EQ.0) GOTO 110
65891 NJET=NJET+1
65892 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65893 DO 120 J=1,5
65894 K(NSAV+NJET,J)=K(I,J)
65895 P(NSAV+NJET,J)=P(I,J)
65896 DPS(J)=DPS(J)+P(I,J)
65897 120 CONTINUE
65898 K(NSAV+NJET,3)=I
65899 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
65900 &K(I+1,1).EQ.2)) GOTO 110
65901 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
65902 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
65903 IF(MSTU(21).GE.1) RETURN
65904 ENDIF
65905
65906C...Boost copied system to CM frame. Find CM energy and sum flavours.
65907 IF(NJET.NE.1) THEN
65908 MSTU(33)=1
65909 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
65910 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
65911 ENDIF
65912 PECM=0D0
65913 DO 130 J=1,3
65914 NFI(J)=0
65915 130 CONTINUE
65916 DO 140 I=NSAV+1,NSAV+NJET
65917 PECM=PECM+P(I,4)
65918 KFA=IABS(K(I,2))
65919 IF(KFA.LE.3) THEN
65920 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
65921 ELSEIF(KFA.GT.1000) THEN
65922 KFLA=MOD(KFA/1000,10)
65923 KFLB=MOD(KFA/100,10)
65924 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
65925 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
65926 ENDIF
65927 140 CONTINUE
65928
65929C...Loop over attempts made. Reset counters.
65930 NTRY=0
65931 150 NTRY=NTRY+1
65932 IF(NTRY.GT.200) THEN
65933 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
65934 IF(MSTU(21).GE.1) RETURN
65935 ENDIF
65936 N=NSAV+NJET
65937 MSTU(90)=MSTU90
65938 DO 160 J=1,3
65939 NFL(J)=NFI(J)
65940 IFET(J)=0
65941 KFLF(J)=0
65942 160 CONTINUE
65943
65944C...Loop over jets to be fragmented.
65945 DO 230 IP1=NSAV+1,NSAV+NJET
65946 MSTJ(91)=0
65947 NSAV1=N
65948 MSTU91=MSTU(90)
65949
65950C...Initial flavour and momentum values. Jet along +z axis.
65951 KFLH=IABS(K(IP1,2))
65952 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
65953 KFLO(2)=0
65954 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
65955
65956C...Initial values for quark or diquark jet.
65957 170 IF(IABS(K(IP1,2)).NE.21) THEN
65958 NSTR=1
65959 KFLO(1)=K(IP1,2)
65960 CALL PYPTDI(0,PXO(1),PYO(1))
65961 WO(1)=WF
65962
65963C...Initial values for gluon treated like random quark jet.
65964 ELSEIF(MSTJ(2).LE.2) THEN
65965 NSTR=1
65966 IF(MSTJ(2).EQ.2) MSTJ(91)=1
65967 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65968 CALL PYPTDI(0,PXO(1),PYO(1))
65969 WO(1)=WF
65970
65971C...Initial values for gluon treated like quark-antiquark jet pair,
65972C...sharing energy according to Altarelli-Parisi splitting function.
65973 ELSE
65974 NSTR=2
65975 IF(MSTJ(2).EQ.4) MSTJ(91)=1
65976 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
65977 KFLO(2)=-KFLO(1)
65978 CALL PYPTDI(0,PXO(1),PYO(1))
65979 PXO(2)=-PXO(1)
65980 PYO(2)=-PYO(1)
65981 WO(1)=WF*PYR(0)**(1D0/3D0)
65982 WO(2)=WF-WO(1)
65983 ENDIF
65984
65985C...Initial values for rank, flavour, pT and W+.
65986 DO 220 ISTR=1,NSTR
65987 180 I=N
65988 MSTU(90)=MSTU91
65989 IRANK=0
65990 KFL1=KFLO(ISTR)
65991 PX1=PXO(ISTR)
65992 PY1=PYO(ISTR)
65993 W=WO(ISTR)
65994
65995C...New hadron. Generate flavour and hadron species.
65996 190 I=I+1
65997 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
65998 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
65999 IF(MSTU(21).GE.1) RETURN
66000 ENDIF
66001 IRANK=IRANK+1
66002 K(I,1)=1
66003 K(I,3)=IP1
66004 K(I,4)=0
66005 K(I,5)=0
66006 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
66007 IF(K(I,2).EQ.0) GOTO 180
66008 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
66009 IF(PYR(0).GT.PARJ(19)) GOTO 200
66010 ENDIF
66011
66012C...Find hadron mass. Generate four-momentum.
66013 P(I,5)=PYMASS(K(I,2))
66014 CALL PYPTDI(KFL1,PX2,PY2)
66015 P(I,1)=PX1+PX2
66016 P(I,2)=PY1+PY2
66017 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
66018 CALL PYZDIS(KFL1,KFL2,PR,Z)
66019 MZSAV=0
66020 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
66021 MZSAV=1
66022 MSTU(90)=MSTU(90)+1
66023 MSTU(90+MSTU(90))=I
66024 PARU(90+MSTU(90))=Z
66025 ENDIF
66026 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
66027 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
66028 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
66029 & P(I,3).LE.0.001D0) THEN
66030 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
66031 P(I,3)=0.0001D0
66032 P(I,4)=SQRT(PR)
66033 Z=P(I,4)/W
66034 ENDIF
66035
66036C...Remaining flavour and momentum.
66037 KFL1=-KFL2
66038 PX1=-PX2
66039 PY1=-PY2
66040 W=(1D0-Z)*W
66041 DO 210 J=1,5
66042 V(I,J)=0D0
66043 210 CONTINUE
66044
66045C...Check if pL acceptable. Go back for new hadron if enough energy.
66046 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
66047 I=I-1
66048 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
66049 ENDIF
66050 IF(W.GT.PARJ(31)) GOTO 190
66051 N=I
66052 220 CONTINUE
66053 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
66054 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
66055
66056C...Rotate jet to new direction.
66057 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
66058 PHI=PYANGL(P(IP1,1),P(IP1,2))
66059 MSTU(33)=1
66060 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
66061 K(K(IP1,3),4)=NSAV1+1
66062 K(K(IP1,3),5)=N
66063
66064C...End of jet generation loop. Skip conservation in some cases.
66065 230 CONTINUE
66066 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
66067 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
66068
66069C...Subtract off produced hadron flavours, finished if zero.
66070 DO 240 I=NSAV+NJET+1,N
66071 KFA=IABS(K(I,2))
66072 KFLA=MOD(KFA/1000,10)
66073 KFLB=MOD(KFA/100,10)
66074 KFLC=MOD(KFA/10,10)
66075 IF(KFLA.EQ.0) THEN
66076 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
66077 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
66078 ELSE
66079 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
66080 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
66081 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
66082 ENDIF
66083 240 CONTINUE
66084 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66085 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66086 IF(NREQ.EQ.0) GOTO 320
66087
66088C...Take away flavour of low-momentum particles until enough freedom.
66089 NREM=0
66090 250 IREM=0
66091 P2MIN=PECM**2
66092 DO 260 I=NSAV+NJET+1,N
66093 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
66094 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
66095 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
66096 260 CONTINUE
66097 IF(IREM.EQ.0) GOTO 150
66098 K(IREM,1)=7
66099 KFA=IABS(K(IREM,2))
66100 KFLA=MOD(KFA/1000,10)
66101 KFLB=MOD(KFA/100,10)
66102 KFLC=MOD(KFA/10,10)
66103 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
66104 IF(K(IREM,1).EQ.8) GOTO 250
66105 IF(KFLA.EQ.0) THEN
66106 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
66107 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
66108 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
66109 ELSE
66110 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
66111 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
66112 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
66113 ENDIF
66114 NREM=NREM+1
66115 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66116 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66117 IF(NREQ.GT.NREM) GOTO 250
66118 DO 270 I=NSAV+NJET+1,N
66119 IF(K(I,1).EQ.8) K(I,1)=1
66120 270 CONTINUE
66121
66122C...Find combination of existing and new flavours for hadron.
66123 280 NFET=2
66124 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
66125 IF(NREQ.LT.NREM) NFET=1
66126 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
66127 DO 290 J=1,NFET
66128 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
66129 KFLF(J)=ISIGN(1,NFL(1))
66130 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
66131 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
66132 290 CONTINUE
66133 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
66134 &GOTO 280
66135 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
66136 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
66137 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
66138 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
66139 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
66140 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
66141 IF(NFET.LE.2) KFLF(3)=0
66142 IF(KFLF(3).NE.0) THEN
66143 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
66144 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
66145 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
66146 & KFLFC=KFLFC+ISIGN(2,KFLFC)
66147 ELSE
66148 KFLFC=KFLF(1)
66149 ENDIF
66150 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
66151 IF(KF.EQ.0) GOTO 280
66152 DO 300 J=1,MAX(2,NFET)
66153 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
66154 300 CONTINUE
66155
66156C...Store hadron at random among free positions.
66157 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
66158 DO 310 I=NSAV+NJET+1,N
66159 IF(K(I,1).EQ.7) NPOS=NPOS-1
66160 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
66161 K(I,1)=1
66162 K(I,2)=KF
66163 P(I,5)=PYMASS(K(I,2))
66164 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66165 310 CONTINUE
66166 NREM=NREM-1
66167 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
66168 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
66169 IF(NREM.GT.0) GOTO 280
66170
66171C...Compensate for missing momentum in global scheme (3 options).
66172 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
66173 DO 340 J=1,3
66174 PSI(J)=0D0
66175 DO 330 I=NSAV+NJET+1,N
66176 PSI(J)=PSI(J)+P(I,J)
66177 330 CONTINUE
66178 340 CONTINUE
66179 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
66180 PWS=0D0
66181 DO 350 I=NSAV+NJET+1,N
66182 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
66183 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66184 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66185 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
66186 350 CONTINUE
66187 DO 370 I=NSAV+NJET+1,N
66188 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
66189 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
66190 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
66191 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
66192 DO 360 J=1,3
66193 P(I,J)=P(I,J)-PSI(J)*PW/PWS
66194 360 CONTINUE
66195 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66196 370 CONTINUE
66197
66198C...Compensate for missing momentum withing each jet separately.
66199 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
66200 DO 390 I=N+1,N+NJET
66201 K(I,1)=0
66202 DO 380 J=1,5
66203 P(I,J)=0D0
66204 380 CONTINUE
66205 390 CONTINUE
66206 DO 410 I=NSAV+NJET+1,N
66207 IR1=K(I,3)
66208 IR2=N+IR1-NSAV
66209 K(IR2,1)=K(IR2,1)+1
66210 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66211 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66212 DO 400 J=1,3
66213 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
66214 400 CONTINUE
66215 P(IR2,4)=P(IR2,4)+P(I,4)
66216 P(IR2,5)=P(IR2,5)+PLS
66217 410 CONTINUE
66218 PSS=0D0
66219 DO 420 I=N+1,N+NJET
66220 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
66221 420 CONTINUE
66222 DO 440 I=NSAV+NJET+1,N
66223 IR1=K(I,3)
66224 IR2=N+IR1-NSAV
66225 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
66226 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
66227 DO 430 J=1,3
66228 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
66229 & PLS*P(IR1,J)
66230 430 CONTINUE
66231 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66232 440 CONTINUE
66233 ENDIF
66234
66235C...Scale momenta for energy conservation.
66236 IF(MOD(MSTJ(3),5).NE.0) THEN
66237 PMS=0D0
66238 PES=0D0
66239 PQS=0D0
66240 DO 450 I=NSAV+NJET+1,N
66241 PMS=PMS+P(I,5)
66242 PES=PES+P(I,4)
66243 PQS=PQS+P(I,5)**2/P(I,4)
66244 450 CONTINUE
66245 IF(PMS.GE.PECM) GOTO 150
66246 NECO=0
66247 460 NECO=NECO+1
66248 PFAC=(PECM-PQS)/(PES-PQS)
66249 PES=0D0
66250 PQS=0D0
66251 DO 480 I=NSAV+NJET+1,N
66252 DO 470 J=1,3
66253 P(I,J)=PFAC*P(I,J)
66254 470 CONTINUE
66255 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
66256 PES=PES+P(I,4)
66257 PQS=PQS+P(I,5)**2/P(I,4)
66258 480 CONTINUE
66259 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
66260 ENDIF
66261
66262C...Origin of produced particles and parton daughter pointers.
66263 490 DO 500 I=NSAV+NJET+1,N
66264 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
66265 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
66266 500 CONTINUE
66267 DO 510 I=NSAV+1,NSAV+NJET
66268 I1=K(I,3)
66269 K(I1,1)=K(I1,1)+10
66270 IF(MSTU(16).NE.2) THEN
66271 K(I1,4)=NSAV+1
66272 K(I1,5)=NSAV+1
66273 ELSE
66274 K(I1,4)=K(I1,4)-NJET+1
66275 K(I1,5)=K(I1,5)-NJET+1
66276 IF(K(I1,5).LT.K(I1,4)) THEN
66277 K(I1,4)=0
66278 K(I1,5)=0
66279 ENDIF
66280 ENDIF
66281 510 CONTINUE
66282
66283C...Document independent fragmentation system. Remove copy of jets.
66284 NSAV=NSAV+1
66285 K(NSAV,1)=11
66286 K(NSAV,2)=93
66287 K(NSAV,3)=IP
66288 K(NSAV,4)=NSAV+1
66289 K(NSAV,5)=N-NJET+1
66290 DO 520 J=1,4
66291 P(NSAV,J)=DPS(J)
66292 V(NSAV,J)=V(IP,J)
66293 520 CONTINUE
66294 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
66295 V(NSAV,5)=0D0
66296 DO 540 I=NSAV+NJET,N
66297 DO 530 J=1,5
66298 K(I-NJET+1,J)=K(I,J)
66299 P(I-NJET+1,J)=P(I,J)
66300 V(I-NJET+1,J)=V(I,J)
66301 530 CONTINUE
66302 540 CONTINUE
66303 N=N-NJET+1
66304 DO 550 IZ=MSTU90+1,MSTU(90)
66305 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
66306 550 CONTINUE
66307
66308C...Boost back particle system. Set production vertices.
66309 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
66310 &DPS(2)/DPS(4),DPS(3)/DPS(4))
66311 DO 570 I=NSAV+1,N
66312 DO 560 J=1,4
66313 V(I,J)=V(IP,J)
66314 560 CONTINUE
66315 570 CONTINUE
66316
66317 RETURN
66318 END
66319
66320C*********************************************************************
66321
66322C...PYDECY
66323C...Handles the decay of unstable particles.
66324
66325 SUBROUTINE PYDECY(IP)
66326
66327C...Double precision and integer declarations.
66328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
66329 IMPLICIT INTEGER(I-N)
66330 INTEGER PYK,PYCHGE,PYCOMP
66331C...Commonblocks.
66332 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
66333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
66334 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
66335 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
66336 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
66337C...Local arrays.
66338 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
66339 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
66340 CHARACTER CIDC*4
66341 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
66342
66343C...Functions: momentum in two-particle decays and four-product.
66344 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
66345 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)
66346
66347C...Initial values.
66348 NTRY=0
66349 NSAV=N
66350 KFA=IABS(K(IP,2))
66351 KFS=ISIGN(1,K(IP,2))
66352 KC=PYCOMP(KFA)
66353 MSTJ(92)=0
66354
66355C...Choose lifetime and determine decay vertex.
66356 IF(K(IP,1).EQ.5) THEN
66357 V(IP,5)=0D0
66358 ELSEIF(K(IP,1).NE.4) THEN
66359 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
66360 ENDIF
66361 DO 100 J=1,4
66362 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
66363 100 CONTINUE
66364
66365C...Determine whether decay allowed or not.
66366 MOUT=0
66367 IF(MSTJ(22).EQ.2) THEN
66368 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
66369 ELSEIF(MSTJ(22).EQ.3) THEN
66370 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
66371 ELSEIF(MSTJ(22).EQ.4) THEN
66372 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
66373 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
66374 ENDIF
66375 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
66376 K(IP,1)=4
66377 RETURN
66378 ENDIF
66379
66380C...Interface to external tau decay library (for tau polarization).
66381 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
66382
66383C...Starting values for pointers and momenta.
66384 ITAU=IP
66385 DO 110 J=1,4
66386 PTAU(J)=P(ITAU,J)
66387 PCMTAU(J)=P(ITAU,J)
66388 110 CONTINUE
66389
66390C...Iterate to find position and code of mother of tau.
66391 IMTAU=ITAU
66392 120 IMTAU=K(IMTAU,3)
66393
66394 IF(IMTAU.EQ.0) THEN
66395C...If no known origin then impossible to do anything further.
66396 KFORIG=0
66397 IORIG=0
66398
66399 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
66400C...If tau -> tau + gamma then add gamma energy and loop.
66401 IF(K(K(IMTAU,4),2).EQ.22) THEN
66402 DO 130 J=1,4
66403 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
66404 130 CONTINUE
66405 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
66406 DO 140 J=1,4
66407 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
66408 140 CONTINUE
66409 ENDIF
66410 GOTO 120
66411
66412 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
66413C...If coming from weak decay of hadron then W is not stored in record,
66414C...but can be reconstructed by adding neutrino momentum.
66415 KFORIG=-ISIGN(24,K(ITAU,2))
66416 IORIG=0
66417 DO 160 II=K(IMTAU,4),K(IMTAU,5)
66418 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
66419 DO 150 J=1,4
66420 PCMTAU(J)=PCMTAU(J)+P(II,J)
66421 150 CONTINUE
66422 ENDIF
66423 160 CONTINUE
66424
66425 ELSE
66426C...If coming from resonance decay then find latest copy of this
66427C...resonance (may not completely agree).
66428 KFORIG=K(IMTAU,2)
66429 IORIG=IMTAU
66430 DO 170 II=IMTAU+1,IP-1
66431 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
66432 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
66433 170 CONTINUE
66434 DO 180 J=1,4
66435 PCMTAU(J)=P(IORIG,J)
66436 180 CONTINUE
66437 ENDIF
66438
66439C...Boost tau to rest frame of production process (where known)
66440C...and rotate it to sit along +z axis.
66441 DO 190 J=1,3
66442 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
66443 190 CONTINUE
66444 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
66445 & -DBETAU(2),-DBETAU(3))
66446 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
66447 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
66448 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
66449 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
66450
66451C...Call tau decay routine (if meaningful) and fill extra info.
66452 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66453 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
66454 DO 200 II=NSAV+1,NSAV+NDECAY
66455 K(II,1)=1
66456 K(II,3)=IP
66457 K(II,4)=0
66458 K(II,5)=0
66459 200 CONTINUE
66460 N=NSAV+NDECAY
66461 ENDIF
66462
66463C...Boost back decay tau and decay products.
66464 DO 210 J=1,4
66465 P(ITAU,J)=PTAU(J)
66466 210 CONTINUE
66467 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
66468 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
66469 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
66470 & DBETAU(2),DBETAU(3))
66471
66472C...Skip past ordinary tau decay treatment.
66473 MMAT=0
66474 MBST=0
66475 ND=0
66476 GOTO 630
66477 ENDIF
66478 ENDIF
66479
66480C...B-Bbar mixing: flip sign of meson appropriately.
66481 MMIX=0
66482 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
66483 XBBMIX=PARJ(76)
66484 IF(KFA.EQ.531) XBBMIX=PARJ(77)
66485 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
66486 IF(MMIX.EQ.1) KFS=-KFS
66487 ENDIF
66488
66489C...Check existence of decay channels. Particle/antiparticle rules.
66490 KCA=KC
66491 IF(MDCY(KC,2).GT.0) THEN
66492 MDMDCY=MDME(MDCY(KC,2),2)
66493 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
66494 ENDIF
66495 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
66496 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
66497 RETURN
66498 ENDIF
66499 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
66500 IF(KCHG(KC,3).EQ.0) THEN
66501 KFSP=1
66502 KFSN=0
66503 IF(PYR(0).GT.0.5D0) KFS=-KFS
66504 ELSEIF(KFS.GT.0) THEN
66505 KFSP=1
66506 KFSN=0
66507 ELSE
66508 KFSP=0
66509 KFSN=1
66510 ENDIF
66511
66512C...Sum branching ratios of allowed decay channels.
66513 220 NOPE=0
66514 BRSU=0D0
66515 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
66516 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66517 & KFSN*MDME(IDL,1).NE.3) GOTO 230
66518 IF(MDME(IDL,2).GT.100) GOTO 230
66519 NOPE=NOPE+1
66520 BRSU=BRSU+BRAT(IDL)
66521 230 CONTINUE
66522 IF(NOPE.EQ.0) THEN
66523 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
66524 RETURN
66525 ENDIF
66526
66527C...Select decay channel among allowed ones.
66528 240 RBR=BRSU*PYR(0)
66529 IDL=MDCY(KCA,2)-1
66530 250 IDL=IDL+1
66531 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
66532 &KFSN*MDME(IDL,1).NE.3) THEN
66533 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66534 ELSEIF(MDME(IDL,2).GT.100) THEN
66535 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
66536 ELSE
66537 IDC=IDL
66538 RBR=RBR-BRAT(IDL)
66539 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
66540 ENDIF
66541
66542C...Start readout of decay channel: matrix element, reset counters.
66543 MMAT=MDME(IDC,2)
66544 260 NTRY=NTRY+1
66545 IF(MOD(NTRY,200).EQ.0) THEN
66546 WRITE(CIDC,'(I4)') IDC
66547C...Do not print warning for some well-known special cases.
66548 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
66549 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
66550 & CIDC)
66551 GOTO 240
66552 ENDIF
66553 IF(NTRY.GT.1000) THEN
66554 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66555 IF(MSTU(21).GE.1) RETURN
66556 ENDIF
66557 I=N
66558 NP=0
66559 NQ=0
66560 MBST=0
66561 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
66562 DO 270 J=1,4
66563 PV(1,J)=0D0
66564 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
66565 270 CONTINUE
66566 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
66567 PV(1,5)=P(IP,5)
66568 PS=0D0
66569 PSQ=0D0
66570 MREM=0
66571 MHADDY=0
66572 IF(KFA.GT.80) MHADDY=1
66573C.. Random flavour and popcorn system memory.
66574 IRNDMO=0
66575 JTMO=0
66576 MSTU(121)=0
66577 MSTU(125)=10
66578
66579C...Read out decay products. Convert to standard flavour code.
66580 JTMAX=5
66581 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
66582 DO 280 JT=1,JTMAX
66583 IF(JT.LE.5) KP=KFDP(IDC,JT)
66584 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
66585 IF(KP.EQ.0) GOTO 280
66586 KPA=IABS(KP)
66587 KCP=PYCOMP(KPA)
66588 IF(KPA.GT.80) MHADDY=1
66589 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
66590 KFP=KP
66591 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
66592 KFP=KFS*KP
66593 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
66594 KFP=-KFS*MOD(KFA/10,10)
66595 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
66596 KFP=KFS*(100*MOD(KFA/10,100)+3)
66597 ELSEIF(KPA.EQ.81) THEN
66598 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
66599 ELSEIF(KP.EQ.82) THEN
66600 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
66601 IF(KFP.EQ.0) GOTO 260
66602 KFP=-KFP
66603 IRNDMO=1
66604 MSTJ(93)=1
66605 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
66606 ELSEIF(KP.EQ.-82) THEN
66607 KFP=MSTU(124)
66608 ENDIF
66609 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
66610
66611C...Add decay product to event record or to quark flavour list.
66612 KFPA=IABS(KFP)
66613 KQP=KCHG(KCP,2)
66614 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
66615 NQ=NQ+1
66616 KFLO(NQ)=KFP
66617C...set rndmflav popcorn system pointer
66618 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
66619 MSTJ(93)=2
66620 PSQ=PSQ+PYMASS(KFLO(NQ))
66621 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
66622 & MOD(NQ,2).EQ.1) THEN
66623 NQ=NQ-1
66624 PS=PS-P(I,5)
66625 K(I,1)=1
66626 KFI=K(I,2)
66627 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
66628 IF(K(I,2).EQ.0) GOTO 260
66629 MSTJ(93)=1
66630 P(I,5)=PYMASS(K(I,2))
66631 PS=PS+P(I,5)
66632 ELSE
66633 I=I+1
66634 NP=NP+1
66635 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
66636 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
66637 K(I,1)=1+MOD(NQ,2)
66638 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
66639 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
66640 K(I,2)=KFP
66641 K(I,3)=IP
66642 K(I,4)=0
66643 K(I,5)=0
66644 P(I,5)=PYMASS(KFP)
66645 PS=PS+P(I,5)
66646 ENDIF
66647 280 CONTINUE
66648
66649C...Check masses for resonance decays.
66650 IF(MHADDY.EQ.0) THEN
66651 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
66652 ENDIF
66653
66654C...Choose decay multiplicity in phase space model.
66655 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
66656 PSP=PS
66657 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
66658 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
66659 300 NTRY=NTRY+1
66660C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
66661 IF(IRNDMO.EQ.0) THEN
66662 MSTU(121)=0
66663 JTMO=0
66664 ELSEIF(IRNDMO.EQ.1) THEN
66665 IRNDMO=2
66666 ELSE
66667 GOTO 260
66668 ENDIF
66669 IF(NTRY.GT.1000) THEN
66670 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
66671 IF(MSTU(21).GE.1) RETURN
66672 ENDIF
66673 IF(MMAT.LE.20) THEN
66674 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
66675 & SIN(PARU(2)*PYR(0))
66676 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
66677 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
66678 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
66679 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
66680 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
66681 ELSE
66682 ND=MMAT-20
66683 ENDIF
66684C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
66685 MSTU(125)=ND-NQ/2
66686 IF(MSTU(121).GT.MSTU(125)) GOTO 300
66687
66688C...Form hadrons from flavour content.
66689 DO 310 JT=1,NQ
66690 KFL1(JT)=KFLO(JT)
66691 310 CONTINUE
66692 IF(ND.EQ.NP+NQ/2) GOTO 330
66693 DO 320 I=N+NP+1,N+ND-NQ/2
66694C.. Stick to started popcorn system, else pick side at random
66695 JT=JTMO
66696 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
66697 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
66698 IF(K(I,2).EQ.0) GOTO 300
66699 MSTU(125)=MSTU(125)-1
66700 JTMO=0
66701 IF(MSTU(121).GT.0) JTMO=JT
66702 KFL1(JT)=-KFL2
66703 320 CONTINUE
66704 330 JT=2
66705 JT2=3
66706 JT3=4
66707 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
66708 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
66709 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
66710 IF(JT.EQ.3) JT2=2
66711 IF(JT.EQ.4) JT3=2
66712 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
66713 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
66714 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
66715 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
66716
66717C...Check that sum of decay product masses not too large.
66718 PS=PSP
66719 DO 340 I=N+NP+1,N+ND
66720 K(I,1)=1
66721 K(I,3)=IP
66722 K(I,4)=0
66723 K(I,5)=0
66724 P(I,5)=PYMASS(K(I,2))
66725 PS=PS+P(I,5)
66726 340 CONTINUE
66727 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
66728
66729C...Rescale energy to subtract off spectator quark mass.
66730 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
66731 & .AND.NP.GE.3) THEN
66732 PS=PS-P(N+NP,5)
66733 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
66734 DO 350 J=1,5
66735 P(N+NP,J)=PQT*PV(1,J)
66736 PV(1,J)=(1D0-PQT)*PV(1,J)
66737 350 CONTINUE
66738 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
66739 ND=NP-1
66740 MREM=1
66741
66742C...Fully specified final state: check mass broadening effects.
66743 ELSE
66744 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
66745 ND=NP
66746 ENDIF
66747
66748C...Determine position of grandmother, number of sisters.
66749 NM=0
66750 KFAS=0
66751 MSGN=0
66752 IF(MMAT.EQ.3) THEN
66753 IM=K(IP,3)
66754 IF(IM.LT.0.OR.IM.GE.IP) IM=0
66755 IF(IM.NE.0) KFAM=IABS(K(IM,2))
66756 IF(IM.NE.0) THEN
66757 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
66758 IF(K(IL,3).EQ.IM) NM=NM+1
66759 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
66760 360 CONTINUE
66761 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
66762 & MOD(KFAM/1000,10).NE.0) NM=0
66763 IF(NM.EQ.2) THEN
66764 KFAS=IABS(K(ISIS,2))
66765 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
66766 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
66767 ENDIF
66768 ENDIF
66769 ENDIF
66770
66771C...Kinematics of one-particle decays.
66772 IF(ND.EQ.1) THEN
66773 DO 370 J=1,4
66774 P(N+1,J)=P(IP,J)
66775 370 CONTINUE
66776 GOTO 630
66777 ENDIF
66778
66779C...Calculate maximum weight ND-particle decay.
66780 PV(ND,5)=P(N+ND,5)
66781 IF(ND.GE.3) THEN
66782 WTMAX=1D0/WTCOR(ND-2)
66783 PMAX=PV(1,5)-PS+P(N+ND,5)
66784 PMIN=0D0
66785 DO 380 IL=ND-1,1,-1
66786 PMAX=PMAX+P(N+IL,5)
66787 PMIN=PMIN+P(N+IL+1,5)
66788 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
66789 380 CONTINUE
66790 ENDIF
66791
66792C...Find virtual gamma mass in Dalitz decay.
66793 390 IF(ND.EQ.2) THEN
66794 ELSEIF(MMAT.EQ.2) THEN
66795 PMES=4D0*PMAS(11,1)**2
66796 PMRHO2=PMAS(131,1)**2
66797 PGRHO2=PMAS(131,2)**2
66798 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
66799 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
66800 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
66801 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
66802 IF(WT.LT.PYR(0)) GOTO 400
66803 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
66804
66805C...M-generator gives weight. If rejected, try again.
66806 ELSE
66807 410 RORD(1)=1D0
66808 DO 440 IL1=2,ND-1
66809 RSAV=PYR(0)
66810 DO 420 IL2=IL1-1,1,-1
66811 IF(RSAV.LE.RORD(IL2)) GOTO 430
66812 RORD(IL2+1)=RORD(IL2)
66813 420 CONTINUE
66814 430 RORD(IL2+1)=RSAV
66815 440 CONTINUE
66816 RORD(ND)=0D0
66817 WT=1D0
66818 DO 450 IL=ND-1,1,-1
66819 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
66820 & (PV(1,5)-PS)
66821 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66822 450 CONTINUE
66823 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
66824 ENDIF
66825
66826C...Perform two-particle decays in respective CM frame.
66827 460 DO 480 IL=1,ND-1
66828 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
66829 UE(3)=2D0*PYR(0)-1D0
66830 PHI=PARU(2)*PYR(0)
66831 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
66832 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
66833 DO 470 J=1,3
66834 P(N+IL,J)=PA*UE(J)
66835 PV(IL+1,J)=-PA*UE(J)
66836 470 CONTINUE
66837 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
66838 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
66839 480 CONTINUE
66840
66841C...Lorentz transform decay products to lab frame.
66842 DO 490 J=1,4
66843 P(N+ND,J)=PV(ND,J)
66844 490 CONTINUE
66845 DO 530 IL=ND-1,1,-1
66846 DO 500 J=1,3
66847 BE(J)=PV(IL,J)/PV(IL,4)
66848 500 CONTINUE
66849 GA=PV(IL,4)/PV(IL,5)
66850 DO 520 I=N+IL,N+ND
66851 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
66852 DO 510 J=1,3
66853 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
66854 510 CONTINUE
66855 P(I,4)=GA*(P(I,4)+BEP)
66856 520 CONTINUE
66857 530 CONTINUE
66858
66859C...Check that no infinite loop in matrix element weight.
66860 NTRY=NTRY+1
66861 IF(NTRY.GT.800) GOTO 560
66862
66863C...Matrix elements for omega and phi decays.
66864 IF(MMAT.EQ.1) THEN
66865 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
66866 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
66867 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
66868 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
66869
66870C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
66871 ELSEIF(MMAT.EQ.2) THEN
66872 FOUR12=FOUR(N+1,N+2)
66873 FOUR13=FOUR(N+1,N+3)
66874 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
66875 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
66876 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
66877
66878C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
66879C...V vector), of form cos**2(theta02) in V1 rest frame, and for
66880C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
66881 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
66882 FOUR10=FOUR(IP,IM)
66883 FOUR12=FOUR(IP,N+1)
66884 FOUR02=FOUR(IM,N+1)
66885 PMS1=P(IP,5)**2
66886 PMS0=P(IM,5)**2
66887 PMS2=P(N+1,5)**2
66888 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
66889 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
66890 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
66891 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
66892 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
66893 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
66894
66895C...Matrix element for "onium" -> g + g + g or gamma + g + g.
66896 ELSEIF(MMAT.EQ.4) THEN
66897 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66898 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
66899 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
66900 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
66901 & ((1D0-HX3)/(HX1*HX2))**2
66902 IF(WT.LT.2D0*PYR(0)) GOTO 390
66903 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
66904 & GOTO 390
66905
66906C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
66907 ELSEIF(MMAT.EQ.41) THEN
66908 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
66909 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
66910 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
66911 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
66912
66913C...Matrix elements for weak decays (only semileptonic for c and b)
66914 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66915 & .AND.ND.EQ.3) THEN
66916 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
66917 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
66918 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66919 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
66920 DO 550 J=1,4
66921 P(N+NP+1,J)=0D0
66922 DO 540 IS=N+3,N+NP
66923 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
66924 540 CONTINUE
66925 550 CONTINUE
66926 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
66927 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
66928 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
66929 ENDIF
66930
66931C...Scale back energy and reattach spectator.
66932 560 IF(MREM.EQ.1) THEN
66933 DO 570 J=1,5
66934 PV(1,J)=PV(1,J)/(1D0-PQT)
66935 570 CONTINUE
66936 ND=ND+1
66937 MREM=0
66938 ENDIF
66939
66940C...Low invariant mass for system with spectator quark gives particle,
66941C...not two jets. Readjust momenta accordingly.
66942 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
66943 MSTJ(93)=1
66944 PM2=PYMASS(K(N+2,2))
66945 MSTJ(93)=1
66946 PM3=PYMASS(K(N+3,2))
66947 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
66948 & (PARJ(32)+PM2+PM3)**2) GOTO 630
66949 K(N+2,1)=1
66950 KFTEMP=K(N+2,2)
66951 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
66952 IF(K(N+2,2).EQ.0) GOTO 260
66953 P(N+2,5)=PYMASS(K(N+2,2))
66954 PS=P(N+1,5)+P(N+2,5)
66955 PV(2,5)=P(N+2,5)
66956 MMAT=0
66957 ND=2
66958 GOTO 460
66959 ELSEIF(MMAT.EQ.44) THEN
66960 MSTJ(93)=1
66961 PM3=PYMASS(K(N+3,2))
66962 MSTJ(93)=1
66963 PM4=PYMASS(K(N+4,2))
66964 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
66965 & (PARJ(32)+PM3+PM4)**2) GOTO 600
66966 K(N+3,1)=1
66967 KFTEMP=K(N+3,2)
66968 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
66969 IF(K(N+3,2).EQ.0) GOTO 260
66970 P(N+3,5)=PYMASS(K(N+3,2))
66971 DO 580 J=1,3
66972 P(N+3,J)=P(N+3,J)+P(N+4,J)
66973 580 CONTINUE
66974 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)
66975 HA=P(N+1,4)**2-P(N+2,4)**2
66976 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
66977 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
66978 & (P(N+1,3)-P(N+2,3))**2
66979 HD=(PV(1,4)-P(N+3,4))**2
66980 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
66981 HF=HD*HC-HB**2
66982 HG=HD*HC-HA*HB
66983 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
66984 DO 590 J=1,3
66985 PCOR=HH*(P(N+1,J)-P(N+2,J))
66986 P(N+1,J)=P(N+1,J)+PCOR
66987 P(N+2,J)=P(N+2,J)-PCOR
66988 590 CONTINUE
66989 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)
66990 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)
66991 ND=ND-1
66992 ENDIF
66993
66994C...Check invariant mass of W jets. May give one particle or start over.
66995 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
66996 &.AND.IABS(K(N+1,2)).LT.10) THEN
66997 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
66998 MSTJ(93)=1
66999 PM1=PYMASS(K(N+1,2))
67000 MSTJ(93)=1
67001 PM2=PYMASS(K(N+2,2))
67002 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
67003 KFLDUM=INT(1.5D0+PYR(0))
67004 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
67005 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
67006 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
67007 PSM=PYMASS(KF1)+PYMASS(KF2)
67008 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
67009 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
67010 IF(MMAT.EQ.48) GOTO 390
67011 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
67012 K(N+1,1)=1
67013 KFTEMP=K(N+1,2)
67014 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
67015 IF(K(N+1,2).EQ.0) GOTO 260
67016 P(N+1,5)=PYMASS(K(N+1,2))
67017 K(N+2,2)=K(N+3,2)
67018 P(N+2,5)=P(N+3,5)
67019 PS=P(N+1,5)+P(N+2,5)
67020 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
67021 PV(2,5)=P(N+3,5)
67022 MMAT=0
67023 ND=2
67024 GOTO 460
67025 ENDIF
67026
67027C...Phase space decay of partons from W decay.
67028 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
67029 KFLO(1)=K(N+1,2)
67030 KFLO(2)=K(N+2,2)
67031 K(N+1,1)=K(N+3,1)
67032 K(N+1,2)=K(N+3,2)
67033 DO 620 J=1,5
67034 PV(1,J)=P(N+1,J)+P(N+2,J)
67035 P(N+1,J)=P(N+3,J)
67036 620 CONTINUE
67037 PV(1,5)=PMR
67038 N=N+1
67039 NP=0
67040 NQ=2
67041 PS=0D0
67042 MSTJ(93)=2
67043 PSQ=PYMASS(KFLO(1))
67044 MSTJ(93)=2
67045 PSQ=PSQ+PYMASS(KFLO(2))
67046 MMAT=11
67047 GOTO 290
67048 ENDIF
67049
67050C...Boost back for rapidly moving particle.
67051 630 N=N+ND
67052 IF(MBST.EQ.1) THEN
67053 DO 640 J=1,3
67054 BE(J)=P(IP,J)/P(IP,4)
67055 640 CONTINUE
67056 GA=P(IP,4)/P(IP,5)
67057 DO 660 I=NSAV+1,N
67058 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
67059 DO 650 J=1,3
67060 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
67061 650 CONTINUE
67062 P(I,4)=GA*(P(I,4)+BEP)
67063 660 CONTINUE
67064 ENDIF
67065
67066C...Fill in position of decay vertex.
67067 DO 680 I=NSAV+1,N
67068 DO 670 J=1,4
67069 V(I,J)=VDCY(J)
67070 670 CONTINUE
67071 V(I,5)=0D0
67072 680 CONTINUE
67073
67074C...Set up for parton shower evolution from jets.
67075 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
67076 K(NSAV+1,1)=3
67077 K(NSAV+2,1)=3
67078 K(NSAV+3,1)=3
67079 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67080 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67081 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67082 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67083 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67084 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67085 MSTJ(92)=-(NSAV+1)
67086 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
67087 K(NSAV+2,1)=3
67088 K(NSAV+3,1)=3
67089 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
67090 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
67091 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
67092 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
67093 MSTJ(92)=NSAV+2
67094 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67095 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
67096 K(NSAV+1,1)=3
67097 K(NSAV+2,1)=3
67098 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
67099 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
67100 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
67101 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
67102 MSTJ(92)=NSAV+1
67103 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
67104 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
67105 MSTJ(92)=NSAV+1
67106 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
67107 & THEN
67108 K(NSAV+1,1)=3
67109 K(NSAV+2,1)=3
67110 K(NSAV+3,1)=3
67111 KCP=PYCOMP(K(NSAV+1,2))
67112 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
67113 JCON=4
67114 IF(KQP.LT.0) JCON=5
67115 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
67116 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
67117 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
67118 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
67119 MSTJ(92)=NSAV+1
67120 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
67121 K(NSAV+1,1)=3
67122 K(NSAV+3,1)=3
67123 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
67124 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
67125 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
67126 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
67127 MSTJ(92)=NSAV+1
67128 ENDIF
67129
67130C...Mark decayed particle; special option for B-Bbar mixing.
67131 IF(K(IP,1).EQ.5) K(IP,1)=15
67132 IF(K(IP,1).LE.10) K(IP,1)=11
67133 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
67134 K(IP,4)=NSAV+1
67135 K(IP,5)=N
67136
67137 RETURN
67138 END
67139
67140
67141C*********************************************************************
67142
67143C...PYDCYK
67144C...Handles flavour production in the decay of unstable particles
67145C...and small string clusters.
67146
67147 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
67148
67149C...Double precision and integer declarations.
67150 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67151 IMPLICIT INTEGER(I-N)
67152 INTEGER PYK,PYCHGE,PYCOMP
67153C...Commonblocks.
67154 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67155 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67156 SAVE /PYDAT1/,/PYDAT2/
67157
67158
67159C.. Call PYKFDI directly if no popcorn option is on
67160 IF(MSTJ(12).LT.2) THEN
67161 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67162 MSTU(124)=KFL3
67163 RETURN
67164 ENDIF
67165
67166 KFL3=0
67167 KF=0
67168 IF(KFL1.EQ.0) RETURN
67169 KF1A=IABS(KFL1)
67170 KF2A=IABS(KFL2)
67171
67172 NSTO=130
67173 NMAX=MIN(MSTU(125),10)
67174
67175C.. Identify rank 0 cluster qq
67176 IRANK=1
67177 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
67178
67179 IF(KF2A.GT.0)THEN
67180C.. Join jets: Fails if store not empty
67181 IF(MSTU(121).GT.0) THEN
67182 MSTU(121)=0
67183 RETURN
67184 ENDIF
67185 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
67186 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
67187C.. Pick popcorn meson from store, return same qq, decrease store
67188 KF=MSTU(NSTO+MSTU(121))
67189 KFL3=-KFL1
67190 MSTU(121)=MSTU(121)-1
67191 ELSE
67192C.. Generate new flavour. Then done if no diquark is generated
67193 100 CALL PYKFDI(KFL1,0,KFL3,KF)
67194 IF(MSTU(121).EQ.-1) GOTO 100
67195 MSTU(124)=KFL3
67196 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
67197
67198C.. Simple case if no dynamical popcorn suppressions are considered
67199 IF(MSTJ(12).LT.4) THEN
67200 IF(MSTU(121).EQ.0) RETURN
67201 NMES=1
67202 KFPREV=-KFL3
67203 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67204C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
67205 IF(IABS(KFL3).LE.10)THEN
67206 KFL3=-KFPREV
67207 RETURN
67208 ENDIF
67209 GOTO 120
67210 ENDIF
67211
67212C test output qq against fake Gamma, then return if no popcorn.
67213 GB=2D0
67214 IF(IRANK.NE.0)THEN
67215 CALL PYZDIS(1,2103,5D0,Z)
67216 GB=5D0*(1D0-Z)/Z
67217 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
67218 MSTU(121)=0
67219 GOTO 100
67220 ENDIF
67221 ENDIF
67222 IF(MSTU(121).EQ.0) RETURN
67223
67224C..Set store size memory. Pick fake dynamical variables of qq.
67225 NMES=MSTU(121)
67226 CALL PYPTDI(1,PX3,PY3)
67227 X=1D0
67228 POPM=0D0
67229 G=GB
67230 POPG=GB
67231
67232C.. Pick next popcorn meson, test with fake dynamical variables
67233 110 KFPREV=-KFL3
67234 PX1=-PX3
67235 PY1=-PY3
67236 CALL PYKFDI(KFPREV,0,KFL3,KFM)
67237 IF(MSTU(121).EQ.-1) GOTO 100
67238 CALL PYPTDI(KFL3,PX3,PY3)
67239 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
67240 CALL PYZDIS(KFPREV,KFL3,PM,Z)
67241 G=(1D0-Z)*(G+PM/Z)
67242 X=(1D0-Z)*X
67243
67244 PTST=1D0
67245 GTST=1D0
67246 RTST=PYR(0)
67247 IF(MSTJ(12).GT.4)THEN
67248 POPMN=SQRT((1D0-X)*(G/X-GB))
67249 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
67250 PTST=EXP((POPM-POPMN)*PARF(193))
67251 POPM=POPMN
67252 ENDIF
67253 IF(IRANK.NE.0)THEN
67254 POPGN=X*GB
67255 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
67256 POPG=POPGN
67257 ENDIF
67258 IF(RTST.GT.PTST*GTST)THEN
67259 MSTU(121)=0
67260 IF(RTST.GT.PTST) MSTU(121)=-1
67261 GOTO 100
67262 ENDIF
67263
67264C.. Store meson
67265 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
67266 IF(MSTU(121).GT.0) GOTO 110
67267
67268C.. Test accepted system size. If OK set global popcorn size variable.
67269 IF(NMES.GT.NMAX)THEN
67270 KF=0
67271 KFL3=0
67272 RETURN
67273 ENDIF
67274 MSTU(121)=NMES
67275 ENDIF
67276
67277 RETURN
67278 END
67279
67280C********************************************************************
67281
67282C...PYKFDI
67283C...Generates a new flavour pair and combines off a hadron
67284
67285 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
67286
67287C...Double precision and integer declarations.
67288 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67289 IMPLICIT INTEGER(I-N)
67290 INTEGER PYK,PYCHGE,PYCOMP
67291C...Commonblocks.
67292 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67293 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67294 SAVE /PYDAT1/,/PYDAT2/
67295C...Local arrays.
67296 DIMENSION PD(7)
67297
67298 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
67299
67300C...Default flavour values. Input consistency checks.
67301 KF1A=IABS(KFL1)
67302 KF2A=IABS(KFL2)
67303 KFL3=0
67304 KF=0
67305 IF(KF1A.EQ.0) RETURN
67306 IF(KF2A.NE.0)THEN
67307 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
67308 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
67309 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
67310 ENDIF
67311
67312C...Check if tabulated flavour probabilities are to be used.
67313 IF(MSTJ(15).EQ.1) THEN
67314 IF(MSTJ(12).GE.5) CALL PYERRM(29,
67315 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
67316 & ' together with MSTJ(12)>=5 modification')
67317 KTAB1=-1
67318 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
67319 KFL1A=MOD(KF1A/1000,10)
67320 KFL1B=MOD(KF1A/100,10)
67321 KFL1S=MOD(KF1A,10)
67322 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
67323 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
67324 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
67325 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
67326 KTAB2=0
67327 IF(KF2A.NE.0) THEN
67328 KTAB2=-1
67329 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
67330 KFL2A=MOD(KF2A/1000,10)
67331 KFL2B=MOD(KF2A/100,10)
67332 KFL2S=MOD(KF2A,10)
67333 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
67334 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
67335 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
67336 ENDIF
67337 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
67338 ENDIF
67339
67340C.. Recognize rank 0 diquark case
67341 100 IRANK=1
67342 KFDIQ=MAX(KF1A,KF2A)
67343 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
67344
67345C.. Join two flavours to meson or baryon. Test for popcorn.
67346 IF(KF2A.GT.0)THEN
67347 MBARY=0
67348 IF(KFDIQ.GT.10) THEN
67349 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
67350 & CALL PYNMES(KFDIQ)
67351 IF(MSTU(121).NE.0) THEN
67352 MSTU(121)=0
67353 RETURN
67354 ENDIF
67355 MBARY=2
67356 ENDIF
67357 KFQOLD=KF1A
67358 KFQVER=KF2A
67359 GOTO 130
67360 ENDIF
67361
67362C.. Separate incoming flavours, curtain flavour consistency check
67363 KFIN=KFL1
67364 KFQOLD=KF1A
67365 KFQPOP=KF1A/10000
67366 IF(KF1A.GT.10)THEN
67367 KFIN=-KFL1
67368 KFL1A=MOD(KF1A/1000,10)
67369 KFL1B=MOD(KF1A/100,10)
67370 IF(IRANK.EQ.0)THEN
67371 QAWT=1D0
67372 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
67373 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
67374 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
67375 ENDIF
67376 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
67377 MSTU(121)=0
67378 RETURN
67379 ENDIF
67380 KFQOLD=KFL1A+KFL1B-KFQPOP
67381 ENDIF
67382
67383C...Meson/baryon choice. Set number of mesons if starting a popcorn
67384C...system.
67385 110 MBARY=0
67386 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
67387 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
67388 MBARY=1
67389 CALL PYNMES(0)
67390 ENDIF
67391 ELSEIF(KF1A.GT.10)THEN
67392 MBARY=2
67393 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
67394 IF(MSTU(121).GT.0) MBARY=-1
67395 ENDIF
67396
67397C..x->H+q: Choose single vertex quark. Jump to form hadron.
67398 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
67399 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
67400 KFL3=ISIGN(KFQVER,-KFIN)
67401 GOTO 130
67402 ENDIF
67403
67404C..x->H+qq: (IDW=proper PARF position for diquark weights)
67405 IDW=160
67406 IF(MBARY.EQ.1)THEN
67407 IF(MSTU(121).EQ.0) IDW=150
67408 SQWT=PARF(IDW+1)
67409 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
67410 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
67411C.. Shift to s-curtain parameters if needed
67412 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
67413 PARF(194)=PARF(138)*PARF(139)
67414 PARF(193)=PARJ(8)+PARJ(9)
67415 ENDIF
67416 ENDIF
67417
67418C.. x->H+qq: Get vertex quark
67419 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67420 IDW=MSTU(122)
67421 MSTU(121)=MSTU(121)-1
67422 IF(IDW.EQ.170) THEN
67423 IF(MSTU(121).EQ.0)THEN
67424 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
67425 ELSE
67426 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
67427 ENDIF
67428 ELSE
67429 IF(MSTU(121).EQ.0)THEN
67430 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
67431 ELSE
67432 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
67433 ENDIF
67434 ENDIF
67435 IPOS=200+30*IPOS+1
67436
67437 IMES=-1
67438 RMES=PYR(0)*PARF(194)
67439 120 IMES=IMES+1
67440 RMES=RMES-PARF(IPOS+IMES)
67441 IF(IMES.EQ.30) THEN
67442 MSTU(121)=-1
67443 KF=-111
67444 RETURN
67445 ENDIF
67446 IF(RMES.GT.0D0) GOTO 120
67447 KMUL=IMES/5
67448 KFJ=2*KMUL+1
67449 IF(KMUL.EQ.2) KFJ=10003
67450 IF(KMUL.EQ.3) KFJ=10001
67451 IF(KMUL.EQ.4) KFJ=20003
67452 IF(KMUL.EQ.5) KFJ=5
67453 IDIAG=0
67454 KFQVER=MOD(IMES,5)+1
67455 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
67456 IF(KFQVER.GT.3)THEN
67457 IDIAG=KFQVER-3
67458 KFQVER=KFQOLD
67459 ENDIF
67460 ELSE
67461 IF(MBARY.EQ.-1) IDW=170
67462 SQWT=PARF(IDW+2)
67463 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
67464 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
67465 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
67466 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
67467 KFQVER=KFQPOP
67468 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
67469 ENDIF
67470 ENDIF
67471
67472C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
67473 KFLDS=3
67474 IF(KFQPOP.NE.KFQVER)THEN
67475 SWT=PARF(IDW+7)
67476 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
67477 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
67478 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
67479 ENDIF
67480 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
67481 & +10000*KFQPOP
67482 KFL3=ISIGN(KFDIQ,KFIN)
67483
67484C..x->M+y: flavour for meson.
67485 130 IF(MBARY.LE.0)THEN
67486 KFLA=MAX(KFQOLD,KFQVER)
67487 KFLB=MIN(KFQOLD,KFQVER)
67488 KFS=ISIGN(1,KFL1)
67489 IF(KFLA.NE.KFQOLD) KFS=-KFS
67490C... Form meson, with spin and flavour mixing for diagonal states.
67491 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
67492 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
67493 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
67494 RETURN
67495 ENDIF
67496 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
67497 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
67498 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
67499 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
67500 IF(PYR(0).LT.PARJ(14)) KMUL=2
67501 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
67502 RMUL=PYR(0)
67503 IF(RMUL.LT.PARJ(15)) KMUL=3
67504 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
67505 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
67506 ENDIF
67507 KFLS=3
67508 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
67509 IF(KMUL.EQ.5) KFLS=5
67510 IF(KFLA.NE.KFLB)THEN
67511 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
67512 ELSE
67513 RMIX=PYR(0)
67514 IMIX=2*KFLA+10*KMUL
67515 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
67516 & INT(RMIX+PARF(IMIX)))+KFLS
67517 IF(KFLA.GE.4) KF=110*KFLA+KFLS
67518 ENDIF
67519 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
67520 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
67521
67522C..Optional extra suppression of eta and eta'.
67523C..Allow shift to qq->B+q in old version (set IRANK to 0)
67524 IF(KF.EQ.221.OR.KF.EQ.331)THEN
67525 IF(PYR(0).GT.PARJ(25+KF/300))THEN
67526 IF(KF2A.GT.0) GOTO 130
67527 IF(MSTJ(12).LT.4) IRANK=0
67528 GOTO 110
67529 ENDIF
67530 ENDIF
67531 MSTU(121)=0
67532
67533C.. x->B+y: Flavour for baryon
67534 ELSE
67535 KFLA=KFQVER
67536 IF(KF1A.LE.10) KFLA=KFQOLD
67537 KFLB=MOD(KFDIQ/1000,10)
67538 KFLC=MOD(KFDIQ/100,10)
67539 KFLDS=MOD(KFDIQ,10)
67540 KFLD=MAX(KFLA,KFLB,KFLC)
67541 KFLF=MIN(KFLA,KFLB,KFLC)
67542 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67543
67544C... SU(6) factors for formation of baryon.
67545 KBARY=3
67546 KDMAX=5
67547 KFLG=KFLB
67548 IF(KFLB.NE.KFLC)THEN
67549 KBARY=2*KFLDS-1
67550 KDMAX=1+KFLDS/2
67551 IF(KFLB.GT.2) KDMAX=KDMAX+2
67552 ENDIF
67553 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
67554 KBARY=KBARY+1
67555 KFLG=KFLA
67556 ENDIF
67557
67558 SU6MAX=PARF(140+KDMAX)
67559 SU6DEC=PARJ(18)
67560 SU6S =PARF(146)
67561 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
67562 SU6MAX=1D0
67563 SU6DEC=1D0
67564 SU6S =1D0
67565 ENDIF
67566 SU6OCT=PARF(60+KBARY)
67567 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
67568 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
67569 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
67570 ELSE
67571 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
67572 ENDIF
67573 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
67574
67575C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
67576 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
67577 MSTU(121)=0
67578 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
67579 GOTO 110
67580 ENDIF
67581
67582C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
67583 KSIG=1
67584 KFLS=2
67585 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
67586 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
67587 KSIG=KFLDS/3
67588 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
67589 ENDIF
67590 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
67591 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
67592 ENDIF
b5627c6b 67593C -------------------------------------------------------------------------
67594C Extracted from a private e-mail exchange with Torbjorn Sjostrand
67595C
67596C No, Lambda(1520) is not included and not foreseen.
67597C So if you want it in Pythia, it would have to be a hack.
67598C What you could do is:
67599C 1) In PYKFDI, just before the RETURN above label 140, you could check if
67600C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
67601C probability switch such a particle to the Lambda(1520) code. That is,
67602C if KF = 3122, 3212, or 3214 and a random number below some number, switch
67603C to KF = 3124. (And correspondingly for anticparticles.)
67604C 2) Use the PYUPDA routine (see manual) to include particle and decay data
67605C for the Lambda(1520).
67606C -------------------------------------------------------------------------
67607
67608 IF (IABS(KF).EQ.3122) THEN
67609C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
67610C This fraction is based on the experimental measurement at ISR
67611C Bobbink 83, NP B217,11 (1983)
67612C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
67613 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
67614 ENDIF
67615
67616 IF(IABS(KF).EQ.3212) THEN
67617C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
67618C We suppose the same fraction as for Lambda0
67619 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
67620 ENDIF
67621
67622 IF (IABS(KF).EQ.3214) THEN
67623C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
67624C This is conservative extimate supposing that the ratio
67625C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
67626 IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
67627 ENDIF
02626a96 67628 RETURN
67629
67630C...Use tabulated probabilities to select new flavour and hadron.
67631 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
67632 KT3L=1
67633 KT3U=6
67634 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
67635 KT3L=1
67636 KT3U=6
67637 ELSEIF(KTAB2.EQ.0) THEN
67638 KT3L=1
67639 KT3U=22
67640 ELSE
67641 KT3L=KTAB2
67642 KT3U=KTAB2
67643 ENDIF
67644 RFL=0D0
67645 DO 160 KTS=0,2
67646 DO 150 KT3=KT3L,KT3U
67647 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
67648 150 CONTINUE
67649 160 CONTINUE
67650 RFL=PYR(0)*RFL
67651 DO 180 KTS=0,2
67652 KTABS=KTS
67653 DO 170 KT3=KT3L,KT3U
67654 KTAB3=KT3
67655 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
67656 IF(RFL.LE.0D0) GOTO 190
67657 170 CONTINUE
67658 180 CONTINUE
67659 190 CONTINUE
67660
67661C...Reconstruct flavour of produced quark/diquark.
67662 IF(KTAB3.LE.6) THEN
67663 KFL3A=KTAB3
67664 KFL3B=0
67665 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
67666 ELSE
67667 KFL3A=1
67668 IF(KTAB3.GE.8) KFL3A=2
67669 IF(KTAB3.GE.11) KFL3A=3
67670 IF(KTAB3.GE.16) KFL3A=4
67671 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
67672 KFL3=1000*KFL3A+100*KFL3B+1
67673 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
67674 & KFL3+2
67675 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
67676 ENDIF
67677
67678C...Reconstruct meson code.
67679 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
67680 &KFL3B.NE.0)) THEN
67681 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67682 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
67683 KF=110+2*KTABS+1
67684 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
67685 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
67686 & 25*KTABS)) KF=330+2*KTABS+1
67687 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
67688 KFLA=MAX(KTAB1,KTAB3)
67689 KFLB=MIN(KTAB1,KTAB3)
67690 KFS=ISIGN(1,KFL1)
67691 IF(KFLA.NE.KF1A) KFS=-KFS
67692 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67693 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
67694 KFS=ISIGN(1,KFL1)
67695 IF(KFL1A.EQ.KFL3A) THEN
67696 KFLA=MAX(KFL1B,KFL3B)
67697 KFLB=MIN(KFL1B,KFL3B)
67698 IF(KFLA.NE.KFL1B) KFS=-KFS
67699 ELSEIF(KFL1A.EQ.KFL3B) THEN
67700 KFLA=KFL3A
67701 KFLB=KFL1B
67702 KFS=-KFS
67703 ELSEIF(KFL1B.EQ.KFL3A) THEN
67704 KFLA=KFL1A
67705 KFLB=KFL3B
67706 ELSEIF(KFL1B.EQ.KFL3B) THEN
67707 KFLA=MAX(KFL1A,KFL3A)
67708 KFLB=MIN(KFL1A,KFL3A)
67709 IF(KFLA.NE.KFL1A) KFS=-KFS
67710 ELSE
67711 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
67712 GOTO 100
67713 ENDIF
67714 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
67715
67716C...Reconstruct baryon code.
67717 ELSE
67718 IF(KTAB1.GE.7) THEN
67719 KFLA=KFL3A
67720 KFLB=KFL1A
67721 KFLC=KFL1B
67722 ELSE
67723 KFLA=KFL1A
67724 KFLB=KFL3A
67725 KFLC=KFL3B
67726 ENDIF
67727 KFLD=MAX(KFLA,KFLB,KFLC)
67728 KFLF=MIN(KFLA,KFLB,KFLC)
67729 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
67730 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
67731 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
67732 ENDIF
67733
67734C...Check that constructed flavour code is an allowed one.
67735 IF(KFL2.NE.0) KFL3=0
67736 KC=PYCOMP(KF)
67737 IF(KC.EQ.0) THEN
67738 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
67739 & 'failed')
67740 GOTO 100
67741 ENDIF
67742
67743 RETURN
67744 END
67745
67746C*********************************************************************
67747
67748C...PYNMES
67749C...Generates number of popcorn mesons and stores some relevant
67750C...parameters.
67751
67752 SUBROUTINE PYNMES(KFDIQ)
67753
67754C...Double precision and integer declarations.
67755 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67756 IMPLICIT INTEGER(I-N)
67757 INTEGER PYK,PYCHGE,PYCOMP
67758C...Commonblocks.
67759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67761 SAVE /PYDAT1/,/PYDAT2/
67762
67763 MSTU(121)=0
67764 IF(MSTJ(12).LT.2) RETURN
67765
67766C..Old version: Get 1 or 0 popcorn mesons
67767 IF(MSTJ(12).LT.5)THEN
67768 POPWT=PARF(131)
67769 IF(KFDIQ.NE.0) THEN
67770 KFDIQA=IABS(KFDIQ)
67771 KFA=MOD(KFDIQA/1000,10)
67772 KFB=MOD(KFDIQA/100,10)
67773 KFS=MOD(KFDIQA,10)
67774 POPWT=PARF(132)
67775 IF(KFA.EQ.3) POPWT=PARF(133)
67776 IF(KFB.EQ.3) POPWT=PARF(134)
67777 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
67778 ENDIF
67779 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
67780 RETURN
67781 ENDIF
67782
67783C..New version: Store popcorn- or rank 0 diquark parameters
67784 MSTU(122)=170
67785 PARF(193)=PARJ(8)
67786 PARF(194)=PARF(139)
67787 IF(KFDIQ.NE.0) THEN
67788 MSTU(122)=180
67789 PARF(193)=PARJ(10)
67790 PARF(194)=PARF(140)
67791 ENDIF
67792 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
67793 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
67794 & '(PYNMES:) Neglecting too large popcorn possibility')
67795 RETURN
67796 ENDIF
67797
67798C..New version: Get number of popcorn mesons
67799 100 RTST=PYR(0)
67800 MSTU(121)=-1
67801 110 MSTU(121)=MSTU(121)+1
67802 RTST=RTST/PARF(194)
67803 IF(RTST.LT.1D0) GOTO 110
67804 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
67805 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
67806 RETURN
67807 END
67808
67809C***************************************************************
67810
67811C...PYKFIN
67812C...Precalculates a set of diquark and popcorn weights.
67813
67814 SUBROUTINE PYKFIN
67815
67816C...Double precision and integer declarations.
67817 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67818 IMPLICIT INTEGER(I-N)
67819 INTEGER PYK,PYCHGE,PYCOMP
67820C...Commonblocks.
67821 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67822 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67823 SAVE /PYDAT1/,/PYDAT2/
67824
67825 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
67826
67827
67828 MSTU(123)=1
67829C..Diquark indices for dimensional variables
67830 IUD1=1
67831 IUU1=2
67832 IUS0=3
67833 ISU0=4
67834 IUS1=5
67835 ISU1=6
67836 ISS1=7
67837
67838C.. *** SU(6) factors **
67839C..Modify with decuplet- (and Sigma/Lambda-) suppression.
67840 PARF(146)=1D0
67841 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
67842 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
67843 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
67844 DO 100 I=1,6
67845 SU6(I)=PARF(60+I)
67846 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
67847 100 CONTINUE
67848 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
67849 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
67850 DO 110 I=1,6
67851 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
67852 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
67853 110 CONTINUE
67854
67855C..SU(6)max q q' s,c,b
67856 SU6MUD =MAX(SU6(1) , SU6(8) )
67857 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
67858 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
67859 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
67860 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
67861 SU6M(IUS0)=SU6M(ISU0)
67862 SU6M(ISS1)=SU6M(IUU1)
67863 SU6M(IUS1)=SU6M(ISU1)
67864
67865C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
67866 PARF(141)=SU6MUD
67867 PARF(142)=SU6M(IUD1)
67868 PARF(143)=SU6M(ISU0)
67869 PARF(144)=SU6M(ISU1)
67870 PARF(145)=SU6M(ISS1)
67871
67872C..diquark SU(6) survival =
67873C..sum over quark (quark tunnel weight)*(SU(6)).
67874 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
67875 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
67876 DMB(IUS0)=DMB(ISU0)
67877 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
67878 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
67879 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
67880 DMB(IUS1)=DMB(ISU1)
67881 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
67882
67883C.. *** Tunneling factors for Diquark production***
67884C.. T: half a curtain pair = sqrt(curtain pair factor)
67885 IF(MSTJ(12).GE.5) THEN
67886 PMUD0=PYMASS(2101)
67887 PMUD1=PYMASS(2103)-PMUD0
67888 PMUS0=PYMASS(3201)-PMUD0
67889 PMUS1=PYMASS(3203)-PMUS0-PMUD0
67890 PMSS1=PYMASS(3303)-PMUS0-PMUD0
67891 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
67892 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
67893 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
67894 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
67895 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
67896 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
67897 QBB(IUD1)=QBB(IUU1)
67898 ELSE
67899 PAR2M=SQRT(PARJ(2))
67900 PAR3M=SQRT(PARJ(3))
67901 PAR4M=SQRT(PARJ(4))
67902 QBB(ISU0)=PAR2M*PAR3M
67903 QBB(IUS0)=PAR3M
67904 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
67905 QBB(IUU1)=PAR4M
67906 QBB(ISU1)=PAR4M*QBB(ISU0)
67907 QBB(IUS1)=PAR4M*QBB(IUS0)
67908 QBB(IUD1)=PAR4M
67909 ENDIF
67910
67911C.. tau: spin*(vertex factor)*(T = half-curtain factor)
67912 QBM(ISU0)=QBB(ISU0)
67913 QBM(IUS0)=PARJ(2)*QBB(IUS0)
67914 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
67915 QBM(IUU1)=6D0*QBB(IUU1)
67916 QBM(ISU1)=3D0*QBB(ISU1)
67917 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
67918 QBM(IUD1)=3D0*QBB(IUD1)
67919
67920C.. Combine T and tau to diquark weight for q-> B+B+..
67921 DO 120 I=1,7
67922 QBB(I)=QBB(I)*QBM(I)
67923 120 CONTINUE
67924
67925 IF(MSTJ(12).GE.5)THEN
67926C..New version: tau for rank 0 diquark.
67927 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
67928 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
67929 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
67930 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
67931 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
67932 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
67933 DMB(7+IUD1)=DMB(7+IUU1)/2D0
67934
67935C..New version: curtain flavour ratios.
67936C.. s/u for q->B+M+...
67937C.. s/u for rank 0 diquark: su -> ...M+B+...
67938C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67939 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67940 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67941 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
67942 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
67943 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
67944 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
67945 ELSE
67946C..Old version: reset unused rank 0 diquark weights and
67947C.. unused diquark SU(6) survival weights
67948 DO 130 I=1,7
67949 IF(MSTJ(12).LT.3) DMB(I)=1D0
67950 DMB(7+I)=1D0
67951 130 CONTINUE
67952
67953C..Old version: Shuffle PARJ(7) into tau
67954 QBM(IUS0)=QBM(IUS0)*PARJ(7)
67955 QBM(ISS1)=QBM(ISS1)*PARJ(7)
67956 QBM(IUS1)=QBM(IUS1)*PARJ(7)
67957
67958C..Old version: curtain flavour ratios.
67959C.. s/u for q->B+M+...
67960C.. s/u for rank 0 diquark: su -> ...M+B+...
67961C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
67962 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
67963 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
67964 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
67965 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
67966 ENDIF
67967
67968C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
67969C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
67970 DO 140 I=1,7
67971 DMB(7+I)=DMB(7+I)*DMB(I)
67972 DMB(I)=DMB(I)*QBM(I)
67973 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
67974 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
67975 140 CONTINUE
67976
67977C.. *** Popcorn factors ***
67978
67979 IF(MSTJ(12).LT.5)THEN
67980C.. Old version: Resulting popcorn weights.
67981 PARF(138)=PARJ(6)
67982 WS=PARF(135)*PARF(138)
67983 WQ=WU*PARJ(5)/3D0
67984 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
67985 PARF(133)=WQ*
67986 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
67987 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
67988 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
67989 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
67990 & (1D0+QBB(IUD1)+QBB(IUU1)+
67991 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
67992 ELSE
67993C..New version: Store weights for popcorn mesons,
67994C..get prel. popcorn weights.
67995 DO 150 IPOS=201,1400
67996 PARF(IPOS)=0D0
67997 150 CONTINUE
67998 DO 160 I=138,140
67999 PARF(I)=0D0
68000 160 CONTINUE
68001 IPOS=200
68002 PARF(193)=PARJ(8)
68003 DO 240 MR=0,7,7
68004 IF(MR.EQ.7) PARF(193)=PARJ(10)
68005 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
68006 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
68007 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
68008 DO 230 NMES=0,1
68009 IF(NMES.EQ.1) SQWT=PARJ(2)
68010 DO 220 KFQPOP=1,4
68011 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
68012 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
68013 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
68014 QQWT=0.5D0
68015 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
68016 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
68017 ENDIF
68018 DO 210 KFQOLD =1,5
68019 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
68020 IF(NMES.EQ.1) THEN
68021 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
68022 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
68023 ENDIF
68024 WTTOT=0D0
68025 WTFAIL=0D0
68026 DO 190 KMUL=0,5
68027 PJWT=PARJ(12+KMUL)
68028 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
68029 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
68030 IF(PJWT.LE.0D0) GOTO 190
68031 IF(PJWT.GT.1D0) PJWT=1D0
68032 IMES=5*KMUL
68033 IMIX=2*KFQOLD+10*KMUL
68034 KFJ=2*KMUL+1
68035 IF(KMUL.EQ.2) KFJ=10003
68036 IF(KMUL.EQ.3) KFJ=10001
68037 IF(KMUL.EQ.4) KFJ=20003
68038 IF(KMUL.EQ.5) KFJ=5
68039 DO 180 KFQVER =1,3
68040 KFLA=MAX(KFQOLD,KFQVER)
68041 KFLB=MIN(KFQOLD,KFQVER)
68042 SWT=PARJ(11+KFLA/3+KFLA/4)
68043 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
68044 SWT=SWT*PJWT
68045 QWT=SQWT/(2D0+SQWT)
68046 IF(KFQVER.LT.3)THEN
68047 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
68048 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
68049 ENDIF
68050 IF(KFQVER.NE.KFQOLD)THEN
68051 IMES=IMES+1
68052 KFM=100*KFLA+10*KFLB+KFJ
68053 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68054 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
68055 WTTOT=WTTOT+PARF(IPOS+IMES)
68056 ELSE
68057 DO 170 ID=3,5
68058 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
68059 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
68060 IF(ID.EQ.5) DWT=PARF(IMIX)
68061 KFM=110*(ID-2)+KFJ
68062 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68063 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
68064 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
68065 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
68066 PARF(IPOS+5*KMUL+ID)=
68067 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
68068 ENDIF
68069 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
68070 170 CONTINUE
68071 ENDIF
68072 180 CONTINUE
68073 190 CONTINUE
68074 DO 200 IMES=1,30
68075 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
68076 200 CONTINUE
68077 IF(MR.EQ.7) PARF(140)=
68078 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
68079 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
68080 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
68081 IPOS=IPOS+30
68082 210 CONTINUE
68083 220 CONTINUE
68084 230 CONTINUE
68085 240 CONTINUE
68086 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
68087 MSTU(121)=0
68088
68089 ENDIF
68090
68091C..Recombine diquark weights to flavour and spin ratios
68092 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
68093 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
68094 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
68095 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
68096 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
68097 PARF(155)=QBB(ISU1)/QBB(ISU0)
68098 PARF(156)=QBB(IUS1)/QBB(IUS0)
68099 PARF(157)=QBB(IUD1)
68100
68101 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
68102 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
68103 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
68104 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
68105 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
68106 PARF(165)=QBM(ISU1)/QBM(ISU0)
68107 PARF(166)=QBM(IUS1)/QBM(IUS0)
68108 PARF(167)=QBM(IUD1)
68109
68110 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
68111 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
68112 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
68113 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
68114 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
68115 PARF(175)=DMB(ISU1)/DMB(ISU0)
68116 PARF(176)=DMB(IUS1)/DMB(IUS0)
68117 PARF(177)=DMB(IUD1)
68118
68119 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
68120 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
68121 PARF(187)=DMB(7+IUD1)
68122
68123 RETURN
68124 END
68125
68126
68127C*********************************************************************
68128
68129C...PYPTDI
68130C...Generates transverse momentum according to a Gaussian.
68131
68132 SUBROUTINE PYPTDI(KFL,PX,PY)
68133
68134C...Double precision and integer declarations.
68135 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68136 IMPLICIT INTEGER(I-N)
68137 INTEGER PYK,PYCHGE,PYCOMP
68138C...Commonblocks.
68139 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68140 SAVE /PYDAT1/
68141
68142C...Generate p_T and azimuthal angle, gives p_x and p_y.
68143 KFLA=IABS(KFL)
68144 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
68145 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
68146 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
68147 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
68148 PHI=PARU(2)*PYR(0)
68149 PX=PT*COS(PHI)
68150 PY=PT*SIN(PHI)
68151
68152 RETURN
68153 END
68154
68155C*********************************************************************
68156
68157C...PYZDIS
68158C...Generates the longitudinal splitting variable z.
68159
68160 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
68161
68162C...Double precision and integer declarations.
68163 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68164 IMPLICIT INTEGER(I-N)
68165 INTEGER PYK,PYCHGE,PYCOMP
68166C...Commonblocks.
68167 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68168 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68169 SAVE /PYDAT1/,/PYDAT2/
68170
68171C...Check if heavy flavour fragmentation.
68172 KFLA=IABS(KFL1)
68173 KFLB=IABS(KFL2)
68174 KFLH=KFLA
68175 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
68176
68177C...Lund symmetric scaling function: determine parameters of shape.
68178 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
68179 &MSTJ(11).GE.4) THEN
68180 FA=PARJ(41)
68181 IF(MSTJ(91).EQ.1) FA=PARJ(43)
68182 IF(KFLB.GE.10) FA=FA+PARJ(45)
68183 FBB=PARJ(42)
68184 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
68185 FB=FBB*PR
68186 FC=1D0
68187 IF(KFLA.GE.10) FC=FC-PARJ(45)
68188 IF(KFLB.GE.10) FC=FC+PARJ(45)
68189 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
68190 FRED=PARJ(46)
68191 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
68192 FC=FC+FRED*FBB*PARF(100+KFLH)**2
68193 ENDIF
68194 MC=1
68195 IF(ABS(FC-1D0).GT.0.01D0) MC=2
68196
68197C...Determine position of maximum. Special cases for a = 0 or a = c.
68198 IF(FA.LT.0.02D0) THEN
68199 MA=1
68200 ZMAX=1D0
68201 IF(FC.GT.FB) ZMAX=FB/FC
68202 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
68203 MA=2
68204 ZMAX=FB/(FB+FC)
68205 ELSE
68206 MA=3
68207 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
68208 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
68209 ENDIF
68210
68211C...Subdivide z range if distribution very peaked near endpoint.
68212 MMAX=2
68213 IF(ZMAX.LT.0.1D0) THEN
68214 MMAX=1
68215 ZDIV=2.75D0*ZMAX
68216 IF(MC.EQ.1) THEN
68217 FINT=1D0-LOG(ZDIV)
68218 ELSE
68219 ZDIVC=ZDIV**(1D0-FC)
68220 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
68221 ENDIF
68222 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
68223 MMAX=3
68224 FSCB=SQRT(4D0+(FC/FB)**2)
68225 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
68226 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
68227 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
68228 FINT=1D0+FB*(1D0-ZDIV)
68229 ENDIF
68230
68231C...Choice of z, preweighted for peaks at low or high z.
68232 100 Z=PYR(0)
68233 FPRE=1D0
68234 IF(MMAX.EQ.1) THEN
68235 IF(FINT*PYR(0).LE.1D0) THEN
68236 Z=ZDIV*Z
68237 ELSEIF(MC.EQ.1) THEN
68238 Z=ZDIV**Z
68239 FPRE=ZDIV/Z
68240 ELSE
68241 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
68242 FPRE=(ZDIV/Z)**FC
68243 ENDIF
68244 ELSEIF(MMAX.EQ.3) THEN
68245 IF(FINT*PYR(0).LE.1D0) THEN
68246 Z=ZDIV+LOG(Z)/FB
68247 FPRE=EXP(FB*(Z-ZDIV))
68248 ELSE
68249 Z=ZDIV+Z*(1D0-ZDIV)
68250 ENDIF
68251 ENDIF
68252
68253C...Weighting according to correct formula.
68254 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
68255 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
68256 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
68257 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
68258 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
68259
68260C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
68261 ELSE
68262 FC=PARJ(50+MAX(1,KFLH))
68263 IF(MSTJ(91).EQ.1) FC=PARJ(59)
68264 110 Z=PYR(0)
68265 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
68266 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
68267 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
68268 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
68269 & GOTO 110
68270 ELSE
68271 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
68272 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
68273 ENDIF
68274 ENDIF
68275
68276 RETURN
68277 END
68278
68279C*********************************************************************
68280
68281C...PYSHOW
68282C...Generates timelike parton showers from given partons.
68283
68284 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
68285
68286C...Double precision and integer declarations.
68287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68288 IMPLICIT INTEGER(I-N)
68289 INTEGER PYK,PYCHGE,PYCOMP
68290C...Parameter statement to help give large particle numbers.
68291 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
68292 &KEXCIT=4000000,KDIMEN=5000000)
68293 PARAMETER (MAXNUR=1000)
68294C...Commonblocks.
68295 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
68296 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
68297 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68298 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68299 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
68300 COMMON/PYINT1/MINT(400),VINT(400)
68301 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
68302C...Local arrays.
68303 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
68304 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
68305 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
68306 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
68307 &IREF(1000)
68308
68309C...Check that QMAX not too low.
68310 IF(MSTJ(41).LE.0) THEN
68311 RETURN
68312 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
68313 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
68314 ELSE
68315 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
68316 & RETURN
68317 ENDIF
68318
68319C...Store positions of shower initiating partons.
68320 MPSPD=0
68321 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
68322 NPA=1
68323 IPA(1)=IP1
68324 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
68325 & MSTU(32))) THEN
68326 NPA=2
68327 IPA(1)=IP1
68328 IPA(2)=IP2
68329 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
68330 & .AND.IP2.GE.-80) THEN
68331 NPA=IABS(IP2)
68332 DO 100 I=1,NPA
68333 IPA(I)=IP1+I-1
68334 100 CONTINUE
68335 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
68336 &IP2.EQ.-100) THEN
68337 MPSPD=1
68338 NPA=2
68339 IPA(1)=IP1+6
68340 IPA(2)=IP1+7
68341 ELSE
68342 CALL PYERRM(12,
68343 & '(PYSHOW:) failed to reconstruct showering system')
68344 IF(MSTU(21).GE.1) RETURN
68345 ENDIF
68346
68347C...Send off to PYPTFS for pT-ordered evolution if requested,
68348C...if at least 2 partons, and without predefined shower branchings.
68349 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
68350 &MPSPD.EQ.0) THEN
68351 NPART=NPA
68352 DO 110 II=1,NPART
68353 IPART(II)=IPA(II)
68354 PTPART(II)=0.5D0*QMAX
68355 110 CONTINUE
68356 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
68357 RETURN
68358 ENDIF
68359
68360C...Initialization of cutoff masses etc.
68361 DO 120 IFL=0,40
68362 ISCOL(IFL)=0
68363 ISCHG(IFL)=0
68364 KSH(IFL)=0
68365 120 CONTINUE
68366 ISCOL(21)=1
68367 KSH(21)=1
68368 PMTH(1,21)=PYMASS(21)
68369 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
68370 PMTH(3,21)=2D0*PMTH(2,21)
68371 PMTH(4,21)=PMTH(3,21)
68372 PMTH(5,21)=PMTH(3,21)
68373 PMTH(1,22)=PYMASS(22)
68374 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
68375 PMTH(3,22)=2D0*PMTH(2,22)
68376 PMTH(4,22)=PMTH(3,22)
68377 PMTH(5,22)=PMTH(3,22)
68378 PMQTH1=PARJ(82)
68379 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
68380 PMQT1E=MIN(PMQTH1,PARJ(90))
68381 PMQTH2=PMTH(2,21)
68382 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
68383 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
68384 DO 130 IFL=1,5
68385 ISCOL(IFL)=1
68386 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
68387 KSH(IFL)=1
68388 PMTH(1,IFL)=PYMASS(IFL)
68389 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
68390 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
68391 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68392 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68393 130 CONTINUE
68394 DO 140 IFL=11,15,2
68395 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
68396 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
68397 PMTH(1,IFL)=PYMASS(IFL)
68398 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
68399 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
68400 PMTH(4,IFL)=PMTH(3,IFL)
68401 PMTH(5,IFL)=PMTH(3,IFL)
68402 140 CONTINUE
68403 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
68404 ALAMS=PARJ(81)**2
68405 ALFM=LOG(PT2MIN/ALAMS)
68406
68407C...Check on phase space available for emission.
68408 IREJ=0
68409 DO 150 J=1,5
68410 PS(J)=0D0
68411 150 CONTINUE
68412 PM=0D0
68413 KFLA(2)=0
68414 DO 170 I=1,NPA
68415 KFLA(I)=IABS(K(IPA(I),2))
68416 PMA(I)=P(IPA(I),5)
68417C...Special cutoff masses for initial partons (may be a heavy quark,
68418C...squark, ..., and need not be on the mass shell).
68419 IR=30+I
68420 IF(NPA.LE.1) IREF(I)=IR
68421 IF(NPA.GE.2) IREF(I+1)=IR
68422 ISCOL(IR)=0
68423 ISCHG(IR)=0
68424 KSH(IR)=0
68425 IF(KFLA(I).LE.8) THEN
68426 ISCOL(IR)=1
68427 IF(MSTJ(41).GE.2) ISCHG(IR)=1
68428 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
68429 & KFLA(I).EQ.17) THEN
68430 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
68431 ELSEIF(KFLA(I).EQ.21) THEN
68432 ISCOL(IR)=1
68433 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
68434 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
68435 ISCOL(IR)=1
68436 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
68437 ISCOL(IR)=1
68438C...QUARKONIA+++
68439C...same for QQ~[3S18]
68440 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
68441 & KFLA(I).EQ.9900553)) THEN
68442 ISCOL(IR)=1
68443C...QUARKONIA---
68444 ENDIF
68445
68446C...Option to switch off radiation from particle KF = MSTJ(39) entirely
68447C...(only intended for studying the effects of switching such rad on/off)
68448 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
68449 ISCOL(IR)=0
68450 ISCHG(IR)=0
68451 ENDIF
68452
68453 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
68454 PMTH(1,IR)=PMA(I)
68455 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
68456 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
68457 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
68458 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
68459 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
68460 ELSEIF(ISCOL(IR).EQ.1) THEN
68461 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
68462 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
68463 PMTH(4,IR)=PMTH(3,IR)
68464 PMTH(5,IR)=PMTH(3,IR)
68465 ELSEIF(ISCHG(IR).EQ.1) THEN
68466 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
68467 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
68468 PMTH(4,IR)=PMTH(3,IR)
68469 PMTH(5,IR)=PMTH(3,IR)
68470 ENDIF
68471 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
68472 PM=PM+PMA(I)
68473 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
68474 DO 160 J=1,4
68475 PS(J)=PS(J)+P(IPA(I),J)
68476 160 CONTINUE
68477 170 CONTINUE
68478 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
68479 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
68480 IF(NPA.EQ.1) PS(5)=PS(4)
68481 IF(PS(5).LE.PM+PMQT1E) RETURN
68482
68483C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
68484 KFSRCE=0
68485 IF(IP2.LE.0) THEN
68486 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
68487 KFSRCE=IABS(K(K(IP1,3),2))
68488 ELSE
68489 IPAR1=MAX(1,K(IP1,3))
68490 IPAR2=MAX(1,K(IP2,3))
68491 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
68492 & KFSRCE=IABS(K(K(IPAR1,3),2))
68493 ENDIF
68494 ITYPES=0
68495 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
68496 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
68497 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
68498 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
68499 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
68500 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
68501 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
68502 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
68503
68504C...Identify two primary showerers.
68505 ITYPE1=0
68506 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
68507 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
68508 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
68509 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
68510 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
68511 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
68512 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
68513 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
68514 ITYPE2=0
68515 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
68516 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
68517 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
68518 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
68519 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
68520 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
68521 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
68522 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
68523
68524C...Order of showerers. Presence of gluino.
68525 ITYPMN=MIN(ITYPE1,ITYPE2)
68526 ITYPMX=MAX(ITYPE1,ITYPE2)
68527 IORD=1
68528 IF(ITYPE1.GT.ITYPE2) IORD=2
68529 IGLUI=0
68530 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
68531
68532C...Check if 3-jet matrix elements to be used.
68533 M3JC=0
68534 ALPHA=0.5D0
68535 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
68536 IF(MSTJ(38).NE.0) THEN
68537 M3JC=MSTJ(38)
68538 ALPHA=PARJ(80)
68539 MSTJ(38)=0
68540 ELSEIF(MSTJ(47).GE.6) THEN
68541 M3JC=MSTJ(47)
68542 ELSE
68543 ICLASS=1
68544 ICOMBI=4
68545
68546C...Vector/axial vector -> q + qbar; q -> q + V.
68547 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
68548 & ITYPES.EQ.3)) THEN
68549 ICLASS=2
68550 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
68551 ICOMBI=1
68552 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
68553 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
68554C...gamma*/Z0: assume e+e- initial state if unknown.
68555 EI=-1D0
68556 IF(KFSRCE.EQ.23) THEN
68557 IANNFL=K(K(IP1,3),3)
68558 IF(IANNFL.NE.0) THEN
68559 KANNFL=IABS(K(IANNFL,2))
68560 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
68561 ENDIF
68562 ENDIF
68563 AI=SIGN(1D0,EI+0.1D0)
68564 VI=AI-4D0*EI*PARU(102)
68565 EF=KCHG(KFLA(1),1)/3D0
68566 AF=SIGN(1D0,EF+0.1D0)
68567 VF=AF-4D0*EF*PARU(102)
68568 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
68569 SH=PS(5)**2
68570 SQMZ=PMAS(23,1)**2
68571 SQWZ=PS(5)*PMAS(23,2)
68572 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
68573 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
68574 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
68575 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
68576 ICOMBI=3
68577 ALPHA=VECT/(VECT+AXIV)
68578 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
68579 ICOMBI=4
68580 ENDIF
68581C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
68582 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
68583 ICLASS=2
68584 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68585 & ITYPES.EQ.1)) THEN
68586 ICLASS=3
68587
68588C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
68589 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
68590 ICLASS=4
68591 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
68592 ICOMBI=1
68593 ELSEIF(KFSRCE.EQ.36) THEN
68594 ICOMBI=2
68595 ENDIF
68596 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68597 & ITYPES.EQ.1)) THEN
68598 ICLASS=5
68599
68600C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
68601 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68602 & ITYPES.EQ.3)) THEN
68603 ICLASS=6
68604 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
68605 & ITYPES.EQ.2)) THEN
68606 ICLASS=7
68607 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
68608 ICLASS=8
68609 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
68610 & ITYPES.EQ.2)) THEN
68611 ICLASS=9
68612
68613C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
68614 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
68615 & ITYPES.EQ.5)) THEN
68616 ICLASS=10
68617 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68618 & ITYPES.EQ.2)) THEN
68619 ICLASS=11
68620 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
68621 & ITYPES.EQ.1)) THEN
68622 ICLASS=12
68623
68624C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
68625 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
68626 ICLASS=13
68627 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68628 & ITYPES.EQ.2)) THEN
68629 ICLASS=14
68630 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
68631 & ITYPES.EQ.1)) THEN
68632 ICLASS=15
68633
68634C...g -> ~g + ~g (eikonal approximation).
68635 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
68636 ICLASS=16
68637 ENDIF
68638 M3JC=5*ICLASS+ICOMBI
68639 ENDIF
68640 ENDIF
68641
68642C...Find if interference with initial state partons.
68643 MIIS=0
68644 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
68645 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
68646 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
68647 &MIIS=MSTJ(50)-3
68648 IF(MIIS.NE.0) THEN
68649 DO 190 I=1,2
68650 KCII(I)=0
68651 KCA=PYCOMP(KFLA(I))
68652 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
68653 NIIS(I)=0
68654 IF(KCII(I).NE.0) THEN
68655 DO 180 J=1,2
68656 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
68657 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
68658 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
68659 NIIS(I)=NIIS(I)+1
68660 IIIS(I,NIIS(I))=ICSI
68661 ENDIF
68662 180 CONTINUE
68663 ENDIF
68664 190 CONTINUE
68665 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
68666 ENDIF
68667
68668C...Boost interfering initial partons to rest frame
68669C...and reconstruct their polar and azimuthal angles.
68670 IF(MIIS.NE.0) THEN
68671 DO 210 I=1,2
68672 DO 200 J=1,5
68673 K(N+I,J)=K(IPA(I),J)
68674 P(N+I,J)=P(IPA(I),J)
68675 V(N+I,J)=0D0
68676 200 CONTINUE
68677 210 CONTINUE
68678 DO 230 I=3,2+NIIS(1)
68679 DO 220 J=1,5
68680 K(N+I,J)=K(IIIS(1,I-2),J)
68681 P(N+I,J)=P(IIIS(1,I-2),J)
68682 V(N+I,J)=0D0
68683 220 CONTINUE
68684 230 CONTINUE
68685 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68686 DO 240 J=1,5
68687 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
68688 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
68689 V(N+I,J)=0D0
68690 240 CONTINUE
68691 250 CONTINUE
68692 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
68693 & -PS(2)/PS(4),-PS(3)/PS(4))
68694 PHI=PYANGL(P(N+1,1),P(N+1,2))
68695 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
68696 THE=PYANGL(P(N+1,3),P(N+1,1))
68697 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
68698 DO 260 I=3,2+NIIS(1)
68699 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
68700 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
68701 260 CONTINUE
68702 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
68703 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
68704 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
68705 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
68706 270 CONTINUE
68707 ENDIF
68708
68709C...Boost 3 or more partons to their rest frame.
68710 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
68711 &-PS(2)/PS(4),-PS(3)/PS(4))
68712
68713C...Define imagined single initiator of shower for parton system.
68714 NS=N
68715 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
68716 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68717 IF(MSTU(21).GE.1) RETURN
68718 ENDIF
68719 280 N=NS
68720 IF(NPA.GE.2) THEN
68721 K(N+1,1)=11
68722 K(N+1,2)=21
68723 K(N+1,3)=0
68724 K(N+1,4)=0
68725 K(N+1,5)=0
68726 P(N+1,1)=0D0
68727 P(N+1,2)=0D0
68728 P(N+1,3)=0D0
68729 P(N+1,4)=PS(5)
68730 P(N+1,5)=PS(5)
68731 V(N+1,5)=PS(5)**2
68732 N=N+1
68733 IREF(1)=21
68734 ENDIF
68735
68736C...Loop over partons that may branch.
68737 NEP=NPA
68738 IM=NS
68739 IF(NPA.EQ.1) IM=NS-1
68740 290 IM=IM+1
68741 IF(N.GT.NS) THEN
68742 IF(IM.GT.N) GOTO 600
68743 KFLM=IABS(K(IM,2))
68744 IR=IREF(IM-NS)
68745 IF(KSH(IR).EQ.0) GOTO 290
68746 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
68747 IGM=K(IM,3)
68748 ELSE
68749 IGM=-1
68750 ENDIF
68751 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
68752 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
68753 IF(MSTU(21).GE.1) RETURN
68754 ENDIF
68755
68756C...Position of aunt (sister to branching parton).
68757C...Origin and flavour of daughters.
68758 IAU=0
68759 IF(IGM.GT.0) THEN
68760 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
68761 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
68762 ENDIF
68763 IF(IGM.GE.0) THEN
68764 K(IM,4)=N+1
68765 DO 300 I=1,NEP
68766 K(N+I,3)=IM
68767 300 CONTINUE
68768 ELSE
68769 K(N+1,3)=IPA(1)
68770 ENDIF
68771 IF(IGM.LE.0) THEN
68772 DO 310 I=1,NEP
68773 K(N+I,2)=K(IPA(I),2)
68774 310 CONTINUE
68775 ELSEIF(KFLM.NE.21) THEN
68776 K(N+1,2)=K(IM,2)
68777 K(N+2,2)=K(IM,5)
68778 IREF(N+1-NS)=IREF(IM-NS)
68779 IREF(N+2-NS)=IABS(K(N+2,2))
68780 ELSEIF(K(IM,5).EQ.21) THEN
68781 K(N+1,2)=21
68782 K(N+2,2)=21
68783 IREF(N+1-NS)=21
68784 IREF(N+2-NS)=21
68785 ELSE
68786 K(N+1,2)=K(IM,5)
68787 K(N+2,2)=-K(IM,5)
68788 IREF(N+1-NS)=IABS(K(N+1,2))
68789 IREF(N+2-NS)=IABS(K(N+2,2))
68790 ENDIF
68791
68792C...Reset flags on daughters and tries made.
68793 DO 320 IP=1,NEP
68794 K(N+IP,1)=3
68795 K(N+IP,4)=0
68796 K(N+IP,5)=0
68797 KFLD(IP)=IABS(K(N+IP,2))
68798 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
68799 ITRY(IP)=0
68800 ISL(IP)=0
68801 ISI(IP)=0
68802 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
68803 320 CONTINUE
68804 ISLM=0
68805
68806C...Maximum virtuality of daughters.
68807 IF(IGM.LE.0) THEN
68808 DO 330 I=1,NPA
68809 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
68810 P(N+I,5)=MIN(QMAX,PS(5))
68811 IR=IREF(N+I-NS)
68812 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
68813 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
68814 330 CONTINUE
68815 ELSE
68816 IF(MSTJ(43).LE.2) PEM=V(IM,2)
68817 IF(MSTJ(43).GE.3) PEM=P(IM,4)
68818 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
68819 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
68820 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
68821 ENDIF
68822 DO 340 I=1,NEP
68823 PMSD(I)=P(N+I,5)
68824 IF(ISI(I).EQ.1) THEN
68825 IR=IREF(N+I-NS)
68826 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
68827 ENDIF
68828 V(N+I,5)=P(N+I,5)**2
68829 340 CONTINUE
68830
68831C...Choose one of the daughters for evolution.
68832 350 INUM=0
68833 IF(NEP.EQ.1) INUM=1
68834 DO 360 I=1,NEP
68835 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
68836 360 CONTINUE
68837 DO 370 I=1,NEP
68838 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
68839 IR=IREF(N+I-NS)
68840 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
68841 ENDIF
68842 370 CONTINUE
68843 IF(INUM.EQ.0) THEN
68844 RMAX=0D0
68845 DO 380 I=1,NEP
68846 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
68847 RPM=P(N+I,5)/PMSD(I)
68848 IR=IREF(N+I-NS)
68849 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
68850 RMAX=RPM
68851 INUM=I
68852 ENDIF
68853 ENDIF
68854 380 CONTINUE
68855 ENDIF
68856
68857C...Cancel choice of predetermined daughter already treated.
68858 INUM=MAX(1,INUM)
68859 INUMT=INUM
68860 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
68861 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
68862 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
68863 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
68864 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
68865 ENDIF
68866
68867C...Store information on choice of evolving daughter.
68868 IEP(1)=N+INUM
68869 DO 390 I=2,NEP
68870 IEP(I)=IEP(I-1)+1
68871 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
68872 390 CONTINUE
68873 DO 400 I=1,NEP
68874 KFL(I)=IABS(K(IEP(I),2))
68875 400 CONTINUE
68876 ITRY(INUM)=ITRY(INUM)+1
68877 IF(ITRY(INUM).GT.200) THEN
68878 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
68879 IF(MSTU(21).GE.1) RETURN
68880 ENDIF
68881 Z=0.5D0
68882 IR=IREF(IEP(1)-NS)
68883 IF(KSH(IR).EQ.0) GOTO 450
68884 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
68885
68886C...Check if evolution already predetermined for daughter.
68887 IPSPD=0
68888 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
68889 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
68890 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
68891 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
68892 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
68893 ENDIF
68894 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
68895 ISSET(INUM)=0
68896 IF(IPSPD.NE.0) ISSET(INUM)=1
68897 ENDIF
68898
68899C...Select side for interference with initial state partons.
68900 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
68901 III=IEP(1)-NS-1
68902 ISII(III)=0
68903 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
68904 ISII(III)=1
68905 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
68906 IF(PYR(0).GT.0.5D0) ISII(III)=1
68907 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
68908 ISII(III)=1
68909 IF(PYR(0).GT.0.5D0) ISII(III)=2
68910 ENDIF
68911 ENDIF
68912
68913C...Calculate allowed z range.
68914 IF(NEP.EQ.1) THEN
68915 PMED=PS(4)
68916 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
68917 PMED=P(IM,5)
68918 ELSE
68919 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
68920 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
68921 ENDIF
68922 IF(MOD(MSTJ(43),2).EQ.1) THEN
68923 ZC=PMTH(2,21)/PMED
68924 ZCE=PMTH(2,22)/PMED
68925 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
68926 ELSE
68927 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
68928 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
68929 PMTMPE=PMTH(2,22)
68930 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
68931 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
68932 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
68933 ENDIF
68934 ZC=MIN(ZC,0.491D0)
68935 ZCE=MIN(ZCE,0.49991D0)
68936 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
68937 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
68938 P(IEP(1),5)=PMTH(1,IR)
68939 V(IEP(1),5)=P(IEP(1),5)**2
68940 GOTO 450
68941 ENDIF
68942
68943C...Integral of Altarelli-Parisi z kernel for QCD.
68944C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
68945 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
68946 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
68947C...QUARKONIA+++
68948C...Evolution of QQ~[3S18] state if MSTP(148)=1.
68949 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
68950 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
68951 FBR=6D0*LOG((1D0-ZC)/ZC)
68952C...QUARKONIA---
68953 ELSEIF(MSTJ(49).EQ.0) THEN
68954 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
68955 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
68956
68957C...Integral of Altarelli-Parisi z kernel for scalar gluon.
68958 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
68959 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
68960 ELSEIF(MSTJ(49).EQ.1) THEN
68961 FBR=(1D0-2D0*ZC)/3D0
68962 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
68963
68964C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
68965 ELSEIF(KFL(1).EQ.21) THEN
68966 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
68967 ELSE
68968 FBR=2D0*LOG((1D0-ZC)/ZC)
68969 ENDIF
68970
68971C...Reset QCD probability for colourless.
68972 IF(ISCOL(IR).EQ.0) FBR=0D0
68973
68974C...Integral of Altarelli-Parisi kernel for photon emission.
68975 FBRE=0D0
68976 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
68977 IF(KFL(1).LE.18) THEN
68978 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
68979 ENDIF
68980 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
68981 ENDIF
68982
68983C...Inner veto algorithm starts. Find maximum mass for evolution.
68984 410 PMS=V(IEP(1),5)
68985 IF(IGM.GE.0) THEN
68986 PM2=0D0
68987 DO 420 I=2,NEP
68988 PM=P(IEP(I),5)
68989 IRI=IREF(IEP(I)-NS)
68990 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
68991 PM2=PM2+PM
68992 420 CONTINUE
68993 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
68994 ENDIF
68995
68996C...Select mass for daughter in QCD evolution.
68997 B0=27D0/6D0
68998 DO 430 IFF=4,MSTJ(45)
68999 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
69000 430 CONTINUE
69001C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
69002 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
69003C...Already predetermined choice.
69004 IF(IPSPD.NE.0) THEN
69005 PMSQCD=P(IPSPD,5)**2
69006 ELSEIF(FBR.LT.1D-3) THEN
69007 PMSQCD=0D0
69008 ELSEIF(MSTJ(44).LE.0) THEN
69009 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
69010 ELSEIF(MSTJ(44).EQ.1) THEN
69011 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
69012 ELSE
69013 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
69014 ENDIF
69015C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
69016 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
69017 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
69018 V(IEP(1),5)=PMSQCD
69019 MCE=1
69020
69021C...Select mass for daughter in QED evolution.
69022 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
69023C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
69024 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
69025 IF(FBRE.LT.1D-3) THEN
69026 PMSQED=0D0
69027 ELSE
69028 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
69029 & (PARU(101)*FBRE)))
69030 ENDIF
69031C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
69032 PMSQED=PMSQED+PMTH(1,IR)**2
69033 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
69034 & PMTH(2,IR)**2
69035 IF(PMSQED.GT.PMSQCD) THEN
69036 V(IEP(1),5)=PMSQED
69037 MCE=2
69038 ENDIF
69039 ENDIF
69040
69041C...Check whether daughter mass below cutoff.
69042 P(IEP(1),5)=SQRT(V(IEP(1),5))
69043 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
69044 P(IEP(1),5)=PMTH(1,IR)
69045 V(IEP(1),5)=P(IEP(1),5)**2
69046 GOTO 450
69047 ENDIF
69048
69049C...Already predetermined choice of z, and flavour in g -> qqbar.
69050 IF(IPSPD.NE.0) THEN
69051 IPSGD1=K(IPSPD,4)
69052 IPSGD2=K(IPSPD,5)
69053 PMSGD1=P(IPSGD1,5)**2
69054 PMSGD2=P(IPSGD2,5)**2
69055 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
69056 & 4D0*PMSGD1*PMSGD2))
69057 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
69058 & PMSGD1+PMSGD2)/ALAMPS
69059 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
69060 IF(KFL(1).NE.21) THEN
69061 K(IEP(1),5)=21
69062 ELSE
69063 K(IEP(1),5)=IABS(K(IPSGD1,2))
69064 ENDIF
69065
69066C...Select z value of branching: q -> qgamma.
69067 ELSEIF(MCE.EQ.2) THEN
69068 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
69069 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69070 K(IEP(1),5)=22
69071
69072C...QUARKONIA+++
69073C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
69074 ELSEIF(MSTJ(49).EQ.0.AND.
69075 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
69076 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69077C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
69078 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
69079 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69080 K(IEP(1),5)=21
69081C...QUARKONIA---
69082
69083C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
69084 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
69085 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69086C...Only do z weighting when no ME correction afterwards.
69087 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
69088 K(IEP(1),5)=21
69089 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
69090 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
69091 IF(PYR(0).GT.0.5D0) Z=1D0-Z
69092 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
69093 K(IEP(1),5)=21
69094 ELSEIF(MSTJ(49).NE.1) THEN
69095 Z=PYR(0)
69096 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
69097 KFLB=1+INT(MSTJ(45)*PYR(0))
69098 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69099 IF(PMQ.GE.1D0) GOTO 410
69100 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
69101 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
69102 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
69103 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
69104 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
69105 ELSE
69106 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
69107 ENDIF
69108 K(IEP(1),5)=KFLB
69109
69110C...Ditto for scalar gluon model.
69111 ELSEIF(KFL(1).NE.21) THEN
69112 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
69113 K(IEP(1),5)=21
69114 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
69115 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69116 K(IEP(1),5)=21
69117 ELSE
69118 Z=ZC+(1D0-2D0*ZC)*PYR(0)
69119 KFLB=1+INT(MSTJ(45)*PYR(0))
69120 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
69121 IF(PMQ.GE.1D0) GOTO 410
69122 K(IEP(1),5)=KFLB
69123 ENDIF
69124
69125C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
69126 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
69127 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69128 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69129 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
69130 ELSE
69131 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
69132 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
69133 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
69134 IF(PT2APP.LT.PT2MIN) GOTO 410
69135 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
69136 ENDIF
69137 ENDIF
69138
69139C...Check if z consistent with chosen m.
69140 IF(KFL(1).EQ.21) THEN
69141 IRGD1=IABS(K(IEP(1),5))
69142 IRGD2=IRGD1
69143 ELSE
69144 IRGD1=IR
69145 IRGD2=IABS(K(IEP(1),5))
69146 ENDIF
69147 IF(NEP.EQ.1) THEN
69148 PED=PS(4)
69149 ELSEIF(NEP.GE.3) THEN
69150 PED=P(IEP(1),4)
69151 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69152 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
69153 ELSE
69154 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
69155 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
69156 ENDIF
69157 IF(MOD(MSTJ(43),2).EQ.1) THEN
69158 PMQTH3=0.5D0*PARJ(82)
69159 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69160 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
69161 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
69162 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
69163 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69164 & 4D0*PMQ1*PMQ2)))
69165 ZH=1D0+PMQ1-PMQ2
69166 ELSE
69167 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
69168 ZH=1D0
69169 ENDIF
69170 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
69171 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69172 ELSEIF(IPSPD.NE.0) THEN
69173 ELSE
69174 ZL=0.5D0*(ZH-ZD)
69175 ZU=0.5D0*(ZH+ZD)
69176 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
69177 ENDIF
69178 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
69179 &(1D0-ZU)))
69180 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69181
69182C...Width suppression for q -> q + g.
69183 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
69184 IF(IGM.EQ.0) THEN
69185 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
69186 ELSE
69187 EGLU=PMED*(1D0-Z)
69188 ENDIF
69189 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
69190 IF(MSTJ(40).EQ.1) THEN
69191 IF(CHI.LT.PYR(0)) GOTO 410
69192 ELSEIF(MSTJ(40).EQ.2) THEN
69193 IF(1D0-CHI.LT.PYR(0)) GOTO 410
69194 ENDIF
69195 ENDIF
69196
69197C...Three-jet matrix element correction.
69198 IF(M3JC.GE.1) THEN
69199 WME=1D0
69200 WSHOW=1D0
69201
69202C...QED matrix elements: only for massless case so far.
69203 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
69204 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69205 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69206 X3=(1D0-X1)+(1D0-X2)
69207 KI1=K(IPA(INUM),2)
69208 KI2=K(IPA(3-INUM),2)
69209 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
69210 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
69211 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
69212 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
69213 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
69214 ELSEIF(MCE.EQ.2) THEN
69215
69216C...QCD matrix elements, including mass effects.
69217 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
69218 PS1ME=V(IEP(1),5)
69219 PM1ME=PMTH(1,IR)
69220 M3JCC=M3JC
69221 IF(IR.GE.31.AND.IGM.EQ.0) THEN
69222C...QCD ME: original parton, first branching.
69223 PM2ME=PMTH(1,63-IR)
69224 ECMME=PS(5)
69225 ELSEIF(IR.GE.31) THEN
69226C...QCD ME: original parton, subsequent branchings.
69227 PM2ME=PMTH(1,63-IR)
69228 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69229 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69230 ELSEIF(K(IM,2).EQ.21) THEN
69231C...QCD ME: secondary partons, first branching.
69232 PM2ME=PM1ME
69233 ZMME=V(IM,1)
69234 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
69235 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
69236 & 4D0*PS1ME*PM2ME**2))
69237 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
69238 & V(IM,5)
69239 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69240 M3JCC=66
69241 ELSE
69242C...QCD ME: secondary partons, subsequent branchings.
69243 PM2ME=PM1ME
69244 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
69245 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
69246 M3JCC=66
69247 ENDIF
69248C...Construct ME variables.
69249 R1ME=PM1ME/ECMME
69250 R2ME=PM2ME/ECMME
69251 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
69252 X2=1D0+R2ME**2-PS1ME/ECMME**2
69253C...Call ME, with right order important for two inequivalent showerers.
69254 IF(IR.EQ.IORD+30) THEN
69255 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
69256 ELSE
69257 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
69258 ENDIF
69259C...Split up total ME when two radiating partons.
69260 ISPRAD=1
69261 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
69262 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
69263 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
69264 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
69265 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
69266 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
69267 & MAX(1D-10,2D0-X1-X2)
69268C...Evaluate shower rate to be compared with.
69269 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
69270 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
69271 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
69272 ELSEIF(MSTJ(49).NE.1) THEN
69273
69274C...Toy model scalar theory matrix elements; no mass effects.
69275 ELSE
69276 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
69277 X2=1D0-V(IEP(1),5)/V(NS+1,5)
69278 X3=(1D0-X1)+(1D0-X2)
69279 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
69280 WME=X3**2
69281 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
69282 & PARJ(171)
69283 ENDIF
69284
69285 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
69286 ENDIF
69287
69288C...Impose angular ordering by rejection of nonordered emission.
69289 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
69290 PEMAO=V(IM,1)*P(IM,4)
69291 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
69292 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
69293 MAOD=0
69294 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
69295 & .OR.MSTJ(42).EQ.7)) THEN
69296 MAOD=0
69297 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
69298 & .OR.MSTJ(42).EQ.6)) THEN
69299 MAOD=1
69300 PMDAO=PMTH(2,K(IEP(1),5))
69301 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
69302 ELSE
69303 MAOD=1
69304 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
69305 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
69306 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
69307 ENDIF
69308 MAOM=1
69309 IAOM=IM
69310 440 IF(K(IAOM,5).EQ.22) THEN
69311 IAOM=K(IAOM,3)
69312 IF(K(IAOM,3).LE.NS) MAOM=0
69313 IF(MAOM.EQ.1) GOTO 440
69314 ENDIF
69315 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
69316 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
69317 IF(THE2ID.LT.THE2IM) GOTO 410
69318 ENDIF
69319 ENDIF
69320
69321C...Impose user-defined maximum angle at first branching.
69322 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
69323 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
69324 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
69325 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69326 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
69327 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69328 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
69329 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
69330 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
69331 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
69332 ENDIF
69333 ENDIF
69334
69335C...Impose angular constraint in first branching from interference
69336C...with initial state partons.
69337 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
69338 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
69339 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
69340 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
69341 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
69342 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
69343 ENDIF
69344 ENDIF
69345
69346C...End of inner veto algorithm. Check if only one leg evolved so far.
69347 450 V(IEP(1),1)=Z
69348 ISL(1)=0
69349 ISL(2)=0
69350 IF(NEP.EQ.1) GOTO 490
69351 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
69352 DO 460 I=1,NEP
69353 IR=IREF(N+I-NS)
69354 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
69355 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
69356 ENDIF
69357 460 CONTINUE
69358
69359C...Check if chosen multiplet m1,m2,z1,z2 is physical.
69360 IF(NEP.GE.3) THEN
69361 PMSUM=0D0
69362 DO 470 I=1,NEP
69363 PMSUM=PMSUM+P(N+I,5)
69364 470 CONTINUE
69365 IF(PMSUM.GE.PS(5)) GOTO 350
69366 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
69367 DO 480 I1=N+1,N+2
69368 IRDA=IREF(I1-NS)
69369 IF(KSH(IRDA).EQ.0) GOTO 480
69370 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
69371 IF(IRDA.EQ.21) THEN
69372 IRGD1=IABS(K(I1,5))
69373 IRGD2=IRGD1
69374 ELSE
69375 IRGD1=IRDA
69376 IRGD2=IABS(K(I1,5))
69377 ENDIF
69378 I2=2*N+3-I1
69379 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
69380 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
69381 ELSE
69382 IF(I1.EQ.N+1) ZM=V(IM,1)
69383 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
69384 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
69385 & 4D0*V(N+1,5)*V(N+2,5))
69386 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
69387 & V(IM,5)
69388 ENDIF
69389 IF(MOD(MSTJ(43),2).EQ.1) THEN
69390 PMQTH3=0.5D0*PARJ(82)
69391 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
69392 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
69393 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
69394 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
69395 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
69396 & 4D0*PMQ1*PMQ2)))
69397 ZH=1D0+PMQ1-PMQ2
69398 ELSE
69399 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
69400 ZH=1D0
69401 ENDIF
69402 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
69403 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69404 ELSE
69405 ZL=0.5D0*(ZH-ZD)
69406 ZU=0.5D0*(ZH+ZD)
69407 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69408 & ISSET(1).EQ.0) THEN
69409 ISL(1)=1
69410 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
69411 & ISSET(2).EQ.0) THEN
69412 ISL(2)=1
69413 ENDIF
69414 ENDIF
69415 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
69416 & ZL*(1D0-ZU)))
69417 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
69418 480 CONTINUE
69419 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
69420 ISL(3-ISLM)=0
69421 ISLM=3-ISLM
69422 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
69423 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
69424 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
69425 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
69426 IF(ISL(1).EQ.1) ISL(2)=0
69427 IF(ISL(1).EQ.0) ISLM=1
69428 IF(ISL(2).EQ.0) ISLM=2
69429 ENDIF
69430 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
69431 ENDIF
69432 IRD1=IREF(N+1-NS)
69433 IRD2=IREF(N+2-NS)
69434 IF(IGM.GT.0) THEN
69435 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
69436 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
69437 PMQ1=V(N+1,5)/V(IM,5)
69438 PMQ2=V(N+2,5)/V(IM,5)
69439 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
69440 & 4D0*PMQ1*PMQ2)))
69441 ZH=1D0+PMQ1-PMQ2
69442 ZL=0.5D0*(ZH-ZD)
69443 ZU=0.5D0*(ZH+ZD)
69444 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
69445 ENDIF
69446 ENDIF
69447
69448C...Accepted branch. Construct four-momentum for initial partons.
69449 490 MAZIP=0
69450 MAZIC=0
69451 IF(NEP.EQ.1) THEN
69452 P(N+1,1)=0D0
69453 P(N+1,2)=0D0
69454 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
69455 & P(N+1,5))))
69456 P(N+1,4)=P(IPA(1),4)
69457 V(N+1,2)=P(N+1,4)
69458 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
69459 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
69460 P(N+1,1)=0D0
69461 P(N+1,2)=0D0
69462 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
69463 P(N+1,4)=PED1
69464 P(N+2,1)=0D0
69465 P(N+2,2)=0D0
69466 P(N+2,3)=-P(N+1,3)
69467 P(N+2,4)=P(IM,5)-PED1
69468 V(N+1,2)=P(N+1,4)
69469 V(N+2,2)=P(N+2,4)
69470 ELSEIF(NEP.GE.3) THEN
69471C...Rescale all momenta for energy conservation.
69472 LOOP=0
69473 PES=0D0
69474 PQS=0D0
69475 DO 510 I=1,NEP
69476 DO 500 J=1,4
69477 P(N+I,J)=P(IPA(I),J)
69478 500 CONTINUE
69479 PES=PES+P(N+I,4)
69480 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69481 510 CONTINUE
69482 520 LOOP=LOOP+1
69483 FAC=(PS(5)-PQS)/(PES-PQS)
69484 PES=0D0
69485 PQS=0D0
69486 DO 540 I=1,NEP
69487 DO 530 J=1,3
69488 P(N+I,J)=FAC*P(N+I,J)
69489 530 CONTINUE
69490 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)
69491 V(N+I,2)=P(N+I,4)
69492 PES=PES+P(N+I,4)
69493 PQS=PQS+P(N+I,5)**2/P(N+I,4)
69494 540 CONTINUE
69495 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
69496
69497C...Construct transverse momentum for ordinary branching in shower.
69498 ELSE
69499 ZM=V(IM,1)
69500 LOOPPT=0
69501 550 LOOPPT=LOOPPT+1
69502 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
69503 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
69504 IF(PZM.LE.0D0) THEN
69505 PTS=0D0
69506 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69507 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69508 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
69509 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69510 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
69511 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
69512 ELSE
69513 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
69514 ENDIF
69515 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
69516 ZM=0.05D0+0.9D0*ZM
69517 GOTO 550
69518 ELSEIF(PTS.LT.0D0) THEN
69519 GOTO 280
69520 ENDIF
69521 PT=SQRT(MAX(0D0,PTS))
69522
69523C...Global statistics.
69524 MINT(353)=MINT(353)+1
69525 VINT(353)=VINT(353)+PT
69526 IF (MINT(353).EQ.1) VINT(358)=PT
69527
69528C...Find coefficient of azimuthal asymmetry due to gluon polarization.
69529 HAZIP=0D0
69530 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
69531 & .AND.IAU.NE.0) THEN
69532 IF(K(IGM,3).NE.0) MAZIP=1
69533 ZAU=V(IGM,1)
69534 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
69535 IF(MAZIP.EQ.0) ZAU=0D0
69536 IF(K(IGM,2).NE.21) THEN
69537 HAZIP=2D0*ZAU/(1D0+ZAU**2)
69538 ELSE
69539 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
69540 ENDIF
69541 IF(K(N+1,2).NE.21) THEN
69542 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
69543 ELSE
69544 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
69545 ENDIF
69546 ENDIF
69547
69548C...Find coefficient of azimuthal asymmetry due to soft gluon
69549C...interference.
69550 HAZIC=0D0
69551 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
69552 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
69553 IF(K(IGM,3).NE.0) MAZIC=N+1
69554 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
69555 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69556 & ZM.GT.0.5D0) MAZIC=N+2
69557 IF(K(IAU,2).EQ.22) MAZIC=0
69558 ZS=ZM
69559 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
69560 ZGM=V(IGM,1)
69561 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
69562 IF(MAZIC.EQ.0) ZGM=1D0
69563 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
69564 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
69565 HAZIC=MIN(0.95D0,HAZIC)
69566 ENDIF
69567 ENDIF
69568
69569C...Construct energies for ordinary branching in shower.
69570 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
69571 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69572 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69573 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69574 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69575 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
69576 P(N+1,4)=PEM*V(IM,1)
69577 ELSE
69578 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
69579 & SQRT(PMLS)*ZM)/V(IM,5)
69580 ENDIF
69581
69582C...Already predetermined choice of phi angle or not
69583 PHI=PARU(2)*PYR(0)
69584 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
69585 IPSPD=IP1+IM-NS-2
69586 IF(K(IPSPD,4).GT.0) THEN
69587 IPSGD1=K(IPSPD,4)
69588 IF(IM.EQ.NS+2) THEN
69589 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69590 ELSE
69591 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
69592 ENDIF
69593 ENDIF
69594 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
69595 IPSPD=IP1+IM-NS-2
69596 IF(K(IPSPD,4).GT.0) THEN
69597 IPSGD1=K(IPSPD,4)
69598 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
69599 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
69600 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
69601 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
69602 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
69603 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
69604 ENDIF
69605 ENDIF
69606
69607C...Construct momenta for ordinary branching in shower.
69608 P(N+1,1)=PT*COS(PHI)
69609 P(N+1,2)=PT*SIN(PHI)
69610 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
69611 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
69612 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
69613 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
69614 ELSEIF(PZM.GT.0D0) THEN
69615 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
69616 & 2D0*PEM*P(N+1,4))/PZM
69617 ELSE
69618 P(N+1,3)=0D0
69619 ENDIF
69620 P(N+2,1)=-P(N+1,1)
69621 P(N+2,2)=-P(N+1,2)
69622 P(N+2,3)=PZM-P(N+1,3)
69623 P(N+2,4)=PEM-P(N+1,4)
69624 IF(MSTJ(43).LE.2) THEN
69625 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
69626 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
69627 ENDIF
69628 ENDIF
69629
69630C...Rotate and boost daughters.
69631 IF(IGM.GT.0) THEN
69632 IF(MSTJ(43).LE.2) THEN
69633 BEX=P(IGM,1)/P(IGM,4)
69634 BEY=P(IGM,2)/P(IGM,4)
69635 BEZ=P(IGM,3)/P(IGM,4)
69636 GA=P(IGM,4)/P(IGM,5)
69637 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
69638 & P(IM,4))
69639 ELSE
69640 BEX=0D0
69641 BEY=0D0
69642 BEZ=0D0
69643 GA=1D0
69644 GABEP=0D0
69645 ENDIF
69646 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
69647 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
69648 IF(PTIMB.GT.1D-4) THEN
69649 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
69650 ELSE
69651 PHI=0D0
69652 ENDIF
69653 DO 570 I=N+1,N+2
69654 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
69655 & SIN(THE)*COS(PHI)*P(I,3)
69656 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
69657 & SIN(THE)*SIN(PHI)*P(I,3)
69658 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
69659 DP(4)=P(I,4)
69660 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
69661 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
69662 P(I,1)=DP(1)+DGABP*BEX
69663 P(I,2)=DP(2)+DGABP*BEY
69664 P(I,3)=DP(3)+DGABP*BEZ
69665 P(I,4)=GA*(DP(4)+DBP)
69666 570 CONTINUE
69667 ENDIF
69668
69669C...Weight with azimuthal distribution, if required.
69670 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
69671 DO 580 J=1,3
69672 DPT(1,J)=P(IM,J)
69673 DPT(2,J)=P(IAU,J)
69674 DPT(3,J)=P(N+1,J)
69675 580 CONTINUE
69676 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
69677 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
69678 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
69679 DO 590 J=1,3
69680 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
69681 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
69682 590 CONTINUE
69683 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
69684 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
69685 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
69686 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
69687 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
69688 IF(MAZIP.NE.0) THEN
69689 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
69690 & GOTO 560
69691 ENDIF
69692 IF(MAZIC.NE.0) THEN
69693 IF(MAZIC.EQ.N+2) CAD=-CAD
69694 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
69695 & .LT.PYR(0)) GOTO 560
69696 ENDIF
69697 ENDIF
69698 ENDIF
69699
69700C...Azimuthal anisotropy due to interference with initial state partons.
69701 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
69702 &K(N+2,2).EQ.21)) THEN
69703 III=IM-NS-1
69704 IF(ISII(III).GE.1) THEN
69705 IAZIID=N+1
69706 IF(K(N+1,2).NE.21) IAZIID=N+2
69707 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
69708 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
69709 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
69710 IF(III.EQ.2) THEIID=PARU(1)-THEIID
69711 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
69712 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
69713 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
69714 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
69715 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
69716 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
69717 & .LT.PYR(0)) GOTO 560
69718 ENDIF
69719 ENDIF
69720
69721C...Continue loop over partons that may branch, until none left.
69722 IF(IGM.GE.0) K(IM,1)=14
69723 N=N+NEP
69724 NEP=2
69725 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
69726 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
69727 IF(MSTU(21).GE.1) N=NS
69728 IF(MSTU(21).GE.1) RETURN
69729 ENDIF
69730 GOTO 290
69731
69732C...Set information on imagined shower initiator.
69733 600 IF(NPA.GE.2) THEN
69734 K(NS+1,1)=11
69735 K(NS+1,2)=94
69736 K(NS+1,3)=IP1
69737 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
69738 K(NS+1,4)=NS+2
69739 K(NS+1,5)=NS+1+NPA
69740 IIM=1
69741 ELSE
69742 IIM=0
69743 ENDIF
69744
69745C...Reconstruct string drawing information.
69746 DO 610 I=NS+1+IIM,N
69747 KQ=KCHG(PYCOMP(K(I,2)),2)
69748 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
69749 K(I,1)=1
69750 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
69751 & IABS(K(I,2)).LE.18) THEN
69752 K(I,1)=1
69753 ELSEIF(K(I,1).LE.10) THEN
69754 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
69755 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
69756 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
69757 ID1=MOD(K(I,4),MSTU(5))
69758 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
69759 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
69760 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
69761 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
69762 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69763 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
69764 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69765 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
69766 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
69767 K(ID2,5)=K(ID2,5)+MSTU(5)*I
69768 ELSE
69769 ID1=MOD(K(I,4),MSTU(5))
69770 ID2=ID1+1
69771 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
69772 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
69773 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
69774 K(ID1,4)=K(ID1,4)+MSTU(5)*I
69775 K(ID1,5)=K(ID1,5)+MSTU(5)*I
69776 ELSE
69777 K(ID1,4)=0
69778 K(ID1,5)=0
69779 ENDIF
69780 K(ID2,4)=0
69781 K(ID2,5)=0
69782 ENDIF
69783 610 CONTINUE
69784
69785C...Transformation from CM frame.
69786 IF(NPA.EQ.1) THEN
69787 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
69788 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
69789 MSTU(33)=1
69790 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
69791 ELSEIF(NPA.EQ.2) THEN
69792 BEX=PS(1)/PS(4)
69793 BEY=PS(2)/PS(4)
69794 BEZ=PS(3)/PS(4)
69795 GA=PS(4)/PS(5)
69796 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
69797 & /(1D0+GA)-P(IPA(1),4))
69798 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
69799 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
69800 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
69801 MSTU(33)=1
69802 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
69803 ELSE
69804 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
69805 & PS(3)/PS(4))
69806 MSTU(33)=1
69807 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
69808 ENDIF
69809
69810C...Decay vertex of shower.
69811 DO 630 I=NS+1,N
69812 DO 620 J=1,5
69813 V(I,J)=V(IP1,J)
69814 620 CONTINUE
69815 630 CONTINUE
69816
69817C...Delete trivial shower, else connect initiators.
69818 IF(N.LE.NS+NPA+IIM) THEN
69819 N=NS
69820 ELSE
69821 DO 640 IP=1,NPA
69822 K(IPA(IP),1)=14
69823 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
69824 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
69825 K(NS+IIM+IP,3)=IPA(IP)
69826 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
69827 IF(K(NS+IIM+IP,1).NE.1) THEN
69828 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
69829 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
69830 ENDIF
69831 640 CONTINUE
69832 ENDIF
69833
69834 RETURN
69835 END
69836
69837C*********************************************************************
69838
69839C...PYPTFS
69840C...Generates pT-ordered timelike final-state parton showers.
69841
69842C...MODE defines how to find radiators and recoilers.
69843C... = 0 : based on colour flow between undecayed partons.
69844C... = 1 : for IPART <= NPARTD only consider primary partons,
69845C... whether decayed or not; else as above.
69846C... = 2 : based on common history, whether decayed or not.
69847C... = 3 : use (or create) MCT color information to shower partons
69848
69849 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
69850
69851C...Double precision and integer declarations.
69852 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69853 IMPLICIT INTEGER(I-N)
69854 INTEGER PYK,PYCHGE,PYCOMP
69855C...Parameter statement to help give large particle numbers.
69856 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69857 &KEXCIT=4000000,KDIMEN=5000000)
69858C...Parameter statement for maximum size of showers.
69859 PARAMETER (MAXNUR=1000)
69860C...Commonblocks.
69861 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69862 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69863 COMMON/PYCTAG/NCT,MCT(4000,2)
69864 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69865 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69866 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69867 COMMON/PYINT1/MINT(400),VINT(400)
69868 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
69869 &/PYINT1/
69870C...Local arrays.
69871 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
69872 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
69873 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
69874 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
69875C...Statement functions.
69876 SHAT(I,J)=(P(I,4)+P(J,4))**2-(P(I,1)+P(J,1))**2-
69877 &(P(I,2)+P(J,2))**2-(P(I,3)+P(J,3))**2
69878
69879C...Initial values. Check that valid system.
69880 PTGEN=0D0
69881 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
69882 &MSTJ(41).NE.12) RETURN
69883 IF(NPART.LE.0) THEN
69884 CALL PYERRM(2,'(PYPTFS:) showering system too small')
69885 RETURN
69886 ENDIF
69887 PT2CMX=PTMAX**2
69888 IORD=1
69889
69890C...Mass thresholds and Lambda for QCD evolution.
69891 PMB=PMAS(5,1)
69892 PMC=PMAS(4,1)
69893 ALAM5=PARJ(81)
69894 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
69895 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
69896 PMBS=PMB**2
69897 PMCS=PMC**2
69898 ALAM5S=ALAM5**2
69899 ALAM4S=ALAM4**2
69900 ALAM3S=ALAM3**2
69901
69902C...Cutoff scale for QCD evolution. Starting pT2.
69903 NFLAV=MAX(0,MIN(5,MSTJ(45)))
69904 PT0C=0.5D0*PARJ(82)
69905 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
69906
69907C...Parameters for QED evolution.
69908 AEM2PI=PARU(101)/PARU(2)
69909 PT0EQ=0.5D0*PARJ(83)
69910 PT0EL=0.5D0*PARJ(90)
69911
69912C...Reset. Remove irrelevant colour tags.
69913 NEVOL=0
69914 DO 100 J=1,4
69915 PSUM(J)=0D0
69916 100 CONTINUE
69917 DO 110 I=MINT(84)+1,N
69918 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
69919 K(I,5)=0
69920 MCT(I,2)=0
69921 ENDIF
69922 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
69923 K(I,4)=0
69924 MCT(I,1)=0
69925 ENDIF
69926 110 CONTINUE
69927 NPARTS=NPART
69928
69929C...Begin loop to set up showering partons. Sum four-momenta.
69930 DO 230 IP=1,NPART
69931 I=IPART(IP)
69932 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
69933 IF(K(I,1).GT.10) GOTO 230
69934 ELSEIF(K(I,3).GT.MINT(84)) THEN
69935 IF(K(I,3).GT.MINT(84)+2) GOTO 230
69936 ELSE
69937 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
69938 ENDIF
69939 DO 120 J=1,4
69940 PSUM(J)=PSUM(J)+P(I,J)
69941 120 CONTINUE
69942
69943C...Find colour and charge, but skip diquarks.
69944 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
69945 KCOL=ISIGN(KCHG(PYCOMP(K(I,2)),2),K(I,2))
69946 KCHA=ISIGN(KCHG(PYCOMP(K(I,2)),1),K(I,2))
69947
69948C...QUARKONIA++
69949 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
69950 IF (MSTP(148).GE.1) THEN
69951C...Temporary: force no radiation from quarkonia since not yet treated
69952 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
69953 & //' PYPTFS, switched off')
69954 CALL PYGIVE('MSTP(148)=0')
69955 ENDIF
69956 IF (MSTP(148).EQ.0) THEN
69957C...Skip quarkonia if radiation switched off
69958 GOTO 230
69959 ENDIF
69960 ENDIF
69961C...QUARKONIA--
69962
69963C...Option to switch off radiation from particle KF = MSTJ(39) entirely
69964C...(only intended for studying the effects of switching such rad on/off)
69965 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
69966 GOTO 230
69967 ENDIF
69968
69969C...Either colour or anticolour charge radiates; for gluon both.
69970 DO 180 JSGCOL=1,-1,-2
69971 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
69972 JCOL=4+(1-JSGCOL)/2
69973 JCOLR=9-JCOL
69974
69975C...Basic info about radiating parton.
69976 NEVOL=NEVOL+1
69977 IPOS(NEVOL)=I
69978 IFLG(NEVOL)=0
69979 ISCOL(NEVOL)=JSGCOL
69980 ISCHG(NEVOL)=0
69981 PTSCA(NEVOL)=PTPART(IP)
69982
69983C...Begin search for colour recoiler when MODE = 0 or 1.
69984 IF(MODE.LE.1) THEN
69985C...Find sister with matching anticolour to the radiating parton.
69986 IROLD=I
69987 IRNEW=K(IROLD,JCOL)/MSTU(5)
69988 MOVE=1
69989
69990C...Skip radiation off loose colour ends.
69991 130 IF(IRNEW.EQ.0) THEN
69992 NEVOL=NEVOL-1
69993 GOTO 180
69994
69995C...Optionally skip radiation on dipole to beam remnant.
69996 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
69997 NEVOL=NEVOL-1
69998 GOTO 180
69999
70000C...For now always skip radiation on dipole to junction.
70001 ELSEIF(K(IRNEW,2).EQ.88) THEN
70002 NEVOL=NEVOL-1
70003 GOTO 180
70004
70005C...For MODE=1: if reached primary then done.
70006 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
70007 & IRNEW.LE.NPARTD) THEN
70008
70009C...If sister stable and points back then done.
70010 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
70011 & THEN
70012 IF(K(IRNEW,1).LT.10) THEN
70013
70014C...If sister unstable then go to her daughter.
70015 ELSE
70016 IROLD=IRNEW
70017 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
70018 MOVE=2
70019 GOTO 130
70020 ENDIF
70021
70022C...If found mother then look for aunt.
70023 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
70024 & IROLD) THEN
70025 IROLD=IRNEW
70026 IRNEW=K(IROLD,JCOL)/MSTU(5)
70027 GOTO 130
70028
70029C...If daughter stable then done.
70030 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
70031 & THEN
70032 IF(K(IRNEW,1).LT.10) THEN
70033
70034C...If daughter unstable then go to granddaughter.
70035 ELSE
70036 IROLD=IRNEW
70037 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
70038 MOVE=2
70039 GOTO 130
70040 ENDIF
70041
70042C...If daughter points to another daughter then done or move up.
70043 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
70044 & IROLD) THEN
70045 IF(K(IRNEW,1).LT.10) THEN
70046 ELSE
70047 IROLD=IRNEW
70048 IRNEW=K(IRNEW,JCOL)/MSTU(5)
70049 MOVE=1
70050 GOTO 130
70051 ENDIF
70052 ENDIF
70053
70054C...Begin search for colour recoiler when MODE = 2.
70055 ELSEIF (MODE.EQ.2) THEN
70056 IROLD=I
70057 IRNEW=K(IROLD,JCOL)/MSTU(5)
70058 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
70059C...If no color partner found, pick at random among other primaries
70060C...(e.g., when the color line is traced all the way to the beam)
70061 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70062 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70063 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
70064C...Step up to mother if radiating parton already branched.
70065 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
70066 IROLD=IRNEW
70067 IRNEW=K(IROLD,JCOL)/MSTU(5)
70068 GOTO 140
70069C...Pick sister by history if no anticolour available.
70070 ELSE
70071 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70072 IRNEW=IROLD-1
70073 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
70074 & THEN
70075 IRNEW=IROLD+1
70076C...Last resort: pick at random among other primaries.
70077 ELSE
70078 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70079 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70080 ENDIF
70081 ENDIF
70082 ENDIF
70083C...Trace down if sister branched.
70084 150 IF(K(IRNEW,1).GT.10) THEN
70085 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70086C...If no correct color-daughter found, swap.
70087 IF (IRTMP.EQ.0) THEN
70088 JCOL=9-JCOL
70089 JCOLR=9-JCOLR
70090 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
70091 ENDIF
70092 IRNEW=IRTMP
70093 GOTO 150
70094 ENDIF
70095 ELSEIF (MODE.EQ.3) THEN
70096C...The following will add MCT colour tracing for unprepped events
70097C...If not done, trace Les Houches colour tags for this dipole
70098 JCOLSV=JCOL
70099 IF (MCT(I,JCOL-3).EQ.0) THEN
70100C...Special end code -1 : trace to color partner or 0, return in IEND
70101 IEND=-1
70102 CALL PYCTTR(I,JCOL,IEND)
70103C...Clean up mother/daughter 'read' tags set by PYCTTR
70104 JCOL=JCOLSV
70105 DO 160 IR=1,N
70106 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
70107 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
70108 MCT(IR,1)=0
70109 MCT(IR,2)=0
70110 160 CONTINUE
70111 ELSE
70112 IEND=0
70113 DO 170 IR=1,N
70114 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
70115 & IEND=IR
70116 170 CONTINUE
70117 ENDIF
70118C...If no color partner, then we hit beam
70119 IF (IEND.LE.0) THEN
70120C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
70121 IF (MSTP(72).LE.1) THEN
70122 NEVOL=NEVOL-1
70123 GOTO 180
70124 ELSE
70125C...Else try a random partner
70126 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70127 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70128 ENDIF
70129 ELSE
70130C...Else save recoiling colour partner
70131 IRNEW=IEND
70132 ENDIF
70133
70134 ENDIF
70135
70136C...Now found other end of colour dipole.
70137 IREC(NEVOL)=IRNEW
70138 ENDIF
70139 180 CONTINUE
70140
70141C...Also electrical charge may radiate; so far only quarks and leptons.
70142 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
70143 & IABS(K(I,2)).LE.18) THEN
70144
70145C...Basic info about radiating parton.
70146 NEVOL=NEVOL+1
70147 IPOS(NEVOL)=I
70148 IFLG(NEVOL)=0
70149 ISCOL(NEVOL)=0
70150 ISCHG(NEVOL)=KCHA
70151 PTSCA(NEVOL)=PTPART(IP)
70152
70153C...Pick nearest (= smallest invariant mass) charged particle
70154C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
70155 IF(MODE.LE.1) THEN
70156 IRNEW=0
70157 PM2MIN=VINT(2)
70158 DO 190 IP2=1,NPART+N-MINT(53)
70159 IF(IP2.EQ.IP) GOTO 190
70160 IF(IP2.LE.NPART) THEN
70161 I2=IPART(IP2)
70162 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
70163 IF(K(I2,1).GT.10) GOTO 190
70164 ELSEIF(K(I2,3).GT.MINT(84)) THEN
70165 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
70166 ELSE
70167 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
70168 ENDIF
70169 ELSE
70170 I2=MINT(53)+IP2-NPART
70171 ENDIF
70172 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
70173 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
70174 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
70175 IF(PM2INV.LT.PM2MIN) THEN
70176 IRNEW=I2
70177 PM2MIN=PM2INV
70178 ENDIF
70179 190 CONTINUE
70180 IF(IRNEW.EQ.0) THEN
70181 NEVOL=NEVOL-1
70182 GOTO 230
70183 ENDIF
70184
70185C...Begin search for charge recoiler when MODE = 2.
70186 ELSE
70187 IROLD=I
70188C...Pick sister by history; step up if parton already branched.
70189 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
70190 IROLD=K(IROLD,3)
70191 GOTO 200
70192 ENDIF
70193 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
70194 IRNEW=IROLD-1
70195 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
70196 IRNEW=IROLD+1
70197C...Last resort: pick at random among other primaries.
70198 ELSE
70199 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
70200 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
70201 ENDIF
70202C...Trace down if sister branched.
70203 210 IF(K(IRNEW,1).GT.10) THEN
70204 DO 220 IR=IRNEW+1,N
70205 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
70206 IRNEW=IR
70207 GOTO 210
70208 ENDIF
70209 220 CONTINUE
70210 ENDIF
70211 ENDIF
70212 IREC(NEVOL)=IRNEW
70213 ENDIF
70214
70215C...End loop to set up showering partons. System invariant mass.
70216 230 CONTINUE
70217 IF(NEVOL.LE.0) RETURN
70218 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
70219 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
70220
70221C...Check if 3-jet matrix elements to be used.
70222 M3JC=0
70223 ALPHA=0.5D0
70224 NMESYS=0
70225 IF(MSTJ(47).GE.1) THEN
70226
70227C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70228 KFSRCE=0
70229 IPART1=K(IPART(1),3)
70230 IPART2=K(IPART(2),3)
70231 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
70232 KFSRCE=IABS(K(IPART1,2))
70233 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
70234 IPART1=K(IPART1,3)
70235 GOTO 240
70236 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
70237 IPART2=K(IPART2,3)
70238 GOTO 240
70239 ENDIF
70240 ITYPES=0
70241 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70242 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70243 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70244 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70245 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70246 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70247 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70248 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70249
70250C...Identify two primary showerers.
70251 KFLA1=IABS(K(IPART(1),2))
70252 ITYPE1=0
70253 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
70254 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
70255 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
70256 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
70257 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
70258 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
70259 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
70260 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
70261 KFLA2=IABS(K(IPART(2),2))
70262 ITYPE2=0
70263 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
70264 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
70265 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
70266 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
70267 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
70268 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
70269 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
70270 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
70271
70272C...Order of showerers. Presence of gluino.
70273 ITYPMN=MIN(ITYPE1,ITYPE2)
70274 ITYPMX=MAX(ITYPE1,ITYPE2)
70275 IORD=1
70276 IF(ITYPE1.GT.ITYPE2) IORD=2
70277 IGLUI=0
70278 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70279
70280C...Require exactly two primary showerers for ME corrections.
70281 NPRIM=0
70282 IF(IPART1.GT.0) THEN
70283 DO 250 I=1,N
70284 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
70285 250 CONTINUE
70286 ENDIF
70287 IF(NPRIM.NE.2) THEN
70288
70289C...Predetermined and default matrix element kinds.
70290 ELSEIF(MSTJ(38).NE.0) THEN
70291 M3JC=MSTJ(38)
70292 ALPHA=PARJ(80)
70293 MSTJ(38)=0
70294 ELSEIF(MSTJ(47).GE.6) THEN
70295 M3JC=MSTJ(47)
70296 ELSE
70297 ICLASS=1
70298 ICOMBI=4
70299
70300C...Vector/axial vector -> q + qbar; q -> q + V.
70301 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70302 & ITYPES.EQ.3)) THEN
70303 ICLASS=2
70304 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70305 ICOMBI=1
70306 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70307 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
70308C...gamma*/Z0: assume e+e- initial state if unknown.
70309 EI=-1D0
70310 IF(KFSRCE.EQ.23) THEN
70311 IANNFL=IPART1
70312 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70313 IF(IANNFL.GT.0) THEN
70314 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
70315 ENDIF
70316 IF(IANNFL.NE.0) THEN
70317 KANNFL=IABS(K(IANNFL,2))
70318 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70319 ENDIF
70320 ENDIF
70321 AI=SIGN(1D0,EI+0.1D0)
70322 VI=AI-4D0*EI*PARU(102)
70323 EF=KCHG(KFLA1,1)/3D0
70324 AF=SIGN(1D0,EF+0.1D0)
70325 VF=AF-4D0*EF*PARU(102)
70326 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70327 SH=PSUM(5)**2
70328 SQMZ=PMAS(23,1)**2
70329 SQWZ=PSUM(5)*PMAS(23,2)
70330 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70331 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70332 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70333 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70334 ICOMBI=3
70335 ALPHA=VECT/(VECT+AXIV)
70336 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70337 ICOMBI=4
70338 ENDIF
70339C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70340 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70341 ICLASS=2
70342 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70343 & ITYPES.EQ.1)) THEN
70344 ICLASS=3
70345
70346C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70347 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70348 ICLASS=4
70349 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70350 ICOMBI=1
70351 ELSEIF(KFSRCE.EQ.36) THEN
70352 ICOMBI=2
70353 ENDIF
70354 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70355 & ITYPES.EQ.1)) THEN
70356 ICLASS=5
70357
70358C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70359 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70360 & ITYPES.EQ.3)) THEN
70361 ICLASS=6
70362 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70363 & ITYPES.EQ.2)) THEN
70364 ICLASS=7
70365 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70366 ICLASS=8
70367 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70368 & ITYPES.EQ.2)) THEN
70369 ICLASS=9
70370
70371C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70372 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70373 & ITYPES.EQ.5)) THEN
70374 ICLASS=10
70375 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70376 & ITYPES.EQ.2)) THEN
70377 ICLASS=11
70378 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70379 & ITYPES.EQ.1)) THEN
70380 ICLASS=12
70381
70382C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70383 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70384 ICLASS=13
70385 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70386 & ITYPES.EQ.2)) THEN
70387 ICLASS=14
70388 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70389 & ITYPES.EQ.1)) THEN
70390 ICLASS=15
70391
70392C...g -> ~g + ~g (eikonal approximation).
70393 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70394 ICLASS=16
70395 ENDIF
70396 M3JC=5*ICLASS+ICOMBI
70397 ENDIF
70398
70399C...Store pair that together define matrix element treatment.
70400 IF(M3JC.NE.0) THEN
70401 NMESYS=1
70402 MESYS(NMESYS,0)=M3JC
70403 MESYS(NMESYS,1)=IPART(1)
70404 MESYS(NMESYS,2)=IPART(2)
70405 ENDIF
70406
70407C...Store qqbar or l+l- pairs for QED radiation.
70408 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
70409 NMESYS=NMESYS+1
70410 MESYS(NMESYS,0)=101
70411 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
70412 MESYS(NMESYS,1)=IPART(1)
70413 MESYS(NMESYS,2)=IPART(2)
70414 ENDIF
70415
70416C...Store other qqbar/l+l- pairs from g/gamma branchings.
70417 DO 290 I1=1,N
70418 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
70419 I1M=K(I1,3)
70420 260 IF(I1M.GT.0.AND.K(I1M,2).EQ.K(I1,2)) THEN
70421 I1M=K(I1M,3)
70422 GOTO 260
70423 ENDIF
70424C...Move up this check to avoid out-of-bounds.
70425 IF(I1M.EQ.0) GOTO 290
70426 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
70427 DO 280 I2=I1+1,N
70428 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
70429 I2M=K(I2,3)
70430 270 IF(I2M.GT.0.AND.K(I2M,2).EQ.K(I2,2)) THEN
70431 I2M=K(I2M,3)
70432 GOTO 270
70433 ENDIF
70434 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
70435 NMESYS=NMESYS+1
70436 MESYS(NMESYS,0)=66
70437 MESYS(NMESYS,1)=I1
70438 MESYS(NMESYS,2)=I2
70439 NMESYS=NMESYS+1
70440 MESYS(NMESYS,0)=102
70441 MESYS(NMESYS,1)=I1
70442 MESYS(NMESYS,2)=I2
70443 ENDIF
70444 280 CONTINUE
70445 290 CONTINUE
70446 ENDIF
70447
70448C..Loopback point for counting number of emissions.
70449 NGEN=0
70450 300 NGEN=NGEN+1
70451
70452C...Begin loop to evolve all existing partons, if required.
70453 310 IMX=0
70454 PT2MX=0D0
70455 DO 380 IEVOL=1,NEVOL
70456 IF(IFLG(IEVOL).EQ.0) THEN
70457
70458C...Basic info on radiator and recoil.
70459 I=IPOS(IEVOL)
70460 IR=IREC(IEVOL)
70461 SHT=SHAT(I,IR)
70462 PM2I=P(I,5)**2
70463 PM2R=P(IR,5)**2
70464
70465C...Invariant mass of "dipole".Starting value for pT evolution.
70466 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
70467 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
70468
70469C...Case of evolution by QCD branching.
70470 IF(ISCOL(IEVOL).NE.0) THEN
70471
70472C...Parton-by-parton maximum scale from initial conditions.
70473 IF(MSTP(72).EQ.0) THEN
70474 DO 320 IPRT=1,NPARTS
70475 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
70476 320 CONTINUE
70477 ENDIF
70478
70479C...If kinematically impossible then do not evolve.
70480 IF(PT2.LT.PT2CMN) THEN
70481 IFLG(IEVOL)=-1
70482 GOTO 380
70483 ENDIF
70484
70485C...Check if part of system for which ME corrections should be applied.
70486 IMESYS=0
70487 DO 330 IME=1,NMESYS
70488 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70489 & MESYS(IME,0).LT.100) IMESYS=IME
70490 330 CONTINUE
70491
70492C...Special flag for colour octet states.
70493C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
70494 MOCT=0
70495 IF(K(I,2).EQ.21) MOCT=1
70496C...SUSY gluino
70497 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70498C...UED KK gluon
70499 IF(K(I,2).EQ.5100021) MOCT=2
70500C...QUARKONIA++
70501 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
70502 & IABS(K(I,2)).LE.9910555) MOCT=2
70503C...QUARKONIA--
70504
70505
70506C...Upper estimate for matrix element weighting and colour factor.
70507C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
70508 WTPSGL=2D0
70509 COLFAC=4D0/3D0
70510 IF(MOCT.GE.1) COLFAC=3D0/2D0
70511 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
70512 WTPSQQ=0.5D0*0.5D0*NFLAV
70513
70514C...Determine overestimated z range: switch at c and b masses.
70515 340 IZRG=1
70516 PT2MNE=PT2CMN
70517 B0=27D0/6D0
70518 ALAMS=ALAM3S
70519 IF(PT2.GT.1.01D0*PMCS) THEN
70520 IZRG=2
70521 PT2MNE=PMCS
70522 B0=25D0/6D0
70523 ALAMS=ALAM4S
70524 ENDIF
70525 IF(PT2.GT.1.01D0*PMBS) THEN
70526 IZRG=3
70527 PT2MNE=PMBS
70528 B0=23D0/6D0
70529 ALAMS=ALAM5S
70530 ENDIF
70531 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
70532 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
70533
70534C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
70535 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
70536 EVCOEF=EVEMGL
70537 IF(MOCT.EQ.1) THEN
70538 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
70539 EVCOEF=EVCOEF+EVEMQQ
70540 ENDIF
70541
70542C...Pick pT2 (in overestimated z range).
70543 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
70544
70545C...Loopback if crossed c/b mass thresholds.
70546 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
70547 PT2=PMBS
70548 GOTO 340
70549 ENDIF
70550 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
70551 PT2=PMCS
70552 GOTO 340
70553 ENDIF
70554
70555C...Finish if below lower cutoff.
70556 IF(PT2.LT.PT2CMN) THEN
70557 IFLG(IEVOL)=-1
70558 GOTO 380
70559 ENDIF
70560
70561C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
70562C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
70563 IFLAG=1
70564 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
70565
70566C...Pick z: dz/(1-z) or dz.
70567 IF(IFLAG.EQ.1) THEN
70568 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70569 ELSE
70570 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
70571 ENDIF
70572
70573C...Loopback if outside allowed range for given pT2.
70574 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70575 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70576 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
70577 PM2=PM2I+PT2/(Z*(1D0-Z))
70578 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
70579
70580C...No weighting for primary partons; to be done later on.
70581 IF(IMESYS.GT.0) THEN
70582
70583C...Weighting of q->qg/X->Xg branching.
70584 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
70585 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
70586
70587C...Weighting of g->gg branching.
70588 ELSEIF(IFLAG.EQ.1) THEN
70589 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
70590
70591C...Flavour choice and weighting of g->qqbar branching.
70592 ELSE
70593 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
70594 PMQ=PMAS(KFQ,1)
70595 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70596 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
70597 IF(WTME.LT.PYR(0)) GOTO 350
70598 IFLAG=10+KFQ
70599 ENDIF
70600
70601C...Case of evolution by QED branching.
70602 ELSEIF(ISCHG(IEVOL).NE.0) THEN
70603
70604C...If kinematically impossible then do not evolve.
70605 PT2EMN=PT0EQ**2
70606 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
70607 IF(PT2.LT.PT2EMN) THEN
70608 IFLG(IEVOL)=-1
70609 GOTO 380
70610 ENDIF
70611
70612C...Check if part of system for which ME corrections should be applied.
70613 IMESYS=0
70614 DO 360 IME=1,NMESYS
70615 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
70616 & MESYS(IME,0).GT.100) IMESYS=IME
70617 360 CONTINUE
70618
70619C...Charge. Matrix element weighting factor.
70620 CHG=ISCHG(IEVOL)/3D0
70621 WTPSGA=2D0
70622
70623C...Determine overestimated z range. Find evolution coefficient.
70624 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
70625 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
70626 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
70627
70628C...Pick pT2 (in overestimated z range).
70629 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
70630
70631C...Finish if below lower cutoff.
70632 IF(PT2.LT.PT2EMN) THEN
70633 IFLG(IEVOL)=-1
70634 GOTO 380
70635 ENDIF
70636
70637C...Pick z: dz/(1-z).
70638 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
70639
70640C...Loopback if outside allowed range for given pT2.
70641 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
70642 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
70643 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
70644 PM2=PM2I+PT2/(Z*(1D0-Z))
70645 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
70646
70647C...Weighting by branching kernel, except if ME weighting later.
70648 IF(IMESYS.EQ.0) THEN
70649 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
70650 ENDIF
70651 IFLAG=3
70652 ENDIF
70653
70654C...Save acceptable branching.
70655 IFLG(IEVOL)=IFLAG
70656 IMESAV(IEVOL)=IMESYS
70657 PT2SAV(IEVOL)=PT2
70658 ZSAV(IEVOL)=Z
70659 SHTSAV(IEVOL)=SHT
70660 ENDIF
70661
70662C...Check if branching has highest pT.
70663 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
70664 IMX=IEVOL
70665 PT2MX=PT2SAV(IEVOL)
70666 ENDIF
70667 380 CONTINUE
70668
70669C...Finished if no more branchings to be done.
70670 IF(IMX.EQ.0) GOTO 500
70671
70672C...Restore info on hardest branching to be processed.
70673 I=IPOS(IMX)
70674 IR=IREC(IMX)
70675 KCOL=ISCOL(IMX)
70676 KCHA=ISCHG(IMX)
70677 IMESYS=IMESAV(IMX)
70678 PT2=PT2SAV(IMX)
70679 Z=ZSAV(IMX)
70680 SHT=SHTSAV(IMX)
70681 PM2I=P(I,5)**2
70682 PM2R=P(IR,5)**2
70683 PM2=PM2I+PT2/(Z*(1D0-Z))
70684
70685C...Special flag for colour octet states.
70686 MOCT=0
70687 IF(K(I,2).EQ.21) MOCT=1
70688 IF(K(I,2).EQ.KSUSY1+21) MOCT=2
70689 IF(K(I,2).EQ.5100021) MOCT=2
70690C...QUARKONIA++
70691 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
70692 & IABS(K(I,2)).LE.9910555) MOCT=2
70693C...QUARKONIA--
70694
70695C...Restore further info for g->qqbar branching.
70696 KFQ=0
70697 IF(IFLG(IMX).GT.10) THEN
70698 KFQ=IFLG(IMX)-10
70699 PMQ=PMAS(KFQ,1)
70700 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
70701 ENDIF
70702
70703C...For branching g include azimuthal asymmetries from polarization.
70704 ASYPOL=0D0
70705 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
70706C...Trace grandmother via intermediate recoil copies.
70707 KFGM=0
70708 IM=I
70709 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
70710 & K(IM,3).GT.0) THEN
70711 IM=K(IM,3)
70712 IF(IM.GT.MINT(84)) GOTO 390
70713 ENDIF
70714 IGM=K(IM,3)
70715 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
70716 & KFGM=IABS(K(IGM,2))
70717C...Define approximate energy sharing by identifying aunt.
70718 IAU=IM+1
70719 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
70720 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
70721 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
70722C...Coefficient from gluon production.
70723 IF(KFGM.LE.6) THEN
70724 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
70725 ELSE
70726 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
70727 ENDIF
70728C...Coefficient from gluon decay.
70729 IF(KFQ.EQ.0) THEN
70730 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
70731 ELSE
70732 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
70733 ENDIF
70734 ENDIF
70735 ENDIF
70736
70737C...Create new slots for branching products and recoil.
70738 INEW=N+1
70739 IGNEW=N+2
70740 IRNEW=N+3
70741 N=N+3
70742
70743C...Set status, flavour and mother of new ones.
70744 K(INEW,1)=K(I,1)
70745 K(IGNEW,1)=3
70746 IF(KCHA.NE.0) K(IGNEW,1)=1
70747 K(IRNEW,1)=K(IR,1)
70748 IF(KFQ.EQ.0) THEN
70749 K(INEW,2)=K(I,2)
70750 K(IGNEW,2)=21
70751 IF(KCHA.NE.0) K(IGNEW,2)=22
70752 ELSE
70753 K(INEW,2)=-ISIGN(KFQ,KCOL)
70754 K(IGNEW,2)=-K(INEW,2)
70755 ENDIF
70756 K(IRNEW,2)=K(IR,2)
70757 K(INEW,3)=I
70758 K(IGNEW,3)=I
70759 K(IRNEW,3)=IR
70760
70761C...Find rest frame and angles of branching+recoil.
70762 DO 400 J=1,5
70763 P(INEW,J)=P(I,J)
70764 P(IGNEW,J)=0D0
70765 P(IRNEW,J)=P(IR,J)
70766 400 CONTINUE
70767 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
70768 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
70769 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
70770 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
70771 PHI=PYANGL(P(INEW,1),P(INEW,2))
70772 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
70773
70774C...Derive kinematics of branching: generics (like g->gg).
70775 DO 410 J=1,4
70776 P(INEW,J)=0D0
70777 P(IRNEW,J)=0D0
70778 410 CONTINUE
70779 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
70780 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
70781 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
70782 PTCOR=SQRT(MAX(0D0,PT2COR))
70783 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
70784 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
70785C...Specific kinematics reduction for q->qg with m_q > 0.
70786 IF(MOCT.NE.1) THEN
70787 PTCOR=(1D0-PM2I/PM2)*PTCOR
70788 PZN=PZN+PM2I*PZG/PM2
70789 PZG=(1D0-PM2I/PM2)*PZG
70790C...Specific kinematics reduction for g->qqbar with m_q > 0.
70791 ELSEIF(KFQ.NE.0) THEN
70792 P(INEW,5)=PMQ
70793 P(IGNEW,5)=PMQ
70794 PTCOR=ROOTQQ*PTCOR
70795 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
70796 PZG=PZM-PZN
70797 ENDIF
70798
70799C...Pick phi and construct kinematics of branching.
70800 420 PHIROT=PARU(2)*PYR(0)
70801 P(INEW,1)=PTCOR*COS(PHIROT)
70802 P(INEW,2)=PTCOR*SIN(PHIROT)
70803 P(INEW,3)=PZN
70804 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
70805 P(IGNEW,1)=-P(INEW,1)
70806 P(IGNEW,2)=-P(INEW,2)
70807 P(IGNEW,3)=PZG
70808 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
70809 P(IRNEW,1)=0D0
70810 P(IRNEW,2)=0D0
70811 P(IRNEW,3)=-PZM
70812 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
70813
70814C...Boost branching system to lab frame.
70815 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
70816
70817C...Renew choice of phi angle according to polarization asymmetry.
70818 IF(ABS(ASYPOL).GT.1D-3) THEN
70819 DO 430 J=1,3
70820 DPT(1,J)=P(I,J)
70821 DPT(2,J)=P(IAU,J)
70822 DPT(3,J)=P(INEW,J)
70823 430 CONTINUE
70824 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
70825 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
70826 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
70827 DO 440 J=1,3
70828 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
70829 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
70830 440 CONTINUE
70831 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
70832 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
70833 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
70834 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
70835 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
70836 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
70837 & GOTO 420
70838 ENDIF
70839 ENDIF
70840
70841C...Matrix element corrections for primary partons when requested.
70842 IF(IMESYS.GT.0) THEN
70843 M3JC=MESYS(IMESYS,0)
70844
70845C...Identify recoiling partner and set up three-body kinematics.
70846 IRP=MESYS(IMESYS,1)
70847 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
70848 IF(IRP.EQ.IR) IRP=IRNEW
70849 DO 450 J=1,4
70850 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
70851 450 CONTINUE
70852 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
70853 & PSUM(3)**2))
70854 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
70855 & PSUM(3)*P(INEW,3))/PSUM(5)**2
70856 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
70857 & PSUM(3)*P(IRP,3))/PSUM(5)**2
70858 X3=2D0-X1-X2
70859 R1ME=P(INEW,5)/PSUM(5)
70860 R2ME=P(IRP,5)/PSUM(5)
70861
70862C...Matrix elements for gluon emission.
70863 IF(M3JC.LT.100) THEN
70864
70865C...Call ME, with right order important for two inequivalent showerers.
70866 IF(MESYS(IMESYS,IORD).EQ.I) THEN
70867 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
70868 ELSE
70869 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
70870 ENDIF
70871
70872C...Split up total ME when two radiating partons.
70873 ISPRAD=1
70874 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
70875 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
70876 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
70877 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70878 & MAX(1D-10,2D0-X1-X2)
70879
70880C...Evaluate shower rate.
70881 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70882 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70883 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
70884
70885C...Matrix elements for photon emission: still rather primitive.
70886 ELSE
70887
70888C...For generic charge combination currently only massless expression.
70889 IF(M3JC.EQ.101) THEN
70890 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
70891 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
70892 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70893 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
70894
70895C...For flavour neutral system assume vector source and include masses.
70896 ELSE
70897 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
70898 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
70899 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
70900 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70901 ENDIF
70902 ENDIF
70903
70904C...Perform weighting with W_ME/W_PS.
70905 IF(WME.LT.PYR(0)*WPS) THEN
70906 N=N-3
70907 IFLG(IMX)=0
70908 PT2CMX=PT2
70909 GOTO 310
70910 ENDIF
70911 ENDIF
70912
70913C...Now for sure accepted branching. Save highest pT.
70914 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
70915
70916C...Update status for obsolete ones. Bookkkep the moved original parton
70917C...and new daughter (arbitrary choice for g->gg or g->qqbar).
70918C...Do not bookkeep radiated photon, since it cannot radiate further.
70919 K(I,1)=K(I,1)+10
70920 K(IR,1)=K(IR,1)+10
70921 DO 460 IP=1,NPART
70922 IF(IPART(IP).EQ.I) IPART(IP)=INEW
70923 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
70924 460 CONTINUE
70925 IF(KCHA.EQ.0) THEN
70926 NPART=NPART+1
70927 IPART(NPART)=IGNEW
70928 ENDIF
70929
70930C...Initialize colour flow of branching.
70931C...Use both old and new style colour tags for flexibility.
70932 K(INEW,4)=0
70933 K(IGNEW,4)=0
70934 K(INEW,5)=0
70935 K(IGNEW,5)=0
70936 JCOLP=4+(1-KCOL)/2
70937 JCOLN=9-JCOLP
70938 MCT(INEW,1)=0
70939 MCT(INEW,2)=0
70940 MCT(IGNEW,1)=0
70941 MCT(IGNEW,2)=0
70942 MCT(IRNEW,1)=0
70943 MCT(IRNEW,2)=0
70944
70945C...Trivial colour flow for l->lgamma and q->qgamma.
70946 IF(IABS(KCHA).EQ.3) THEN
70947 K(I,4)=INEW
70948 K(I,5)=IGNEW
70949 ELSEIF(KCHA.NE.0) THEN
70950 IF(K(I,4).NE.0) THEN
70951 K(I,4)=K(I,4)+INEW
70952 K(INEW,4)=MSTU(5)*I
70953 MCT(INEW,1)=MCT(I,1)
70954 ENDIF
70955 IF(K(I,5).NE.0) THEN
70956 K(I,5)=K(I,5)+INEW
70957 K(INEW,5)=MSTU(5)*I
70958 MCT(INEW,2)=MCT(I,2)
70959 ENDIF
70960
70961C...Set colour flow for q->qg and g->gg.
70962 ELSEIF(KFQ.EQ.0) THEN
70963 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70964 K(IGNEW,JCOLP)=MSTU(5)*I
70965 K(INEW,JCOLP)=MSTU(5)*IGNEW
70966 K(IGNEW,JCOLN)=MSTU(5)*INEW
70967 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70968 NCT=NCT+1
70969 MCT(INEW,JCOLP-3)=NCT
70970 MCT(IGNEW,JCOLN-3)=NCT
70971 IF(MOCT.GE.1) THEN
70972 K(I,JCOLN)=K(I,JCOLN)+INEW
70973 K(INEW,JCOLN)=MSTU(5)*I
70974 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70975 ENDIF
70976
70977C...Set colour flow for g->qqbar.
70978 ELSE
70979 K(I,JCOLN)=K(I,JCOLN)+INEW
70980 K(INEW,JCOLN)=MSTU(5)*I
70981 K(I,JCOLP)=K(I,JCOLP)+IGNEW
70982 K(IGNEW,JCOLP)=MSTU(5)*I
70983 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
70984 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
70985 ENDIF
70986
70987C...Daughter info for colourless recoiling parton.
70988 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
70989 K(IR,4)=IRNEW
70990 K(IR,5)=IRNEW
70991 K(IRNEW,4)=0
70992 K(IRNEW,5)=0
70993
70994C...Colour of recoiling parton sails through unchanged.
70995 ELSE
70996 IF(K(IR,4).NE.0) THEN
70997 K(IR,4)=K(IR,4)+IRNEW
70998 K(IRNEW,4)=MSTU(5)*IR
70999 MCT(IRNEW,1)=MCT(IR,1)
71000 ENDIF
71001 IF(K(IR,5).NE.0) THEN
71002 K(IR,5)=K(IR,5)+IRNEW
71003 K(IRNEW,5)=MSTU(5)*IR
71004 MCT(IRNEW,2)=MCT(IR,2)
71005 ENDIF
71006 ENDIF
71007
71008C...Vertex information trivial.
71009 DO 470 J=1,5
71010 V(INEW,J)=V(I,J)
71011 V(IGNEW,J)=V(I,J)
71012 V(IRNEW,J)=V(IR,J)
71013 470 CONTINUE
71014
71015C...Update list of old radiators.
71016 DO 480 IEVOL=1,NEVOL
71017 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
71018 IPOS(IEVOL)=INEW
71019 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
71020 IREC(IEVOL)=IRNEW
71021 IFLG(IEVOL)=0
71022 ELSEIF(IPOS(IEVOL).EQ.I) THEN
71023 IPOS(IEVOL)=INEW
71024 IFLG(IEVOL)=0
71025 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
71026 IPOS(IEVOL)=IRNEW
71027 IREC(IEVOL)=INEW
71028 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL) IREC(IEVOL)=IGNEW
71029 IFLG(IEVOL)=0
71030 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
71031 IPOS(IEVOL)=IRNEW
71032 IFLG(IEVOL)=0
71033 ENDIF
71034C...Update links of old connected partons.
71035 IF(IREC(IEVOL).EQ.I) THEN
71036 IREC(IEVOL)=INEW
71037 IFLG(IEVOL)=0
71038 ELSEIF(IREC(IEVOL).EQ.IR) THEN
71039 IREC(IEVOL)=IRNEW
71040 IFLG(IEVOL)=0
71041 ENDIF
71042 480 CONTINUE
71043
71044C...q->qg or g->gg: create new gluon radiators.
71045 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
71046 NEVOL=NEVOL+1
71047 IPOS(NEVOL)=INEW
71048 IREC(NEVOL)=IGNEW
71049 IFLG(NEVOL)=0
71050 ISCOL(NEVOL)=KCOL
71051 ISCHG(NEVOL)=0
71052 PTSCA(NEVOL)=SQRT(PT2)
71053 NEVOL=NEVOL+1
71054 IPOS(NEVOL)=IGNEW
71055 IREC(NEVOL)=INEW
71056 IFLG(NEVOL)=0
71057 ISCOL(NEVOL)=-KCOL
71058 ISCHG(NEVOL)=0
71059 PTSCA(NEVOL)=PTSCA(NEVOL-1)
71060 ENDIF
71061
71062C...Update matrix elements parton list and add new for g/gamma->qqbar.
71063 DO 490 IME=1,NMESYS
71064 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
71065 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
71066 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
71067 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
71068 490 CONTINUE
71069 IF(KFQ.NE.0) THEN
71070 NMESYS=NMESYS+1
71071 MESYS(NMESYS,0)=66
71072 MESYS(NMESYS,1)=INEW
71073 MESYS(NMESYS,2)=IGNEW
71074 NMESYS=NMESYS+1
71075 MESYS(NMESYS,0)=102
71076 MESYS(NMESYS,1)=INEW
71077 MESYS(NMESYS,2)=IGNEW
71078 ENDIF
71079
71080C...Global statistics.
71081 MINT(353)=MINT(353)+1
71082 VINT(353)=VINT(353)+PTCOR
71083 IF (MINT(353).EQ.1) VINT(358)=PTCOR
71084
71085C...Loopback for more emissions if enough space.
71086 PT2CMX=PT2
71087 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
71088 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
71089 GOTO 300
71090 ELSE
71091 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
71092 ENDIF
71093
71094C...Done.
71095 500 CONTINUE
71096
71097 RETURN
71098 END
71099
71100C*********************************************************************
71101
71102C...PYMAEL
71103C...Auxiliary to PYSHOW and PYPTFS.
71104C...Matrix elements for gluon (or photon) emission from
71105C...a two-body state; to be used by the parton shower routine.
71106C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
71107C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
71108C... = (alpha-strong/2 pi) * CF * PYMAEL,
71109C...i.e. normalization is such that one recovers the familiar
71110C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
71111C...Coupling structure:
71112C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
71113C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
71114C... = 16-19 : q -> q V
71115C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
71116C... = 26-29 : q -> q S
71117C... = 31-34 : V -> ~q ~qbar (~q = squark)
71118C... = 36-39 : ~q -> ~q V
71119C... = 41-44 : S -> ~q ~qbar
71120C... = 46-49 : ~q -> ~q S
71121C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
71122C... = 56-59 : ~q -> q chi
71123C... = 61-64 : q -> ~q chi
71124C... = 66-69 : ~g -> q ~qbar
71125C... = 71-74 : ~q -> q ~g
71126C... = 76-79 : q -> ~q ~g
71127C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
71128C...Note that the order of the decay products is important.
71129C...In each set of four, the variants are ordered as:
71130C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
71131C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
71132C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
71133C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
71134
71135 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
71136
71137C...Double precision and integer declarations.
71138 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71139 IMPLICIT INTEGER(I-N)
71140
71141C...Check input values. Return zero outside allowed phase space.
71142 PYMAEL=0D0
71143 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
71144 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
71145 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
71146 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
71147 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
71148 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
71149
71150C...Initial values and flags.
71151 ICLASS=NI/5
71152 ICOMBI=NI-5*ICLASS
71153 ISSET1=0
71154 ISSET2=0
71155 ISSET4=0
71156
71157C... Phase space.
71158 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
71159
71160C...Eikonal expression; also acts as default.
71161 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
71162 RLO=PS
71163 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71164 ANUM=0D0
71165 ELSEIF(ICOMBI.EQ.2) THEN
71166 ANUM=(2D0-X1-X2)**2
71167 ELSEIF(ICOMBI.EQ.3) THEN
71168 ANUM=ALPCOR*(2D0-X1-X2)**2
71169 ELSE
71170 ANUM=0.5D0*(2D0-X1-X2)**2
71171 ENDIF
71172 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71173 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71174 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71175 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71176 ICOMBI=0
71177
71178C...V -> q qbar (V = gamma*/Z0/W+-/...).
71179 ELSEIF(ICLASS.EQ.2) THEN
71180 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71181 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71182 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
71183 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
71184 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
71185 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
71186 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71187 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
71188 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
71189 & (-1+R1**2-R2**2+X2)**2
71190 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71191 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71192 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
71193 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71194 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
71195 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71196 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71197 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
71198 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
71199 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
71200 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
71201 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
71202 RFO1=RFO1/2.D0
71203 ISSET1=1
71204 ENDIF
71205 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71206 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
71207 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
71208 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
71209 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
71210 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
71211 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
71212 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
71213 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
71214 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
71215 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
71216 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
71217 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
71218 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
71219 & -X1-X2)**2+X1*(2-X1-X2)**2)/
71220 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71221 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
71222 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
71223 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
71224 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
71225 & +X2)/(-1-R1**2+R2**2+X1)**2
71226 RFO2=RFO2/2.D0
71227 ISSET2=1
71228 ENDIF
71229 IF(ICOMBI.EQ.4) THEN
71230 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
71231 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
71232 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
71233 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
71234 & (-1-R1**2+R2**2+X1)**2
71235 RFO4=RFO4
71236 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
71237 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
71238 & -R1**2*X2**2+X1*X2**2)/
71239 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71240 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
71241 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
71242 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
71243 & (-1+R1**2-R2**2+X2)**2
71244 RFO4=RFO4/2.D0
71245 ISSET4=1
71246 ENDIF
71247
71248C...q -> q V.
71249 ELSEIF(ICLASS.EQ.3) THEN
71250 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71251 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
71252 & +R1**2*R2**2-2D0*R2**4)
71253 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
71254 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
71255 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
71256 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
71257 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
71258 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
71259 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71260 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
71261 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71262 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
71263 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71264 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71265 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
71266 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
71267 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71268 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
71269 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71270 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
71271 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
71272 ISSET1=1
71273 ENDIF
71274 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71275 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
71276 & +R1**2*R2**2-2D0*R2**4)
71277 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
71278 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
71279 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
71280 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
71281 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
71282 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
71283 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71284 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
71285 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
71286 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
71287 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71288 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71289 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71290 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
71291 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
71292 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
71293 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71294 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71295 & +X1*X2**2)/(-2+X1+X2)**2
71296 ISSET2=1
71297 ENDIF
71298 IF(ICOMBI.EQ.4) THEN
71299 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
71300 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
71301 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
71302 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
71303 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
71304 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71305 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
71306 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
71307 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
71308 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
71309 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
71310 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
71311 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
71312 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
71313 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
71314 & +X1*X2**2)/(2-X1-X2)**2
71315 ISSET4=1
71316 ENDIF
71317
71318C...S -> q qbar (S = h0/H0/A0/H+-/...).
71319 ELSEIF(ICLASS.EQ.4) THEN
71320 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71321 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
71322 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71323 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71324 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71325 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
71326 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
71327 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71328 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71329 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71330 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71331 ISSET1=1
71332 ENDIF
71333 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71334 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
71335 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71336 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71337 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71338 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71339 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71340 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71341 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
71342 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
71343 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71344 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71345 ISSET2=1
71346 ENDIF
71347 IF(ICOMBI.EQ.4) THEN
71348 RLO4=PS*(1D0-R1**2-R2**2)
71349 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71350 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71351 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71352 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71353 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71354 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
71355 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71356 ISSET4=1
71357 ENDIF
71358
71359C...q -> q S.
71360 ELSEIF(ICLASS.EQ.5) THEN
71361 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71362 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71363 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71364 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71365 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
71366 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71367 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71368 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71369 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71370 & (-1+R1**2-R2**2+X2)**2
71371 ISSET1=1
71372 ENDIF
71373 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71374 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71375 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
71376 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71377 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
71378 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71379 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
71380 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71381 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71382 & (-1+R1**2-R2**2+X2)**2
71383 ISSET2=1
71384 ENDIF
71385 IF(ICOMBI.EQ.4) THEN
71386 RLO4=PS*(1D0+R1**2-R2**2)
71387 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
71388 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
71389 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
71390 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
71391 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71392 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71393 ISSET4=1
71394 ENDIF
71395
71396C...V -> ~q ~qbar (~q = squark).
71397 ELSEIF(ICLASS.EQ.6) THEN
71398 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71399 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
71400 & (-1-R1**2+R2**2+X1)**2
71401 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
71402 & (-1-R1**2+R2**2+X1)
71403 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
71404 & /(-1+R1**2-R2**2+X2)**2
71405 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
71406 & (-1+R1**2-R2**2+X2)
71407 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
71408 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
71409 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
71410 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71411 ISSET1=1
71412
71413C...~q -> ~q V.
71414 ELSEIF(ICLASS.EQ.7) THEN
71415 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
71416 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
71417 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
71418 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
71419 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71420 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
71421 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
71422 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
71423 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
71424 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
71425 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
71426 & (3*(-2+X1+X2))
71427 RFO1=3D0*RFO1/8D0
71428 ISSET1=1
71429
71430C...S -> ~q ~qbar.
71431 ELSEIF(ICLASS.EQ.8) THEN
71432 RLO1=PS
71433 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
71434 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
71435 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
71436 & -R1**2*X2**2+X1*X2**2)/
71437 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
71438 RFO1=2D0*RFO1
71439 ISSET1=1
71440
71441C...~q -> ~q S.
71442 ELSEIF(ICLASS.EQ.9) THEN
71443 RLO1=PS
71444 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71445 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71446 & -(X1+X2)/(-2+X1+X2)**2
71447 ISSET1=1
71448
71449C...chi -> q ~qbar (chi = neutralino/chargino).
71450 ELSEIF(ICLASS.EQ.10) THEN
71451 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71452 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71453 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71454 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
71455 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71456 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71457 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
71458 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71459 & (-1+R1**2-R2**2+X2)**2
71460 ISSET1=1
71461 ENDIF
71462 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71463 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
71464 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
71465 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
71466 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
71467 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71468 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
71469 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71470 & (-1+R1**2-R2**2+X2)**2
71471 ISSET2=1
71472 ENDIF
71473 IF(ICOMBI.EQ.4) THEN
71474 RLO4=PS*(1+R1**2-R2**2)
71475 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
71476 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
71477 & +X2+R1**2*X2-X1*X2/2)/
71478 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
71479 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
71480 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
71481 ISSET4=1
71482 ENDIF
71483
71484C...~q -> q chi.
71485 ELSEIF(ICLASS.EQ.11) THEN
71486 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71487 RLO1=PS*(1D0-(R1+R2)**2)
71488 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71489 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71490 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71491 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71492 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71493 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71494 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71495 ISSET1=1
71496 ENDIF
71497 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71498 RLO2=PS*(1D0-(R1-R2)**2)
71499 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
71500 & (-2+X1+X2)**2
71501 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71502 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
71503 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
71504 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
71505 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71506 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
71507 ISSET2=1
71508 ENDIF
71509 IF(ICOMBI.EQ.4) THEN
71510 RLO4=PS*(1D0-R1**2-R2**2)
71511 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
71512 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
71513 & +3*R1**2*X2-R2**2*X2-X1*X2)/
71514 & (-1+R1**2-R2**2+X2)**2
71515 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71516 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71517 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71518 ISSET4=1
71519 ENDIF
71520
71521C...q -> ~q chi.
71522 ELSEIF(ICLASS.EQ.12) THEN
71523 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71524 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71525 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71526 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
71527 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
71528 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
71529 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71530 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71531 ISSET1=1
71532 END IF
71533 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71534 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71535 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
71536 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
71537 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71538 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71539 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71540 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71541 ISSET2=1
71542 END IF
71543 IF(ICOMBI.EQ.4) THEN
71544 RLO4=PS*(1D0-R1**2+R2**2)
71545 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
71546 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
71547 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
71548 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
71549 & +R1**2*X2-X1*X2/2-X2**2/2)/
71550 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
71551 ISSET4=1
71552 END IF
71553
71554C...~g -> q ~qbar.
71555 ELSEIF(ICLASS.EQ.13) THEN
71556 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71557 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
71558 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
71559 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
71560 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
71561 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
71562 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
71563 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
71564 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
71565 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
71566 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
71567 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
71568 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
71569 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71570 & (3*(-1+R1**2-R2**2+X2)**2)
71571 RFO1=3D0*RFO1/4D0
71572 ISSET1=1
71573 ENDIF
71574 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71575 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
71576 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
71577 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
71578 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71579 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
71580 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
71581 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
71582 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
71583 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
71584 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
71585 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71586 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
71587 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
71588 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71589 & (3*(-1+R1**2-R2**2+X2)**2)
71590 RFO2=3D0*RFO2/4D0
71591 ISSET2=1
71592 ENDIF
71593 IF(ICOMBI.EQ.4) THEN
71594 RLO4=PS*(1D0+R1**2-R2**2)
71595 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
71596 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
71597 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
71598 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
71599 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
71600 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71601 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
71602 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71603 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
71604 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
71605 & (3*(-1+R1**2-R2**2+X2)**2)
71606 RFO4=3D0*RFO4/8D0
71607 ISSET4=1
71608 ENDIF
71609
71610C...~q -> q ~g.
71611 ELSEIF(ICLASS.EQ.14) THEN
71612 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71613 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
71614 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71615 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71616 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71617 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
71618 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
71619 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
71620 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71621 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
71622 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
71623 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71624 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
71625 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
71626 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71627 RFO1=RFO1
71628 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
71629 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
71630 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71631 RFO1=9D0*RFO1/64D0
71632 ISSET1=1
71633 ENDIF
71634 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71635 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
71636 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
71637 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
71638 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
71639 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
71640 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
71641 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
71642 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
71643 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
71644 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
71645 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
71646 RFO2=RFO2
71647 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
71648 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
71649 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
71650 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
71651 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
71652 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71653 RFO2=9D0*RFO2/64D0
71654 ISSET2=1
71655 ENDIF
71656 IF(ICOMBI.EQ.4) THEN
71657 RLO4=PS*(1-R1**2-R2**2)
71658 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
71659 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
71660 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
71661 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
71662 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
71663 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
71664 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
71665 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
71666 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
71667 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
71668 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
71669 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
71670 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
71671 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
71672 RFO4=9D0*RFO4/128D0
71673 ISSET4=1
71674 ENDIF
71675
71676C...q -> ~q ~g.
71677 ELSEIF(ICLASS.EQ.15) THEN
71678 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
71679 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
71680 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71681 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
71682 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
71683 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
71684 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
71685 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71686 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
71687 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
71688 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71689 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
71690 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
71691 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
71692 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71693 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71694 RFO1=9D0*RFO1/32D0
71695 ISSET1=1
71696 END IF
71697 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
71698 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
71699 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
71700 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
71701 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
71702 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
71703 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
71704 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
71705 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
71706 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
71707 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71708 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
71709 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
71710 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
71711 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
71712 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71713 RFO2=9D0*RFO2/32D0
71714 ISSET2=1
71715 END IF
71716 IF(ICOMBI.EQ.4) THEN
71717 RLO4=PS*(1D0-R1**2+R2**2)
71718 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
71719 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
71720 & -R2**2*X2/2-X1*X2/2)/
71721 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
71722 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
71723 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
71724 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
71725 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
71726 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
71727 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
71728 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
71729 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
71730 RFO4=9D0*RFO4/64D0
71731 ISSET4=1
71732 END IF
71733
71734C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
71735 ELSEIF(ICLASS.EQ.16) THEN
71736 RLO=PS
71737 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
71738 ANUM=0D0
71739 ELSEIF(ICOMBI.EQ.2) THEN
71740 ANUM=(2D0-X1-X2)**2
71741 ELSEIF(ICOMBI.EQ.3) THEN
71742 ANUM=ALPCOR*(2D0-X1-X2)**2
71743 ELSE
71744 ANUM=0.5D0*(2D0-X1-X2)**2
71745 ENDIF
71746 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
71747 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
71748 & R1**2/(1D0+R2**2-R1**2-X2)**2-
71749 & R2**2/(1D0+R1**2-R2**2-X1)**2)
71750 RFO=9D0*RFO/4D0
71751 ICOMBI=0
71752 ENDIF
71753
71754C...Find relevant LO and FO expression.
71755 IF(ICOMBI.EQ.0) THEN
71756 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
71757 RLO=RLO1
71758 RFO=RFO1
71759 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
71760 RLO=RLO2
71761 RFO=RFO2
71762 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71763 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
71764 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
71765 ELSEIF(ISSET4.EQ.1) THEN
71766 RLO=RLO4
71767 RFO=RFO4
71768 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
71769 RLO=0.5D0*(RLO1+RLO2)
71770 RFO=0.5D0*(RFO1+RFO2)
71771 ELSEIF(ISSET1.EQ.1) THEN
71772 RLO=RLO1
71773 RFO=RFO1
71774 ELSE
71775 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
71776 RLO=1D0
71777 RFO=0D0
71778 ENDIF
71779
71780C...Output.
71781 PYMAEL=RFO/RLO
71782
71783 RETURN
71784 END
71785
71786C*********************************************************************
71787
71788C...PYBOEI
71789C...Modifies an event so as to approximately take into account
71790C...Bose-Einstein effects according to a simple phenomenological
71791C...parametrization.
71792
71793 SUBROUTINE PYBOEI(NSAV)
71794
71795C...Double precision and integer declarations.
71796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71797 IMPLICIT INTEGER(I-N)
71798 INTEGER PYK,PYCHGE,PYCOMP
71799C...Parameter statement to help give large particle numbers.
71800 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71801 &KEXCIT=4000000,KDIMEN=5000000)
71802C...Commonblocks.
71803 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71804 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71805 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71806 COMMON/PYINT1/MINT(400),VINT(400)
71807 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
71808C...Local arrays and data.
71809 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
71810 &BEIW(100),BEI3W(100)
71811 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
71812C...Statement function: squared invariant mass.
71813 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
71814 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
71815
71816C...Boost event to overall CM frame. Calculate CM energy.
71817 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
71818 DO 100 J=1,4
71819 DPS(J)=0D0
71820 100 CONTINUE
71821 DO 120 I=1,N
71822 KFA=IABS(K(I,2))
71823 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
71824 & .AND.K(I,3).GT.0) THEN
71825 KFMA=IABS(K(K(I,3),2))
71826 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
71827 ENDIF
71828 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
71829 DO 110 J=1,4
71830 DPS(J)=DPS(J)+P(I,J)
71831 110 CONTINUE
71832 120 CONTINUE
71833 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
71834 &-DPS(3)/DPS(4))
71835 PECM=0D0
71836 DO 130 I=1,N
71837 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
71838 130 CONTINUE
71839
71840C...Check if we have separated strings
71841
71842C...Reserve copy of particles by species at end of record.
71843 IWP=0
71844 IWN=0
71845 NBE(0)=N+MSTU(3)
71846 NMAX=NBE(0)
71847 SMMIN=PECM
71848 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
71849 NBE(IBE)=NBE(IBE-1)
71850 DO 180 I=NSAV+1,N
71851 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
71852 DO 140 IIBE=1,IBE-1
71853 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
71854 140 CONTINUE
71855 ELSE
71856 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
71857 ENDIF
71858 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
71859 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
71860 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
71861 RETURN
71862 ENDIF
71863 NBE(IBE)=NBE(IBE)+1
71864 NMAX=NBE(IBE)
71865 K(NBE(IBE),1)=I
71866 K(NBE(IBE),2)=0
71867 K(NBE(IBE),3)=0
71868 K(NBE(IBE),4)=0
71869 K(NBE(IBE),5)=0
71870 P(NBE(IBE),1)=0.0D0
71871 P(NBE(IBE),2)=0.0D0
71872 P(NBE(IBE),3)=0.0D0
71873 P(NBE(IBE),4)=0.0D0
71874 P(NBE(IBE),5)=0.0D0
71875 SMMIN=MIN(SMMIN,P(I,5))
71876C...Check if particles comes from different W's or Z's
71877 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
71878 IM=I
71879 150 IF(K(IM,3).GT.0) THEN
71880 IM=K(IM,3)
71881 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
71882 K(NBE(IBE),5)=IM
71883 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
71884 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
71885 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
71886 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
71887 ENDIF
71888 ENDIF
71889C...Check if particles comes from different strings.
71890 IF(PARJ(94).GT.0.0D0) THEN
71891 IM=I
71892 160 IF(K(IM,3).GT.0) THEN
71893 IM=K(IM,3)
71894 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
71895 K(NBE(IBE),5)=IM
71896 ENDIF
71897 ENDIF
71898 DO 170 J=1,3
71899 P(NBE(IBE),J)=0D0
71900 V(NBE(IBE),J)=0D0
71901 170 CONTINUE
71902 P(NBE(IBE),5)=-1.0D0
71903 180 CONTINUE
71904 190 CONTINUE
71905 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
71906
71907C...Calculate separation between W+ and W- or between two Z0's.
71908C...No separation if there has been re-connections.
71909 SIGW=PARJ(93)
71910 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
71911 IF(K(IWP,2).EQ.23) THEN
71912 DMW=PMAS(23,1)
71913 DGW=PMAS(23,2)
71914 ELSE
71915 DMW=PMAS(24,1)
71916 DGW=PMAS(24,2)
71917 ENDIF
71918 DMP=P(IWP,5)
71919 DMN=P(IWN,5)
71920 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
71921 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
71922 TAUP=-TAUPD*LOG(PYR(IDUM))
71923 TAUN=-TAUND*LOG(PYR(IDUM))
71924 DXP=TAUP*PYP(IWP,8)/DMP
71925 DXN=TAUN*PYP(IWN,8)/DMN
71926 DX=DXP+DXN
71927 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
71928 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
71929 ENDIF
71930
71931C...Add separation between strings.
71932 IF(PARJ(94).GT.0.0D0) THEN
71933 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
71934 IWP=-1
71935 IWN=-1
71936 ENDIF
71937
71938 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
71939 DO 220 IBE=1,MIN(9,MSTJ(52))
71940 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
71941 Q2MIN=PECM**2
71942 I1=K(I1M,1)
71943 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
71944 IF(I2M.EQ.I1M) GOTO 200
71945 I2=K(I2M,1)
71946 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
71947 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
71948 & (P(I1,5)+P(I2,5))**2
71949 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
71950 Q2MIN=Q2
71951 ENDIF
71952 200 CONTINUE
71953 P(I1M,5)=Q2MIN
71954 210 CONTINUE
71955 220 CONTINUE
71956 ENDIF
71957
71958C...Tabulate integral for subsequent momentum shift.
71959 DO 400 IBE=1,MIN(9,MSTJ(52))
71960 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
71961 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
71962 & .LE.1) GOTO 270
71963 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
71964 & NBE(7)-NBE(6)).LE.1) GOTO 270
71965 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
71966 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
71967 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
71968 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
71969 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
71970 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
71971 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
71972 QDELW=0.1D0*MIN(PMHQ,SIGW)
71973 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
71974 IF(MSTJ(51).EQ.1) THEN
71975 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
71976 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
71977 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
71978 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
71979 BEEX=EXP(0.5D0*QDEL/PARJ(93))
71980 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
71981 BEEXW=EXP(0.5D0*QDELW/SIGW)
71982 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
71983 BERT=EXP(-QDEL/PARJ(93))
71984 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
71985 BERTW=EXP(-QDELW/SIGW)
71986 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
71987 ELSE
71988 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
71989 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
71990 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
71991 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
71992 ENDIF
71993 DO 230 IBIN=1,NBIN
71994 QBIN=QDEL*(IBIN-0.5D0)
71995 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
71996 IF(MSTJ(51).EQ.1) THEN
71997 BEEX=BEEX*BERT
71998 BEI(IBIN)=BEI(IBIN)*BEEX
71999 ELSE
72000 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
72001 ENDIF
72002 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
72003 230 CONTINUE
72004 DO 240 IBIN=1,NBIN3
72005 QBIN=QDEL3*(IBIN-0.5D0)
72006 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
72007 IF(MSTJ(51).EQ.1) THEN
72008 BEEX3=BEEX3*BERT3
72009 BEI3(IBIN)=BEI3(IBIN)*BEEX3
72010 ELSE
72011 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
72012 ENDIF
72013 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
72014 240 CONTINUE
72015 DO 250 IBIN=1,NBINW
72016 QBIN=QDELW*(IBIN-0.5D0)
72017 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
72018 IF(MSTJ(51).EQ.1) THEN
72019 BEEXW=BEEXW*BERTW
72020 BEIW(IBIN)=BEIW(IBIN)*BEEXW
72021 ELSE
72022 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
72023 ENDIF
72024 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
72025 250 CONTINUE
72026 DO 260 IBIN=1,NBIN3W
72027 QBIN=QDEL3W*(IBIN-0.5D0)
72028 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
72029 & SQRT(QBIN**2+PMHQ**2)
72030 IF(MSTJ(51).EQ.1) THEN
72031 BEEX3W=BEEX3W*BERT3W
72032 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
72033 ELSE
72034 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
72035 ENDIF
72036 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
72037 260 CONTINUE
72038
72039C...Loop through particle pairs and find old relative momentum.
72040 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
72041 I1=K(I1M,1)
72042 DO 380 I2M=I1M+1,NBE(IBE)
72043 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
72044 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
72045 I2=K(I2M,1)
72046 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
72047 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
72048 IF(Q2OLD.LE.0.0D0) GOTO 380
72049 QOLD=SQRT(Q2OLD)
72050
72051C...Calculate new relative momentum.
72052 QMOV=0.0D0
72053 QMOV3=0.0D0
72054 QMOVW=0.0D0
72055 QMOV3W=0.0D0
72056 IF(QOLD.LT.1D-3*QDEL) THEN
72057 GOTO 280
72058 ELSEIF(QOLD.LE.QDEL) THEN
72059 QMOV=QOLD/3D0
72060 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
72061 RBIN=QOLD/QDEL
72062 IBIN=RBIN
72063 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
72064 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
72065 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72066 ELSE
72067 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72068 ENDIF
72069 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
72070 IF(QOLD.LT.1D-3*QDEL3) THEN
72071 GOTO 290
72072 ELSEIF(QOLD.LE.QDEL3) THEN
72073 QMOV3=QOLD/3D0
72074 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
72075 RBIN3=QOLD/QDEL3
72076 IBIN3=RBIN3
72077 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
72078 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
72079 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72080 ELSE
72081 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72082 ENDIF
72083 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
72084 RSCALE=1.0D0
72085 IF(MSTJ(54).EQ.2)
72086 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
72087 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
72088 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
72089
72090 IF(QOLD.LT.1D-3*QDELW) THEN
72091 GOTO 300
72092 ELSEIF(QOLD.LE.QDELW) THEN
72093 QMOVW=QOLD/3D0
72094 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
72095 RBINW=QOLD/QDELW
72096 IBINW=RBINW
72097 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
72098 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
72099 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
72100 ELSE
72101 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72102 ENDIF
72103 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
72104 IF(QOLD.LT.1D-3*QDEL3W) THEN
72105 GOTO 310
72106 ELSEIF(QOLD.LE.QDEL3W) THEN
72107 QMOV3W=QOLD/3D0
72108 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
72109 RBIN3W=QOLD/QDEL3W
72110 IBIN3W=RBIN3W
72111 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
72112 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
72113 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72114 ELSE
72115 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
72116 ENDIF
72117 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
72118 IF(MSTJ(54).EQ.2)
72119 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
72120
72121 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
72122 DO 330 J=1,3
72123 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
72124 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
72125 330 CONTINUE
72126 IF(MSTJ(54).GE.1) THEN
72127 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
72128 DO 340 J=1,3
72129 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
72130 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
72131 340 CONTINUE
72132 ELSEIF(MSTJ(54).LE.-1) THEN
72133 EDEL=P(I1,4)+P(I2,4)-
72134 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
72135 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72136 & (P(I1,3)-P(I2,3))**2
72137 WMAX=-1.0D20
72138 MI3=0
72139 MI4=0
72140 S12=SDIP(I1,I2)
72141 SM1=(P(I1,5)+SMMIN)**2
72142 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72143 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
72144 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
72145 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72146 & K(I3M,5).NE.K(I1M,5)) GOTO 360
72147 I3=K(I3M,1)
72148 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
72149 S13=SDIP(I1,I3)
72150 S23=SDIP(I2,I3)
72151 SM3=(P(I3,5)+SMMIN)**2
72152 IF(MSTJ(54).EQ.-2) THEN
72153 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
72154 & S23*MIN(SM1,SM3))*SM1)
72155 ELSE
72156 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
72157 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
72158 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
72159 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
72160 ENDIF
72161 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
72162 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
72163 & GOTO 360
72164 ELSE
72165 IF(WMAX*WI.GE.1.0) GOTO 360
72166 ENDIF
72167 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
72168 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
72169 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
72170 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
72171 & K(I4M,5).NE.K(I1M,5)) GOTO 350
72172 I4=K(I4M,1)
72173 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
72174 & GOTO 350
72175 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
72176 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72177 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
72178 & GOTO 350
72179 IF(MSTJ(54).EQ.-2) THEN
72180 S14=SDIP(I1,I4)
72181 S24=SDIP(I2,I4)
72182 S34=SDIP(I3,I4)
72183 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
72184 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
72185 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
72186 W=MIN(W,MIN(S23,S24)*S13*S14)
72187 W=1.0D0/W
72188 ELSE
72189C...weight=1-cos(theta)/mtot2
72190 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
72191 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
72192 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
72193 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
72194 W=1.0D0/S1234
72195 IF(W.LE.WMAX) GOTO 350
72196 ENDIF
72197 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
72198 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
72199 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
72200 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
72201 IF(W.LE.WMAX) GOTO 350
72202 MI3=I3M
72203 MI4=I4M
72204 WMAX=W
72205 350 CONTINUE
72206 360 CONTINUE
72207 IF(MI4.EQ.0) GOTO 380
72208 I3=K(MI3,1)
72209 I4=K(MI4,1)
72210 EOLD=P(I3,4)+P(I4,4)
72211 ENEW=EOLD+EDEL
72212 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
72213 & (P(I3,3)+P(I4,3))**2
72214 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
72215 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
72216 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
72217 DO 370 J=1,3
72218 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
72219 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
72220 370 CONTINUE
72221 ENDIF
72222 380 CONTINUE
72223 390 CONTINUE
72224 400 CONTINUE
72225
72226C...Shift momenta and recalculate energies.
72227 ESUMP=0.0D0
72228 ESUM=0.0D0
72229 PROD=0.0D0
72230 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72231 I=K(IM,1)
72232 ESUMP=ESUMP+P(I,4)
72233 DO 410 J=1,3
72234 P(I,J)=P(I,J)+P(IM,J)
72235 410 CONTINUE
72236 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72237 ESUM=ESUM+P(I,4)
72238 DO 420 J=1,3
72239 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72240 420 CONTINUE
72241 430 CONTINUE
72242
72243 PARJ(96)=0.0D0
72244 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
72245 440 ALPHA=(ESUMP-ESUM)/PROD
72246 PARJ(96)=PARJ(96)+ALPHA
72247 PROD=0.0D0
72248 ESUM=0.0D0
72249 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
72250 I=K(IM,1)
72251 DO 450 J=1,3
72252 P(I,J)=P(I,J)+ALPHA*V(IM,J)
72253 450 CONTINUE
72254 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72255 ESUM=ESUM+P(I,4)
72256 DO 460 J=1,3
72257 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
72258 460 CONTINUE
72259 470 CONTINUE
72260 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
72261 & GOTO 440
72262 ENDIF
72263
72264C...Rescale all momenta for energy conservation.
72265 PES=0D0
72266 PQS=0D0
72267 DO 480 I=1,N
72268 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
72269 PES=PES+P(I,4)
72270 PQS=PQS+P(I,5)**2/P(I,4)
72271 480 CONTINUE
72272 PARJ(95)=PES-PECM
72273 FAC=(PECM-PQS)/(PES-PQS)
72274 DO 500 I=1,N
72275 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
72276 DO 490 J=1,3
72277 P(I,J)=FAC*P(I,J)
72278 490 CONTINUE
72279 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
72280 500 CONTINUE
72281
72282C...Boost back to correct reference frame.
72283 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
72284 DO 520 I=1,N
72285 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
72286 520 CONTINUE
72287
72288 RETURN
72289 END
72290
72291C*********************************************************************
72292
72293C...PYBESQ
72294C...Calculates the momentum shift in a system of two particles assuming
72295C...the relative momentum squared should be shifted to Q2NEW. NI is the
72296C...last position occupied in /PYJETS/.
72297
72298 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
72299
72300C...Double precision and integer declarations.
72301 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72302 IMPLICIT INTEGER(I-N)
72303 INTEGER PYK,PYCHGE,PYCOMP
72304C...Parameter statement to help give large particle numbers.
72305 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72306 &KEXCIT=4000000,KDIMEN=5000000)
72307C...Commonblocks.
72308 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72309 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72310 SAVE /PYJETS/,/PYDAT1/
72311C...Local arrays and data.
72312 DIMENSION DP(5)
72313 SAVE HC1
72314
72315 IF(MSTJ(55).EQ.0) THEN
72316 DQ2=Q2NEW-Q2OLD
72317 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
72318 & (P(I1,3)-P(I2,3))**2
72319 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
72320 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
72321 SE=P(I1,4)+P(I2,4)
72322 DE=P(I1,4)-P(I2,4)
72323 DQ2SE=DQ2+SE**2
72324 DA=SE*DE*DP12-DP2*DQ2SE
72325 DB=DP2*DQ2SE-DP12**2
72326 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
72327 DO 100 J=1,3
72328 PD=HA*(P(I1,J)-P(I2,J))
72329 P(NI+1,J)=PD
72330 P(NI+2,J)=-PD
72331 100 CONTINUE
72332 RETURN
72333 ENDIF
72334
72335 K(NI+1,1)=1
72336 K(NI+2,1)=1
72337 DO 110 J=1,5
72338 P(NI+1,J)=P(I1,J)
72339 P(NI+2,J)=P(I2,J)
72340 DP(J)=P(I1,J)+P(I2,J)
72341 110 CONTINUE
72342
72343C...Boost to cms and rotate first particle to z-axis
72344 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
72345 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
72346 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
72347 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
72348 S=Q2NEW+(P(I1,5)+P(I2,5))**2
72349 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
72350 P(NI+1,1)=0.0D0
72351 P(NI+1,2)=0.0D0
72352 P(NI+1,3)=PZ
72353 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
72354 P(NI+2,1)=0.0D0
72355 P(NI+2,2)=0.0D0
72356 P(NI+2,3)=-PZ
72357 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
72358 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
72359 CALL PYROBO(NI+1,NI+2,THE,PHI,
72360 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
72361
72362 DO 120 J=1,3
72363 P(NI+1,J)=P(NI+1,J)-P(I1,J)
72364 P(NI+2,J)=P(NI+2,J)-P(I2,J)
72365 120 CONTINUE
72366
72367 RETURN
72368 END
72369
72370C*********************************************************************
72371
72372C...PYMASS
72373C...Gives the mass of a particle/parton.
72374
72375 FUNCTION PYMASS(KF)
72376
72377C...Double precision and integer declarations.
72378 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72379 IMPLICIT INTEGER(I-N)
72380 INTEGER PYK,PYCHGE,PYCOMP
72381C...Commonblocks.
72382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72383 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72384 SAVE /PYDAT1/,/PYDAT2/
72385
72386C...Reset variables. Compressed code. Special case for popcorn diquarks.
72387 PYMASS=0D0
72388 KFA=IABS(KF)
72389 KC=PYCOMP(KF)
72390 IF(KC.EQ.0) THEN
72391 MSTJ(93)=0
72392 RETURN
72393 ENDIF
72394
72395C...Guarantee use of constituent masses for internal checks.
72396 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
72397 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
72398 IF(KFA.LE.5) THEN
72399 PYMASS=PARF(100+KFA)
72400 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
72401 ELSEIF(KFA.LE.10) THEN
72402 PYMASS=PMAS(KFA,1)
72403 ELSEIF(MSTJ(93).EQ.1) THEN
72404 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
72405 ELSE
72406 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
72407 ENDIF
72408
72409C...Other masses can be read directly off table.
72410 ELSE
72411 PYMASS=PMAS(KC,1)
72412 ENDIF
72413
72414C...Optional mass broadening according to truncated Breit-Wigner
72415C...(either in m or in m^2).
72416 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
72417 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
72418 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
72419 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
72420 ELSE
72421 PM0=PYMASS
72422 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
72423 & (PM0*PMAS(KC,2)))
72424 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
72425 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
72426 & (PMUPP-PMLOW)*PYR(0))))
72427 ENDIF
72428 ENDIF
72429 MSTJ(93)=0
72430
72431 RETURN
72432 END
72433
72434C*********************************************************************
72435
72436C...PYMRUN
72437C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
72438C...for Higgs couplings. Everything else sent on to PYMASS.
72439
72440 FUNCTION PYMRUN(KF,Q2)
72441
72442C...Double precision and integer declarations.
72443 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72444 IMPLICIT INTEGER(I-N)
72445 INTEGER PYK,PYCHGE,PYCOMP
72446C...Commonblocks.
72447 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72448 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72449 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
72450 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
72451
72452C...Most masses not handled here.
72453 KFA=IABS(KF)
72454 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
72455 PYMRUN=PYMASS(KF)
72456
72457C...Current-algebra masses, but no Q2 dependence.
72458 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
72459 PYMRUN=PARF(90+KFA)
72460
72461C...Running current-algebra masses.
72462 ELSE
72463 AS=PYALPS(Q2)
72464 PYMRUN=PARF(90+KFA)*
72465 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
72466 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
72467 ENDIF
72468
72469 RETURN
72470 END
72471
72472C*********************************************************************
72473
72474C...PYNAME
72475C...Gives the particle/parton name as a character string.
72476
72477 SUBROUTINE PYNAME(KF,CHAU)
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 COMMON/PYDAT4/CHAF(500,2)
72487 CHARACTER CHAF*16
72488 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
72489C...Local character variable.
72490 CHARACTER CHAU*16
72491
72492C...Read out code with distinction particle/antiparticle.
72493 CHAU=' '
72494 KC=PYCOMP(KF)
72495 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
72496
72497
72498 RETURN
72499 END
72500
72501C*********************************************************************
72502
72503C...PYCHGE
72504C...Gives three times the charge for a particle/parton.
72505
72506 FUNCTION PYCHGE(KF)
72507
72508C...Double precision and integer declarations.
72509 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72510 IMPLICIT INTEGER(I-N)
72511 INTEGER PYK,PYCHGE,PYCOMP
72512C...Commonblocks.
72513 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72514 SAVE /PYDAT2/
72515
72516C...Read out charge and change sign for antiparticle.
72517 PYCHGE=0
72518 KC=PYCOMP(KF)
72519 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
72520
72521 RETURN
72522 END
72523
72524C*********************************************************************
72525
72526C...PYCOMP
72527C...Compress the standard KF codes for use in mass and decay arrays;
72528C...also checks whether a given code actually is defined.
72529
72530 FUNCTION PYCOMP(KF)
72531
72532C...Double precision and integer declarations.
72533 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72534 IMPLICIT INTEGER(I-N)
72535 INTEGER PYK,PYCHGE,PYCOMP
72536C...Commonblocks.
72537 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72538 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72539 SAVE /PYDAT1/,/PYDAT2/
72540C...Local arrays and saved data.
72541 DIMENSION KFORD(100:500),KCORD(101:500)
72542 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
72543
72544C...Whenever necessary reorder codes for faster search.
72545 IF(MSTU(20).EQ.0) THEN
72546 NFORD=100
72547 KFORD(100)=0
72548 DO 120 I=101,500
72549 KFA=KCHG(I,4)
72550 IF(KFA.LE.100) GOTO 120
72551 NFORD=NFORD+1
72552 DO 100 I1=NFORD-1,0,-1
72553 IF(KFA.GE.KFORD(I1)) GOTO 110
72554 KFORD(I1+1)=KFORD(I1)
72555 KCORD(I1+1)=KCORD(I1)
72556 100 CONTINUE
72557 110 KFORD(I1+1)=KFA
72558 KCORD(I1+1)=I
72559 120 CONTINUE
72560 MSTU(20)=1
72561 KFLAST=0
72562 KCLAST=0
72563 ENDIF
72564
72565C...Fast action if same code as in latest call.
72566 IF(KF.EQ.KFLAST) THEN
72567 PYCOMP=KCLAST
72568 RETURN
72569 ENDIF
72570
72571C...Starting values. Remove internal diquark flags.
72572 PYCOMP=0
72573 KFA=IABS(KF)
72574 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
72575 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
72576
72577C...Simple cases: direct translation.
72578 IF(KFA.GT.KFORD(NFORD)) THEN
72579 ELSEIF(KFA.LE.100) THEN
72580 PYCOMP=KFA
72581
72582C...Else binary search.
72583 ELSE
72584 IMIN=100
72585 IMAX=NFORD+1
72586 130 IAVG=(IMIN+IMAX)/2
72587 IF(KFORD(IAVG).GT.KFA) THEN
72588 IMAX=IAVG
72589 IF(IMAX.GT.IMIN+1) GOTO 130
72590 ELSEIF(KFORD(IAVG).LT.KFA) THEN
72591 IMIN=IAVG
72592 IF(IMAX.GT.IMIN+1) GOTO 130
72593 ELSE
72594 PYCOMP=KCORD(IAVG)
72595 ENDIF
72596 ENDIF
72597
72598C...Check if antiparticle allowed.
72599 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
72600 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
72601 ENDIF
72602
72603C...Save codes for possible future fast action.
72604 KFLAST=KF
72605 KCLAST=PYCOMP
72606
72607 RETURN
72608 END
72609
72610C*********************************************************************
72611
72612C...PYERRM
72613C...Informs user of errors in program execution.
72614
72615 SUBROUTINE PYERRM(MERR,CHMESS)
72616
72617C...Double precision and integer declarations.
72618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72619 IMPLICIT INTEGER(I-N)
72620 INTEGER PYK,PYCHGE,PYCOMP
72621C...Commonblocks.
72622 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72623 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72624 SAVE /PYJETS/,/PYDAT1/
72625C...Local character variable.
72626 CHARACTER CHMESS*(*)
72627
72628C...Write first few warnings, then be silent.
72629 IF(MERR.LE.10) THEN
72630 MSTU(27)=MSTU(27)+1
72631 MSTU(28)=MERR
72632 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
72633 & MERR,MSTU(31),CHMESS
72634
72635C...Write first few errors, then be silent or stop program.
72636 ELSEIF(MERR.LE.20) THEN
72637 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
72638 MSTU(30)=MSTU(30)+1
72639 MSTU(24)=MERR-10
72640 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
72641 & MERR-10,MSTU(31),CHMESS
72642 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
72643 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
72644 WRITE(MSTU(11),5200)
72645 IF(MERR.NE.17) CALL PYLIST(2)
72646 CALL PYSTOP(3)
72647 ENDIF
72648
72649C...Stop program in case of irreparable error.
72650 ELSE
72651 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
72652 CALL PYSTOP(3)
72653 ENDIF
72654
72655C...Formats for output.
72656 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
72657 &' PYEXEC calls:'/5X,A)
72658 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
72659 &' PYEXEC calls:'/5X,A)
72660 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
72661 &'event!')
72662 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
72663 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
72664
72665 RETURN
72666 END
72667
72668C*********************************************************************
72669
72670C...PYALEM
72671C...Calculates the running alpha_electromagnetic.
72672
72673 FUNCTION PYALEM(Q2)
72674
72675C...Double precision and integer declarations.
72676 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72677 IMPLICIT INTEGER(I-N)
72678 INTEGER PYK,PYCHGE,PYCOMP
72679C...Commonblocks.
72680 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72681 SAVE /PYDAT1/
72682
72683C...Calculate real part of photon vacuum polarization.
72684C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
72685C...For hadrons use parametrization of H. Burkhardt et al.
72686C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
72687 AEMPI=PARU(101)/(3D0*PARU(1))
72688 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
72689 RPIGG=0D0
72690 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
72691 RPIGG=0D0
72692 ELSEIF(MSTU(101).EQ.2) THEN
72693 RPIGG=1D0-PARU(101)/PARU(103)
72694 ELSEIF(Q2.LT.0.09D0) THEN
72695 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
72696 ELSEIF(Q2.LT.9D0) THEN
72697 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
72698 & 0.00238D0*LOG(1D0+3.927D0*Q2)
72699 ELSEIF(Q2.LT.1D4) THEN
72700 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
72701 & 0.00299D0*LOG(1D0+Q2)
72702 ELSE
72703 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
72704 & 0.00293D0*LOG(1D0+Q2)
72705 ENDIF
72706
72707C...Calculate running alpha_em.
72708 PYALEM=PARU(101)/(1D0-RPIGG)
72709 PARU(108)=PYALEM
72710
72711 RETURN
72712 END
72713
72714C*********************************************************************
72715
72716C...PYALPS
72717C...Gives the value of alpha_strong.
72718
72719 FUNCTION PYALPS(Q2)
72720
72721C...Double precision and integer declarations.
72722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72723 IMPLICIT INTEGER(I-N)
72724 INTEGER PYK,PYCHGE,PYCOMP
72725C...Commonblocks.
72726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72728 SAVE /PYDAT1/,/PYDAT2/
72729C...Coefficients for second-order threshold matching.
72730C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
72731 DIMENSION STEPDN(6),STEPUP(6)
72732c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
72733c &(2D0*321D0/3703D0),0D0/
72734c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
72735c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
72736 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
72737 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
72738
72739C...Constant alpha_strong trivial. Pick artificial Lambda.
72740 IF(MSTU(111).LE.0) THEN
72741 PYALPS=PARU(111)
72742 MSTU(118)=MSTU(112)
72743 PARU(117)=0.2D0
72744 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
72745 & ((33D0-2D0*MSTU(112))*PARU(111)))
72746 PARU(118)=PARU(111)
72747 RETURN
72748 ENDIF
72749
72750C...Find effective Q2, number of flavours and Lambda.
72751 Q2EFF=Q2
72752 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
72753 NF=MSTU(112)
72754 ALAM2=PARU(112)**2
72755 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
72756 Q2THR=PARU(113)*PMAS(NF,1)**2
72757 IF(Q2EFF.LT.Q2THR) THEN
72758 NF=NF-1
72759 Q2RAT=Q2THR/ALAM2
72760 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
72761 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
72762 GOTO 100
72763 ENDIF
72764 ENDIF
72765 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
72766 Q2THR=PARU(113)*PMAS(NF+1,1)**2
72767 IF(Q2EFF.GT.Q2THR) THEN
72768 NF=NF+1
72769 Q2RAT=Q2THR/ALAM2
72770 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
72771 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
72772 GOTO 110
72773 ENDIF
72774 ENDIF
72775 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
72776 PARU(117)=SQRT(ALAM2)
72777
72778C...Evaluate first or second order alpha_strong.
72779 B0=(33D0-2D0*NF)/6D0
72780 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
72781 IF(MSTU(111).EQ.1) THEN
72782 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
72783 ELSE
72784 B1=(153D0-19D0*NF)/6D0
72785 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
72786 & (B0**2*ALGQ)))
72787 ENDIF
72788 MSTU(118)=NF
72789 PARU(118)=PYALPS
72790
72791 RETURN
72792 END
72793
72794C*********************************************************************
72795
72796C...PYANGL
72797C...Reconstructs an angle from given x and y coordinates.
72798
72799 FUNCTION PYANGL(X,Y)
72800
72801C...Double precision and integer declarations.
72802 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72803 IMPLICIT INTEGER(I-N)
72804 INTEGER PYK,PYCHGE,PYCOMP
72805C...Commonblocks.
72806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72807 SAVE /PYDAT1/
72808
72809 PYANGL=0D0
72810 R=SQRT(X**2+Y**2)
72811 IF(R.LT.1D-20) RETURN
72812 IF(ABS(X)/R.LT.0.8D0) THEN
72813 PYANGL=SIGN(ACOS(X/R),Y)
72814 ELSE
72815 PYANGL=ASIN(Y/R)
72816 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
72817 PYANGL=PARU(1)-PYANGL
72818 ELSEIF(X.LT.0D0) THEN
72819 PYANGL=-PARU(1)-PYANGL
72820 ENDIF
72821 ENDIF
72822
72823 RETURN
72824 END
72825
72826C*********************************************************************
72827
72828C...PYROBO
72829C...Performs rotations and boosts.
72830
72831 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
72832
72833C...Double precision and integer declarations.
72834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72835 IMPLICIT INTEGER(I-N)
72836 INTEGER PYK,PYCHGE,PYCOMP
72837C...Commonblocks.
72838 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72840 SAVE /PYJETS/,/PYDAT1/
72841C...Local arrays.
72842 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
72843
72844C...Find and check range of rotation/boost.
72845 IMIN=IMI
72846 IF(IMIN.LE.0) IMIN=1
72847 IF(MSTU(1).GT.0) IMIN=MSTU(1)
72848 IMAX=IMA
72849 IF(IMAX.LE.0) IMAX=N
72850 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72851 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
72852 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
72853 RETURN
72854 ENDIF
72855
72856C...Optional resetting of V (when not set before.)
72857 IF(MSTU(33).NE.0) THEN
72858 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
72859 DO 100 J=1,5
72860 V(I,J)=0D0
72861 100 CONTINUE
72862 110 CONTINUE
72863 MSTU(33)=0
72864 ENDIF
72865
72866C...Rotate, typically from z axis to direction (theta,phi).
72867 IF(THE**2+PHI**2.GT.1D-20) THEN
72868 ROT(1,1)=COS(THE)*COS(PHI)
72869 ROT(1,2)=-SIN(PHI)
72870 ROT(1,3)=SIN(THE)*COS(PHI)
72871 ROT(2,1)=COS(THE)*SIN(PHI)
72872 ROT(2,2)=COS(PHI)
72873 ROT(2,3)=SIN(THE)*SIN(PHI)
72874 ROT(3,1)=-SIN(THE)
72875 ROT(3,2)=0D0
72876 ROT(3,3)=COS(THE)
72877 DO 140 I=IMIN,IMAX
72878 IF(K(I,1).LE.0) GOTO 140
72879 DO 120 J=1,3
72880 PR(J)=P(I,J)
72881 VR(J)=V(I,J)
72882 120 CONTINUE
72883 DO 130 J=1,3
72884 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
72885 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
72886 130 CONTINUE
72887 140 CONTINUE
72888 ENDIF
72889
72890C...Boost, typically from rest to momentum/energy=beta.
72891 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
72892 DBX=BEX
72893 DBY=BEY
72894 DBZ=BEZ
72895 DB=SQRT(DBX**2+DBY**2+DBZ**2)
72896 EPS1=1D0-1D-12
72897 IF(DB.GT.EPS1) THEN
72898C...Rescale boost vector if too close to unity.
72899 CALL PYERRM(3,'(PYROBO:) boost vector too large')
72900 DBX=DBX*(EPS1/DB)
72901 DBY=DBY*(EPS1/DB)
72902 DBZ=DBZ*(EPS1/DB)
72903 DB=EPS1
72904 ENDIF
72905 DGA=1D0/SQRT(1D0-DB**2)
72906 DO 160 I=IMIN,IMAX
72907 IF(K(I,1).LE.0) GOTO 160
72908 DO 150 J=1,4
72909 DP(J)=P(I,J)
72910 DV(J)=V(I,J)
72911 150 CONTINUE
72912 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
72913 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
72914 P(I,1)=DP(1)+DGABP*DBX
72915 P(I,2)=DP(2)+DGABP*DBY
72916 P(I,3)=DP(3)+DGABP*DBZ
72917 P(I,4)=DGA*(DP(4)+DBP)
72918 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
72919 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
72920 V(I,1)=DV(1)+DGABV*DBX
72921 V(I,2)=DV(2)+DGABV*DBY
72922 V(I,3)=DV(3)+DGABV*DBZ
72923 V(I,4)=DGA*(DV(4)+DBV)
72924 160 CONTINUE
72925 ENDIF
72926
72927 RETURN
72928 END
72929
72930C*********************************************************************
72931
72932C...PYEDIT
72933C...Performs global manipulations on the event record, in particular
72934C...to exclude unstable or undetectable partons/particles.
72935
72936 SUBROUTINE PYEDIT(MEDIT)
72937
72938C...Double precision and integer declarations.
72939 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72940 IMPLICIT INTEGER(I-N)
72941 INTEGER PYK,PYCHGE,PYCOMP
72942C...Parameter statement to help give large particle numbers.
72943 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
72944 &KEXCIT=4000000,KDIMEN=5000000)
72945C...Commonblocks.
72946 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
72947 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
72948 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
72949 COMMON/PYCTAG/NCT,MCT(4000,2)
72950 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
72951C...Local arrays.
72952 DIMENSION NS(2),PTS(2),PLS(2)
72953
72954C...Remove unwanted partons/particles.
72955 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
72956 IMAX=N
72957 IF(MSTU(2).GT.0) IMAX=MSTU(2)
72958 I1=MAX(1,MSTU(1))-1
72959 DO 110 I=MAX(1,MSTU(1)),IMAX
72960 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
72961 IF(MEDIT.EQ.1) THEN
72962 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72963 ELSEIF(MEDIT.EQ.2) THEN
72964 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72965 KC=PYCOMP(K(I,2))
72966 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
72967 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
72968 & K(I,2).EQ.KSUSY1+39) GOTO 110
72969 ELSEIF(MEDIT.EQ.3) THEN
72970 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
72971 KC=PYCOMP(K(I,2))
72972 IF(KC.EQ.0) GOTO 110
72973 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
72974 ELSEIF(MEDIT.EQ.5) THEN
72975 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
72976 KC=PYCOMP(K(I,2))
72977 IF(KC.EQ.0) GOTO 110
72978 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
72979 & KCHG(KC,2).EQ.0) GOTO 110
72980 ENDIF
72981
72982C...Pack remaining partons/particles. Origin no longer known.
72983 I1=I1+1
72984 DO 100 J=1,5
72985 K(I1,J)=K(I,J)
72986 P(I1,J)=P(I,J)
72987 V(I1,J)=V(I,J)
72988 100 CONTINUE
72989 K(I1,3)=0
72990 110 CONTINUE
72991 IF(I1.LT.N) MSTU(3)=0
72992 IF(I1.LT.N) MSTU(70)=0
72993 N=I1
72994
72995C...Selective removal of class of entries. New position of retained.
72996 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
72997 I1=0
72998 DO 120 I=1,N
72999 K(I,3)=MOD(K(I,3),MSTU(5))
73000 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
73001 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
73002 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
73003 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
73004 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
73005 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
73006 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
73007 I1=I1+1
73008 K(I,3)=K(I,3)+MSTU(5)*I1
73009 120 CONTINUE
73010
73011C...Find new event history information and replace old.
73012 DO 140 I=1,N
73013 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
73014 & K(I,3)/MSTU(5).EQ.0) GOTO 140
73015 ID=I
73016 130 IM=MOD(K(ID,3),MSTU(5))
73017 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
73018 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
73019 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
73020 ID=IM
73021 GOTO 130
73022 ENDIF
73023 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
73024 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
73025 & K(IM,2).EQ.94) THEN
73026 ID=IM
73027 GOTO 130
73028 ENDIF
73029 ENDIF
73030 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
73031 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
73032 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
73033 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
73034 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
73035 & K(K(I,4),3)/MSTU(5)
73036 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
73037 & K(K(I,5),3)/MSTU(5)
73038 ELSE
73039 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
73040 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
73041 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
73042 KCD=MOD(K(I,4),MSTU(5))
73043 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73044 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73045 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
73046 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
73047 KCD=MOD(K(I,5),MSTU(5))
73048 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
73049 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
73050 ENDIF
73051 140 CONTINUE
73052
73053C...Pack remaining entries.
73054 I1=0
73055 MSTU90=MSTU(90)
73056 MSTU(90)=0
73057 DO 170 I=1,N
73058 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
73059 I1=I1+1
73060 DO 150 J=1,5
73061 K(I1,J)=K(I,J)
73062 P(I1,J)=P(I,J)
73063 V(I1,J)=V(I,J)
73064 150 CONTINUE
73065C...Also update LHA1 colour tags
73066 MCT(I1,1)=MCT(I,1)
73067 MCT(I1,2)=MCT(I,2)
73068 K(I1,3)=MOD(K(I1,3),MSTU(5))
73069 DO 160 IZ=1,MSTU90
73070 IF(I.EQ.MSTU(90+IZ)) THEN
73071 MSTU(90)=MSTU(90)+1
73072 MSTU(90+MSTU(90))=I1
73073 PARU(90+MSTU(90))=PARU(90+IZ)
73074 ENDIF
73075 160 CONTINUE
73076 170 CONTINUE
73077 IF(I1.LT.N) MSTU(3)=0
73078 IF(I1.LT.N) MSTU(70)=0
73079 N=I1
73080
73081C...Fill in some missing daughter pointers (lost in colour flow).
73082 ELSEIF(MEDIT.EQ.16) THEN
73083 DO 220 I=1,N
73084 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
73085 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
73086C...Find daughters who point to mother.
73087 DO 180 I1=I+1,N
73088 IF(K(I1,3).NE.I) THEN
73089 ELSEIF(K(I,4).EQ.0) THEN
73090 K(I,4)=I1
73091 ELSE
73092 K(I,5)=I1
73093 ENDIF
73094 180 CONTINUE
73095 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73096 IF(K(I,4).NE.0) GOTO 220
73097C...Find daughters who point to documentation version of mother.
73098 IM=K(I,3)
73099 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
73100 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
73101 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
73102 DO 190 I1=I+1,N
73103 IF(K(I1,3).NE.IM) THEN
73104 ELSEIF(K(I,4).EQ.0) THEN
73105 K(I,4)=I1
73106 ELSE
73107 K(I,5)=I1
73108 ENDIF
73109 190 CONTINUE
73110 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73111 IF(K(I,4).NE.0) GOTO 220
73112C...Find daughters who point to documentation daughters who,
73113C...in their turn, point to documentation mother.
73114 ID1=IM
73115 ID2=IM
73116 DO 200 I1=IM+1,I-1
73117 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
73118 ID2=I1
73119 IF(ID1.EQ.IM) ID1=I1
73120 ENDIF
73121 200 CONTINUE
73122 DO 210 I1=I+1,N
73123 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
73124 ELSEIF(K(I,4).EQ.0) THEN
73125 K(I,4)=I1
73126 ELSE
73127 K(I,5)=I1
73128 ENDIF
73129 210 CONTINUE
73130 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
73131 220 CONTINUE
73132
73133C...Save top entries at bottom of PYJETS commonblock.
73134 ELSEIF(MEDIT.EQ.21) THEN
73135 IF(2*N.GE.MSTU(4)) THEN
73136 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
73137 RETURN
73138 ENDIF
73139 DO 240 I=1,N
73140 DO 230 J=1,5
73141 K(MSTU(4)-I,J)=K(I,J)
73142 P(MSTU(4)-I,J)=P(I,J)
73143 V(MSTU(4)-I,J)=V(I,J)
73144 230 CONTINUE
73145 240 CONTINUE
73146 MSTU(32)=N
73147
73148C...Restore bottom entries of commonblock PYJETS to top.
73149 ELSEIF(MEDIT.EQ.22) THEN
73150 DO 260 I=1,MSTU(32)
73151 DO 250 J=1,5
73152 K(I,J)=K(MSTU(4)-I,J)
73153 P(I,J)=P(MSTU(4)-I,J)
73154 V(I,J)=V(MSTU(4)-I,J)
73155 250 CONTINUE
73156 260 CONTINUE
73157 N=MSTU(32)
73158
73159C...Mark primary entries at top of commonblock PYJETS as untreated.
73160 ELSEIF(MEDIT.EQ.23) THEN
73161 I1=0
73162 DO 270 I=1,N
73163 KH=K(I,3)
73164 IF(KH.GE.1) THEN
73165 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
73166 ENDIF
73167 IF(KH.NE.0) GOTO 280
73168 I1=I1+1
73169 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
73170 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
73171 270 CONTINUE
73172 280 N=I1
73173
73174C...Place largest axis along z axis and second largest in xy plane.
73175 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
73176 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
73177 & P(MSTU(61),2)),0D0,0D0,0D0)
73178 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
73179 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
73180 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
73181 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
73182 IF(MEDIT.EQ.31) RETURN
73183
73184C...Rotate to put slim jet along +z axis.
73185 DO 290 IS=1,2
73186 NS(IS)=0
73187 PTS(IS)=0D0
73188 PLS(IS)=0D0
73189 290 CONTINUE
73190 DO 300 I=1,N
73191 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
73192 IF(MSTU(41).GE.2) THEN
73193 KC=PYCOMP(K(I,2))
73194 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73195 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73196 & K(I,2).EQ.KSUSY1+39) GOTO 300
73197 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73198 & .EQ.0) GOTO 300
73199 ENDIF
73200 IS=2D0-SIGN(0.5D0,P(I,3))
73201 NS(IS)=NS(IS)+1
73202 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
73203 300 CONTINUE
73204 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
73205 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
73206
73207C...Rotate to put second largest jet into -z,+x quadrant.
73208 DO 310 I=1,N
73209 IF(P(I,3).GE.0D0) GOTO 310
73210 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
73211 IF(MSTU(41).GE.2) THEN
73212 KC=PYCOMP(K(I,2))
73213 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
73214 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
73215 & K(I,2).EQ.KSUSY1+39) GOTO 310
73216 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
73217 & .EQ.0) GOTO 310
73218 ENDIF
73219 IS=2D0-SIGN(0.5D0,P(I,1))
73220 PLS(IS)=PLS(IS)-P(I,3)
73221 310 CONTINUE
73222 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
73223 & 0D0,0D0,0D0)
73224 ENDIF
73225
73226 RETURN
73227 END
73228
73229C*********************************************************************
73230
73231C...PYLIST
73232C...Gives program heading, or lists an event, or particle
73233C...data, or current parameter values.
73234
73235 SUBROUTINE PYLIST(MLIST)
73236
73237C...Double precision and integer declarations.
73238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73239 IMPLICIT INTEGER(I-N)
73240 INTEGER PYK,PYCHGE,PYCOMP
73241C...Parameter statement to help give large particle numbers.
73242 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73243 &KEXCIT=4000000,KDIMEN=5000000)
73244
73245C...HEPEVT commonblock.
73246 PARAMETER (NMXHEP=4000)
73247 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
73248 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
73249 DOUBLE PRECISION PHEP,VHEP
73250 SAVE /HEPEVT/
73251
73252C...User process event common block.
73253 INTEGER MAXNUP
73254 PARAMETER (MAXNUP=500)
73255 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
73256 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
73257 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
73258 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
73259 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
73260 SAVE /HEPEUP/
73261
73262C...Commonblocks.
73263 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73265 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73266 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73267 COMMON/PYCTAG/NCT,MCT(4000,2)
73268 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
73269C...Local arrays, character variables and data.
73270 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
73271 DIMENSION PS(6)
73272 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
73273
73274C...Initialization printout: version number and date of last change.
73275 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
73276 CALL PYLOGO
73277 MSTU(12)=12345
73278 IF(MLIST.EQ.0) RETURN
73279 ENDIF
73280
73281C...List event data, including additional lines after N.
73282 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
73283 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
73284 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
73285 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
73286 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
73287 LMX=12
73288 IF(MLIST.GE.2) LMX=16
73289 ISTR=0
73290 IMAX=N
73291 IF(MSTU(2).GT.0) IMAX=MSTU(2)
73292 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
73293 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
73294 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
73295 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
73296
73297C...Get particle name, pad it and check it is not too long.
73298 CALL PYNAME(K(I,2),CHAP)
73299 LEN=0
73300 DO 100 LEM=1,16
73301 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
73302 100 CONTINUE
73303 MDL=(K(I,1)+19)/10
73304 LDL=0
73305 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
73306 CHAC=CHAP
73307 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
73308 ELSE
73309 LDL=1
73310 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
73311 IF(LEN.EQ.0) THEN
73312 CHAC=CHDL(MDL)(1:2*LDL)//' '
73313 ELSE
73314 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
73315 & CHDL(MDL)(LDL+1:2*LDL)//' '
73316 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
73317 ENDIF
73318 ENDIF
73319
73320C...Add information on string connection.
73321 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
73322 & THEN
73323 KC=PYCOMP(K(I,2))
73324 KCC=0
73325 IF(KC.NE.0) KCC=KCHG(KC,2)
73326 IF(IABS(K(I,2)).EQ.39) THEN
73327 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
73328 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
73329 ISTR=1
73330 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
73331 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
73332 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
73333 ELSEIF(KCC.NE.0) THEN
73334 ISTR=0
73335 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
73336 ENDIF
73337 ENDIF
73338 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
73339 & CHAC(LMX-1:LMX-1)='I'
73340
73341C...Write data for particle/jet.
73342 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
73343 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
73344 & (P(I,J2),J2=1,5)
73345 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
73346 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
73347 & (P(I,J2),J2=1,5)
73348 ELSEIF(MLIST.EQ.1) THEN
73349 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
73350 & (P(I,J2),J2=1,5)
73351 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
73352 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
73353 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
73354 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73355 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
73356 & (P(I,J2),J2=1,5)
73357 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
73358 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
73359 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
73360 & ,10000),MCT(I,1),MCT(I,2)
73361 ELSE
73362 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
73363 & (P(I,J2),J2=1,5)
73364 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
73365 & ,MCT(I,1),MCT(I,2)
73366 ENDIF
73367 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
73368
73369C...Insert extra separator lines specified by user.
73370 IF(MSTU(70).GE.1) THEN
73371 ISEP=0
73372 DO 110 J=1,MIN(10,MSTU(70))
73373 IF(I.EQ.MSTU(70+J)) ISEP=1
73374 110 CONTINUE
73375 IF(ISEP.EQ.1) THEN
73376 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
73377 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
73378 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
73379 ENDIF
73380 ENDIF
73381 120 CONTINUE
73382
73383C...Sum of charges and momenta.
73384 DO 130 J=1,6
73385 PS(J)=PYP(0,J)
73386 130 CONTINUE
73387 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
73388 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
73389 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
73390 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
73391 ELSEIF(MLIST.EQ.1) THEN
73392 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
73393 ELSEIF(MLIST.LE.3) THEN
73394 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
73395 ELSE
73396 WRITE(MSTU(11),7000) PS(6)
73397 ENDIF
73398
73399C...Simple listing of HEPEVT entries (mainly for test purposes).
73400 ELSEIF(MLIST.EQ.5) THEN
73401 WRITE(MSTU(11),7100)
73402 DO 140 I=1,NHEP
73403 IF(ISTHEP(I).EQ.0) GOTO 140
73404 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
73405 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
73406 140 CONTINUE
73407
73408
73409C...Simple listing of user-process entries (mainly for test purposes).
73410 ELSEIF(MLIST.EQ.7) THEN
73411 WRITE(MSTU(11),7300)
73412 DO 150 I=1,NUP
73413 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
73414 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
73415 150 CONTINUE
73416
73417C...Give simple list of KF codes defined in program.
73418 ELSEIF(MLIST.EQ.11) THEN
73419 WRITE(MSTU(11),7500)
73420 DO 160 KF=1,80
73421 CALL PYNAME(KF,CHAP)
73422 CALL PYNAME(-KF,CHAN)
73423 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73424 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73425 160 CONTINUE
73426 DO 190 KFLS=1,3,2
73427 DO 180 KFLA=1,5
73428 DO 170 KFLB=1,KFLA-(3-KFLS)/2
73429 KF=1000*KFLA+100*KFLB+KFLS
73430 CALL PYNAME(KF,CHAP)
73431 CALL PYNAME(-KF,CHAN)
73432 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73433 170 CONTINUE
73434 180 CONTINUE
73435 190 CONTINUE
73436 DO 220 KMUL=0,5
73437 KFLS=3
73438 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
73439 IF(KMUL.EQ.5) KFLS=5
73440 KFLR=0
73441 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
73442 IF(KMUL.EQ.4) KFLR=2
73443 DO 210 KFLB=1,5
73444 DO 200 KFLC=1,KFLB-1
73445 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
73446 CALL PYNAME(KF,CHAP)
73447 CALL PYNAME(-KF,CHAN)
73448 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73449 IF(KF.EQ.311) THEN
73450 KFK=130
73451 CALL PYNAME(KFK,CHAP)
73452 WRITE(MSTU(11),7600) KFK,CHAP
73453 KFK=310
73454 CALL PYNAME(KFK,CHAP)
73455 WRITE(MSTU(11),7600) KFK,CHAP
73456 ENDIF
73457 200 CONTINUE
73458 KF=10000*KFLR+110*KFLB+KFLS
73459 CALL PYNAME(KF,CHAP)
73460 WRITE(MSTU(11),7600) KF,CHAP
73461 210 CONTINUE
73462 220 CONTINUE
73463 KF=100443
73464 CALL PYNAME(KF,CHAP)
73465 WRITE(MSTU(11),7600) KF,CHAP
73466 KF=100553
73467 CALL PYNAME(KF,CHAP)
73468 WRITE(MSTU(11),7600) KF,CHAP
73469 DO 260 KFLSP=1,3
73470 KFLS=2+2*(KFLSP/3)
73471 DO 250 KFLA=1,5
73472 DO 240 KFLB=1,KFLA
73473 DO 230 KFLC=1,KFLB
73474 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
73475 & GOTO 230
73476 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
73477 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
73478 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
73479 CALL PYNAME(KF,CHAP)
73480 CALL PYNAME(-KF,CHAN)
73481 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73482 230 CONTINUE
73483 240 CONTINUE
73484 250 CONTINUE
73485 260 CONTINUE
73486 DO 270 KC=1,500
73487 KF=KCHG(KC,4)
73488 IF(KF.LT.1000000) GOTO 270
73489 CALL PYNAME(KF,CHAP)
73490 CALL PYNAME(-KF,CHAN)
73491 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
73492 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
73493 270 CONTINUE
73494
73495C...List parton/particle data table. Check whether to be listed.
73496 ELSEIF(MLIST.EQ.12) THEN
73497 WRITE(MSTU(11),7700)
73498 DO 300 KC=1,MSTU(6)
73499 KF=KCHG(KC,4)
73500 IF(KF.EQ.0) GOTO 300
73501 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
73502 & GOTO 300
73503
73504C...Find particle name and mass. Print information.
73505 CALL PYNAME(KF,CHAP)
73506 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
73507 CALL PYNAME(-KF,CHAN)
73508 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
73509 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
73510
73511C...Particle decay: channel number, branching ratios, matrix element,
73512C...decay products.
73513 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73514 DO 280 J=1,5
73515 CALL PYNAME(KFDP(IDC,J),CHAD(J))
73516 280 CONTINUE
73517 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73518 & (CHAD(J),J=1,5)
73519 290 CONTINUE
73520 300 CONTINUE
73521
73522C...List parameter value table.
73523 ELSEIF(MLIST.EQ.13) THEN
73524 WRITE(MSTU(11),8000)
73525 DO 310 I=1,200
73526 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
73527 310 CONTINUE
73528 ENDIF
73529
73530C...Format statements for output on unit MSTU(11) (by default 6).
73531 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
73532 &5X,'KF orig p_x p_y p_z E m'/)
73533 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
73534 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73535 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
73536 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
73537 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
73538 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
73539 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
73540 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
73541 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
73542 & ,' C tag AC tag'/)
73543 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
73544 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
73545 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
73546 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
73547 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
73548 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
73549 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
73550 6200 FORMAT(66X,5(1X,F12.3))
73551 6300 FORMAT(1X,78('='))
73552 6400 FORMAT(1X,130('='))
73553 6500 FORMAT(1X,65('='))
73554 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
73555 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
73556 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
73557 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
73558 &5F13.5)
73559 7000 FORMAT(19X,'sum charge:',F6.2)
73560 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
73561 &//' I IST ID Mothers Daughters p_x p_y p_z',
73562 &' E m')
73563 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
73564 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
73565 &//' I IST ID Mothers Colours p_x p_y p_z',
73566 &' E m')
73567 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
73568 7500 FORMAT(///20X,'List of KF codes in program'/)
73569 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
73570 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
73571 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
73572 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
73573 &1X,'ME',3X,'Br.rat.',4X,'decay products')
73574 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
73575 &1X,1P,E13.5,3X,I2)
73576 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
73577 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
73578 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
73579 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
73580
73581 RETURN
73582 END
73583
73584C*********************************************************************
73585
73586C...PYLOGO
73587C...Writes a logo for the program.
73588
73589 SUBROUTINE PYLOGO
73590
73591C...Double precision and integer declarations.
73592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73593 IMPLICIT INTEGER(I-N)
73594 INTEGER PYK,PYCHGE,PYCOMP
73595C...Parameter for length of information block.
73596 PARAMETER (IREFER=21)
73597C...Commonblocks.
73598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73599 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
73600 SAVE /PYDAT1/,/PYPARS/
73601C...Local arrays and character variables.
73602 INTEGER IDATI(6)
73603 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
73604 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
73605
73606C...Data on months, logo, titles, and references.
73607 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
73608 &'Oct','Nov','Dec'/
73609 DATA (LOGO(J),J=1,19)/
73610 &' *......* ',
73611 &' *:::!!:::::::::::* ',
73612 &' *::::::!!::::::::::::::* ',
73613 &' *::::::::!!::::::::::::::::* ',
73614 &' *:::::::::!!:::::::::::::::::* ',
73615 &' *:::::::::!!:::::::::::::::::* ',
73616 &' *::::::::!!::::::::::::::::*! ',
73617 &' *::::::!!::::::::::::::* !! ',
73618 &' !! *:::!!:::::::::::* !! ',
73619 &' !! !* -><- * !! ',
73620 &' !! !! !! ',
73621 &' !! !! !! ',
73622 &' !! !! ',
73623 &' !! lh !! ',
73624 &' !! !! ',
73625 &' !! hh !! ',
73626 &' !! ll !! ',
73627 &' !! !! ',
73628 &' !! '/
73629 DATA (LOGO(J),J=20,38)/
73630 &'Welcome to the Lund Monte Carlo!',
73631 &' ',
73632 &'PPP Y Y TTTTT H H III A ',
73633 &'P P Y Y T H H I A A ',
73634 &'PPP Y T HHHHH I AAAAA',
73635 &'P Y T H H I A A',
73636 &'P Y T H H III A A',
73637 &' ',
73638 &'This is PYTHIA version x.xxx ',
73639 &'Last date of change: xx xxx 200x',
73640 &' ',
73641 &'Now is xx xxx 200x at xx:xx:xx ',
73642 &' ',
73643 &'Disclaimer: this program comes ',
73644 &'without any guarantees. Beware ',
73645 &'of errors and use common sense ',
73646 &'when interpreting results. ',
73647 &' ',
73648 &'Copyright T. Sjostrand (2008) '/
73649 DATA (REFER(J),J=1,14)/
73650 &'An archive of program versions and d',
73651 &'ocumentation is found on the web: ',
73652 &'http://www.thep.lu.se/~torbjorn/Pyth',
73653 &'ia.html ',
73654 &' ',
73655 &' ',
73656 &'When you cite this program, the offi',
73657 &'cial reference is to the 6.4 manual:',
73658 &'T. Sjostrand, S. Mrenna and P. Skand',
73659 &'s, JHEP05 (2006) 026 ',
73660 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
73661 &'-T) [hep-ph/0603175]. ',
73662 &' ',
73663 &' '/
73664 DATA (REFER(J),J=15,32)/
73665 &'Also remember that the program, to a',
73666 &' large extent, represents original ',
73667 &'physics research. Other publications',
73668 &' of special relevance to your ',
73669 &'studies may therefore deserve separa',
73670 &'te mention. ',
73671 &' ',
73672 &' ',
73673 &'Main author: Torbjorn Sjostrand; Dep',
73674 &'artment of Theoretical Physics, ',
73675 &' Lund University, Solvegatan 14A, S',
73676 &'-223 62 Lund, Sweden; ',
73677 &' phone: + 46 - 46 - 222 48 16; e-ma',
73678 &'il: torbjorn@thep.lu.se ',
73679 &'Author: Stephen Mrenna; Computing Di',
73680 &'vision, GDS Group, ',
73681 &' Fermi National Accelerator Laborat',
73682 &'ory, MS 234, Batavia, IL 60510, USA;'/
73683 DATA (REFER(J),J=33,2*IREFER)/
73684 &' phone: + 1 - 630 - 840 - 2556; e-m',
73685 &'ail: mrenna@fnal.gov ',
73686 &'Author: Peter Skands; Theoretical Ph',
73687 &'ysics Department, ',
73688 &' Fermi National Accelerator Laborat',
73689 &'ory, MS 106, Batavia, IL 60510, USA;',
73690 &' and CERN/PH, CH-1211 Geneva, Switz',
73691 &'erland; ',
73692 &' phone: + 41 - 22 - 767 24 59; e-ma',
73693 &'il: skands@fnal.gov '/
73694
73695C...Check that PYDATA linked.
73696 IF(MSTP(183)/10.NE.199.AND.MSTP(183)/10.NE.200) THEN
73697 WRITE(*,'(1X,A)')
73698 & 'Error: PYDATA has not been linked.'
73699 WRITE(*,'(1X,A)') 'Execution stopped!'
73700 CALL PYSTOP(8)
73701
73702C...Write current version number and current date+time.
73703 ELSE
73704 WRITE(VERS,'(I1)') MSTP(181)
73705 LOGO(28)(24:24)=VERS
73706 WRITE(SUBV,'(I3)') MSTP(182)
73707 LOGO(28)(26:28)=SUBV
73708 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
73709 WRITE(DATE,'(I2)') MSTP(185)
73710 LOGO(29)(22:23)=DATE
73711 LOGO(29)(25:27)=MONTH(MSTP(184))
73712 WRITE(YEAR,'(I4)') MSTP(183)
73713 LOGO(29)(29:32)=YEAR
73714 CALL PYTIME(IDATI)
73715 IF(IDATI(1).LE.0) THEN
73716 LOGO(31)=' '
73717 ELSE
73718 WRITE(DATE,'(I2)') IDATI(3)
73719 LOGO(31)(8:9)=DATE
73720 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
73721 WRITE(YEAR,'(I4)') IDATI(1)
73722 LOGO(31)(15:18)=YEAR
73723 WRITE(HOUR,'(I2)') IDATI(4)
73724 LOGO(31)(23:24)=HOUR
73725 WRITE(MINU,'(I2)') IDATI(5)
73726 LOGO(31)(26:27)=MINU
73727 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
73728 WRITE(SECO,'(I2)') IDATI(6)
73729 LOGO(31)(29:30)=SECO
73730 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
73731 ENDIF
73732 ENDIF
73733
73734C...Loop over lines in header. Define page feed and side borders.
73735 DO 100 ILIN=1,29+IREFER
73736 LINE=' '
73737 IF(ILIN.EQ.1) THEN
73738 LINE(1:1)='1'
73739 ELSE
73740 LINE(2:3)='**'
73741 LINE(78:79)='**'
73742 ENDIF
73743
73744C...Separator lines and logos.
73745 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
73746 LINE(4:77)='***********************************************'//
73747 & '***************************'
73748 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
73749 LINE(6:37)=LOGO(ILIN-5)
73750 LINE(44:75)=LOGO(ILIN+14)
73751 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
73752 LINE(5:40)=REFER(2*ILIN-51)
73753 LINE(41:76)=REFER(2*ILIN-50)
73754 ENDIF
73755
73756C...Write lines to appropriate unit.
73757 WRITE(MSTU(11),'(A79)') LINE
73758 100 CONTINUE
73759
73760 RETURN
73761 END
73762
73763C*********************************************************************
73764
73765C...PYUPDA
73766C...Facilitates the updating of particle and decay data
73767C...by allowing it to be done in an external file.
73768
73769 SUBROUTINE PYUPDA(MUPDA,LFN)
73770
73771C...Double precision and integer declarations.
73772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73773 IMPLICIT INTEGER(I-N)
73774 INTEGER PYK,PYCHGE,PYCOMP
73775C...Commonblocks.
73776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73777 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73778 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
73779 COMMON/PYDAT4/CHAF(500,2)
73780 CHARACTER CHAF*16
73781 COMMON/PYINT4/MWID(500),WIDS(500,5)
73782 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
73783C...Local arrays, character variables and data.
73784 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
73785 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
73786 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
73787 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
73788 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
73789 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
73790 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
73791
73792C...Write header if not yet done.
73793 IF(MSTU(12).NE.12345) CALL PYLIST(0)
73794
73795C...Write information on file for editing.
73796 IF(MUPDA.EQ.1) THEN
73797 DO 110 KC=1,500
73798 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73799 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73800 & MWID(KC),MDCY(KC,1)
73801 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73802 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
73803 & (KFDP(IDC,J),J=1,5)
73804 100 CONTINUE
73805 110 CONTINUE
73806
73807C...Read complete set of information from edited file or
73808C...read partial set of new or updated information from edited file.
73809 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
73810
73811C...Reset counters.
73812 KCC=100
73813 NDC=0
73814 CHKF=' '
73815 IF(MUPDA.EQ.2) THEN
73816 DO 120 I=1,MSTU(6)
73817 KCHG(I,4)=0
73818 120 CONTINUE
73819 ELSE
73820 DO 130 KC=1,MSTU(6)
73821 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
73822 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
73823 130 CONTINUE
73824 ENDIF
73825
73826C...Begin of loop: read new line; unknown whether particle or
73827C...decay data.
73828 140 READ(LFN,5200,END=190) CHINL
73829
73830C...Identify particle code and whether already defined (for MUPDA=3).
73831 IF(CHINL(2:10).NE.' ') THEN
73832 CHKF=CHINL(2:10)
73833 READ(CHKF,5300) KF
73834 IF(MUPDA.EQ.2) THEN
73835 IF(KF.LE.100) THEN
73836 KC=KF
73837 ELSE
73838 KCC=KCC+1
73839 KC=KCC
73840 ENDIF
73841 ELSE
73842 KCREP=0
73843 IF(KF.LE.100) THEN
73844 KCREP=KF
73845 ELSE
73846 DO 150 KCR=101,KCC
73847 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
73848 150 CONTINUE
73849 ENDIF
73850C...Remove duplicate old decay data.
73851 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
73852 IDCREP=MDCY(KCREP,2)
73853 NDCREP=MDCY(KCREP,3)
73854 DO 160 I=1,KCC
73855 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
73856 160 CONTINUE
73857 DO 180 I=IDCREP,NDC-NDCREP
73858 MDME(I,1)=MDME(I+NDCREP,1)
73859 MDME(I,2)=MDME(I+NDCREP,2)
73860 BRAT(I)=BRAT(I+NDCREP)
73861 DO 170 J=1,5
73862 KFDP(I,J)=KFDP(I+NDCREP,J)
73863 170 CONTINUE
73864 180 CONTINUE
73865 NDC=NDC-NDCREP
73866 KC=KCREP
73867 ELSEIF(KCREP.NE.0) THEN
73868 KC=KCREP
73869 ELSE
73870 KCC=KCC+1
73871 KC=KCC
73872 ENDIF
73873 ENDIF
73874
73875C...Study line with particle data.
73876 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
73877 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
73878 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
73879 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
73880 & MWID(KC),MDCY(KC,1)
73881 MDCY(KC,2)=0
73882 MDCY(KC,3)=0
73883
73884C...Study line with decay data.
73885 ELSE
73886 NDC=NDC+1
73887 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
73888 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
73889 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
73890 MDCY(KC,3)=MDCY(KC,3)+1
73891 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
73892 & (KFDP(NDC,J),J=1,5)
73893 ENDIF
73894
73895C...End of loop; ensure that PYCOMP tables are updated.
73896 GOTO 140
73897 190 CONTINUE
73898 MSTU(20)=0
73899
73900C...Perform possible tests that new information is consistent.
73901 DO 220 KC=1,MSTU(6)
73902 KF=KCHG(KC,4)
73903 IF(KF.EQ.0) GOTO 220
73904 WRITE(CHKF,5300) KF
73905 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
73906 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
73907 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
73908 BRSUM=0D0
73909 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
73910 IF(MDME(IDC,2).GT.80) GOTO 210
73911 KQ=KCHG(KC,1)
73912 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
73913 MERR=0
73914 DO 200 J=1,5
73915 KP=KFDP(IDC,J)
73916 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
73917 IF(KP.EQ.81) KQ=0
73918 ELSEIF(PYCOMP(KP).EQ.0) THEN
73919 MERR=3
73920 ELSE
73921 KQ=KQ-PYCHGE(KP)
73922 KPC=PYCOMP(KP)
73923 PMS=PMS-PMAS(KPC,1)
73924 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
73925 & PMAS(KPC,3))
73926 ENDIF
73927 200 CONTINUE
73928 IF(KQ.NE.0) MERR=MAX(2,MERR)
73929 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
73930 & MERR=MAX(1,MERR)
73931 IF(MERR.EQ.3) CALL PYERRM(17,
73932 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
73933 IF(MERR.EQ.2) CALL PYERRM(17,
73934 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
73935 IF(MERR.EQ.1) CALL PYERRM(7,
73936 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
73937 BRSUM=BRSUM+BRAT(IDC)
73938 210 CONTINUE
73939 WRITE(CHTMP,5500) BRSUM
73940 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
73941 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
73942 & CHTMP(9:16)//' for KF ='//CHKF)
73943 220 CONTINUE
73944
73945C...Write DATA statements for inclusion in program.
73946 ELSEIF(MUPDA.EQ.4) THEN
73947
73948C...Find out how many codes and decay channels are actually used.
73949 KCC=0
73950 NDC=0
73951 DO 230 I=1,MSTU(6)
73952 IF(KCHG(I,4).NE.0) THEN
73953 KCC=I
73954 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
73955 ENDIF
73956 230 CONTINUE
73957
73958C...Initialize writing of DATA statements for inclusion in program.
73959 DO 300 IVAR=1,22
73960 NDIM=MSTU(6)
73961 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
73962 NLIN=1
73963 CHLIN=' '
73964 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
73965 LLIN=35
73966 CHOLD='START'
73967
73968C...Loop through variables for conversion to characters.
73969 DO 280 IDIM=1,NDIM
73970 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
73971 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
73972 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
73973 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
73974 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
73975 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
73976 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
73977 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
73978 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
73979 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
73980 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
73981 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
73982 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
73983 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
73984 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
73985 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
73986 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
73987 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
73988 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
73989 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
73990 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
73991 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
73992
73993C...Replace variables beyond what is properly defined.
73994 IF(IVAR.LE.4) THEN
73995 IF(IDIM.GT.KCC) CHTMP=' 0'
73996 ELSEIF(IVAR.LE.8) THEN
73997 IF(IDIM.GT.KCC) CHTMP=' 0.0'
73998 ELSEIF(IVAR.LE.11) THEN
73999 IF(IDIM.GT.KCC) CHTMP=' 0'
74000 ELSEIF(IVAR.LE.13) THEN
74001 IF(IDIM.GT.NDC) CHTMP=' 0'
74002 ELSEIF(IVAR.LE.14) THEN
74003 IF(IDIM.GT.NDC) CHTMP=' 0.0'
74004 ELSEIF(IVAR.LE.19) THEN
74005 IF(IDIM.GT.NDC) CHTMP=' 0'
74006 ELSEIF(IVAR.LE.21) THEN
74007 IF(IDIM.GT.KCC) CHTMP=' '
74008 ELSE
74009 IF(IDIM.GT.KCC) CHTMP=' 0'
74010 ENDIF
74011
74012C...Length of variable, trailing decimal zeros, quotation marks.
74013 LLOW=1
74014 LHIG=1
74015 DO 240 LL=1,16
74016 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
74017 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
74018 240 CONTINUE
74019 CHNEW=CHTMP(LLOW:LHIG)//' '
74020 LNEW=1+LHIG-LLOW
74021 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
74022 LNEW=LNEW+1
74023 250 LNEW=LNEW-1
74024 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
74025 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
74026 IF(LNEW.EQ.0) THEN
74027 CHNEW(1:3)='0D0'
74028 LNEW=3
74029 ELSE
74030 CHNEW(LNEW+1:LNEW+2)='D0'
74031 LNEW=LNEW+2
74032 ENDIF
74033 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
74034 DO 260 LL=LNEW,1,-1
74035 IF(CHNEW(LL:LL).EQ.'''') THEN
74036 CHTMP=CHNEW
74037 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
74038 LNEW=LNEW+1
74039 ENDIF
74040 260 CONTINUE
74041 LNEW=MIN(14,LNEW)
74042 CHTMP=CHNEW
74043 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
74044 LNEW=LNEW+2
74045 ENDIF
74046
74047C...Form composite character string, often including repetition counter.
74048 IF(CHNEW.NE.CHOLD) THEN
74049 NRPT=1
74050 CHOLD=CHNEW
74051 CHCOM=CHNEW
74052 LCOM=LNEW
74053 ELSE
74054 LRPT=LNEW+1
74055 IF(NRPT.GE.2) LRPT=LNEW+3
74056 IF(NRPT.GE.10) LRPT=LNEW+4
74057 IF(NRPT.GE.100) LRPT=LNEW+5
74058 IF(NRPT.GE.1000) LRPT=LNEW+6
74059 LLIN=LLIN-LRPT
74060 NRPT=NRPT+1
74061 WRITE(CHTMP,5400) NRPT
74062 LRPT=1
74063 IF(NRPT.GE.10) LRPT=2
74064 IF(NRPT.GE.100) LRPT=3
74065 IF(NRPT.GE.1000) LRPT=4
74066 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
74067 LCOM=LRPT+1+LNEW
74068 ENDIF
74069
74070C...Add characters to end of line, to new line (after storing old line),
74071C...or to new block of lines (after writing old block).
74072 IF(LLIN+LCOM.LE.70) THEN
74073 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
74074 LLIN=LLIN+LCOM+1
74075 ELSEIF(NLIN.LE.19) THEN
74076 CHLIN(LLIN+1:72)=' '
74077 CHBLK(NLIN)=CHLIN
74078 NLIN=NLIN+1
74079 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
74080 LLIN=6+LCOM+1
74081 ELSE
74082 CHLIN(LLIN:72)='/'//' '
74083 CHBLK(NLIN)=CHLIN
74084 WRITE(CHTMP,5400) IDIM-NRPT
74085 CHBLK(1)(30:33)=CHTMP(13:16)
74086 DO 270 ILIN=1,NLIN
74087 WRITE(LFN,5700) CHBLK(ILIN)
74088 270 CONTINUE
74089 NLIN=1
74090 CHLIN=' '
74091 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
74092 & ',I= , )/'//CHCOM(1:LCOM)//','
74093 WRITE(CHTMP,5400) IDIM-NRPT+1
74094 CHLIN(25:28)=CHTMP(13:16)
74095 LLIN=35+LCOM+1
74096 ENDIF
74097 280 CONTINUE
74098
74099C...Write final block of lines.
74100 CHLIN(LLIN:72)='/'//' '
74101 CHBLK(NLIN)=CHLIN
74102 WRITE(CHTMP,5400) NDIM
74103 CHBLK(1)(30:33)=CHTMP(13:16)
74104 DO 290 ILIN=1,NLIN
74105 WRITE(LFN,5700) CHBLK(ILIN)
74106 290 CONTINUE
74107 300 CONTINUE
74108 ENDIF
74109
74110C...Formats for reading and writing particle data.
74111 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
74112 5100 FORMAT(10X,2I5,F12.6,5I10)
74113 5200 FORMAT(A120)
74114 5300 FORMAT(I9)
74115 5400 FORMAT(I16)
74116 5500 FORMAT(F16.5)
74117 5600 FORMAT(F16.6)
74118 5700 FORMAT(A72)
74119
74120 RETURN
74121 END
74122
74123C*********************************************************************
74124
74125C...PYK
74126C...Provides various integer-valued event related data.
74127
74128 FUNCTION PYK(I,J)
74129
74130C...Double precision and integer declarations.
74131 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74132 IMPLICIT INTEGER(I-N)
74133 INTEGER PYK,PYCHGE,PYCOMP
74134C...Commonblocks.
74135 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74138 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74139
74140C...Default value. For I=0 number of entries, number of stable entries
74141C...or 3 times total charge.
74142 PYK=0
74143 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74144 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
74145 PYK=N
74146 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
74147 DO 100 I1=1,N
74148 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
74149 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
74150 & PYCHGE(K(I1,2))
74151 100 CONTINUE
74152 ELSEIF(I.EQ.0) THEN
74153
74154C...For I > 0 direct readout of K matrix or charge.
74155 ELSEIF(J.LE.5) THEN
74156 PYK=K(I,J)
74157 ELSEIF(J.EQ.6) THEN
74158 PYK=PYCHGE(K(I,2))
74159
74160C...Status (existing/fragmented/decayed), parton/hadron separation.
74161 ELSEIF(J.LE.8) THEN
74162 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
74163 IF(J.EQ.8) PYK=PYK*K(I,2)
74164 ELSEIF(J.LE.12) THEN
74165 KFA=IABS(K(I,2))
74166 KC=PYCOMP(KFA)
74167 KQ=0
74168 IF(KC.NE.0) KQ=KCHG(KC,2)
74169 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
74170 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
74171 IF(J.EQ.11) PYK=KC
74172 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
74173
74174C...Heaviest flavour in hadron/diquark.
74175 ELSEIF(J.EQ.13) THEN
74176 KFA=IABS(K(I,2))
74177 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
74178 IF(KFA.LT.10) PYK=KFA
74179 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
74180 PYK=PYK*ISIGN(1,K(I,2))
74181
74182C...Particle history: generation, ancestor, rank.
74183 ELSEIF(J.LE.15) THEN
74184 I2=I
74185 I1=I
74186 110 PYK=PYK+1
74187 I2=I1
74188 I1=K(I1,3)
74189 IF(I1.GT.0) THEN
74190 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
74191 ENDIF
74192 IF(J.EQ.15) PYK=I2
74193 ELSEIF(J.EQ.16) THEN
74194 KFA=IABS(K(I,2))
74195 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
74196 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
74197 I1=I
74198 120 I2=I1
74199 I1=K(I1,3)
74200 IF(I1.GT.0) THEN
74201 KFAM=IABS(K(I1,2))
74202 ILP=1
74203 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
74204 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
74205 & ILP=0
74206 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
74207 IF(ILP.EQ.1) GOTO 120
74208 ENDIF
74209 IF(K(I1,1).EQ.12) THEN
74210 DO 130 I3=I1+1,I2
74211 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
74212 & .AND.K(I3,2).NE.93) PYK=PYK+1
74213 130 CONTINUE
74214 ELSE
74215 I3=I2
74216 140 PYK=PYK+1
74217 I3=I3+1
74218 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
74219 ENDIF
74220 ENDIF
74221
74222C...Particle coming from collapsing jet system or not.
74223 ELSEIF(J.EQ.17) THEN
74224 I1=I
74225 150 PYK=PYK+1
74226 I3=I1
74227 I1=K(I1,3)
74228 I0=MAX(1,I1)
74229 KC=PYCOMP(K(I0,2))
74230 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
74231 IF(PYK.EQ.1) PYK=-1
74232 IF(PYK.GT.1) PYK=0
74233 RETURN
74234 ENDIF
74235 IF(KCHG(KC,2).EQ.0) GOTO 150
74236 IF(K(I1,1).NE.12) PYK=0
74237 IF(K(I1,1).NE.12) RETURN
74238 I2=I1
74239 160 I2=I2+1
74240 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
74241 K3M=K(I3-1,3)
74242 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
74243 K3P=K(I3+1,3)
74244 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
74245
74246C...Number of decay products. Colour flow.
74247 ELSEIF(J.EQ.18) THEN
74248 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
74249 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
74250 ELSEIF(J.LE.22) THEN
74251 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
74252 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
74253 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
74254 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
74255 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
74256 ELSE
74257 ENDIF
74258
74259 RETURN
74260 END
74261
74262C*********************************************************************
74263
74264C...PYP
74265C...Provides various real-valued event related data.
74266
74267 FUNCTION PYP(I,J)
74268
74269C...Double precision and integer declarations.
74270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74271 IMPLICIT INTEGER(I-N)
74272 INTEGER PYK,PYCHGE,PYCOMP
74273C...Commonblocks.
74274 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74275 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74276 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74277 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74278C...Local array.
74279 DIMENSION PSUM(4)
74280
74281C...Set default value. For I = 0 sum of momenta or charges,
74282C...or invariant mass of system.
74283 PYP=0D0
74284 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
74285 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
74286 DO 100 I1=1,N
74287 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
74288 100 CONTINUE
74289 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
74290 DO 120 J1=1,4
74291 PSUM(J1)=0D0
74292 DO 110 I1=1,N
74293 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
74294 & P(I1,J1)
74295 110 CONTINUE
74296 120 CONTINUE
74297 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
74298 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
74299 DO 130 I1=1,N
74300 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
74301 130 CONTINUE
74302 ELSEIF(I.EQ.0) THEN
74303
74304C...Direct readout of P matrix.
74305 ELSEIF(J.LE.5) THEN
74306 PYP=P(I,J)
74307
74308C...Charge, total momentum, transverse momentum, transverse mass.
74309 ELSEIF(J.LE.12) THEN
74310 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
74311 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
74312 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
74313 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
74314 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
74315
74316C...Theta and phi angle in radians or degrees.
74317 ELSEIF(J.LE.16) THEN
74318 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
74319 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
74320 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
74321
74322C...True rapidity, rapidity with pion mass, pseudorapidity.
74323 ELSEIF(J.LE.19) THEN
74324 PMR=0D0
74325 IF(J.EQ.17) PMR=P(I,5)
74326 IF(J.EQ.18) PMR=PYMASS(211)
74327 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
74328 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
74329 & 1D20)),P(I,3))
74330
74331C...Energy and momentum fractions (only to be used in CM frame).
74332 ELSEIF(J.LE.25) THEN
74333 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
74334 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
74335 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
74336 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
74337 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
74338 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
74339 ENDIF
74340
74341 RETURN
74342 END
74343
74344C*********************************************************************
74345
74346C...PYSPHE
74347C...Performs sphericity tensor analysis to give sphericity,
74348C...aplanarity and the related event axes.
74349
74350 SUBROUTINE PYSPHE(SPH,APL)
74351
74352C...Double precision and integer declarations.
74353 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74354 IMPLICIT INTEGER(I-N)
74355 INTEGER PYK,PYCHGE,PYCOMP
74356C...Parameter statement to help give large particle numbers.
74357 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74358 &KEXCIT=4000000,KDIMEN=5000000)
74359C...Commonblocks.
74360 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74361 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74362 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74363 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74364C...Local arrays.
74365 DIMENSION SM(3,3),SV(3,3)
74366
74367C...Calculate matrix to be diagonalized.
74368 NP=0
74369 DO 110 J1=1,3
74370 DO 100 J2=J1,3
74371 SM(J1,J2)=0D0
74372 100 CONTINUE
74373 110 CONTINUE
74374 PS=0D0
74375 DO 140 I=1,N
74376 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74377 IF(MSTU(41).GE.2) THEN
74378 KC=PYCOMP(K(I,2))
74379 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74380 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74381 & K(I,2).EQ.KSUSY1+39) GOTO 140
74382 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74383 & GOTO 140
74384 ENDIF
74385 NP=NP+1
74386 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74387 PWT=1D0
74388 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
74389 & MAX(1D-10,PA)**(PARU(41)-2D0)
74390 DO 130 J1=1,3
74391 DO 120 J2=J1,3
74392 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
74393 120 CONTINUE
74394 130 CONTINUE
74395 PS=PS+PWT*PA**2
74396 140 CONTINUE
74397
74398C...Very low multiplicities (0 or 1) not considered.
74399 IF(NP.LE.1) THEN
74400 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
74401 SPH=-1D0
74402 APL=-1D0
74403 RETURN
74404 ENDIF
74405 DO 160 J1=1,3
74406 DO 150 J2=J1,3
74407 SM(J1,J2)=SM(J1,J2)/PS
74408 150 CONTINUE
74409 160 CONTINUE
74410
74411C...Find eigenvalues to matrix (third degree equation).
74412 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
74413 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
74414 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
74415 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
74416 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
74417 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
74418 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
74419 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
74420 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
74421 IF(P(N+2,4).LT.1D-5) THEN
74422 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
74423 SPH=-1D0
74424 APL=-1D0
74425 RETURN
74426 ENDIF
74427
74428C...Find first and last eigenvector by solving equation system.
74429 DO 240 I=1,3,2
74430 DO 180 J1=1,3
74431 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
74432 DO 170 J2=J1+1,3
74433 SV(J1,J2)=SM(J1,J2)
74434 SV(J2,J1)=SM(J1,J2)
74435 170 CONTINUE
74436 180 CONTINUE
74437 SMAX=0D0
74438 DO 200 J1=1,3
74439 DO 190 J2=1,3
74440 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
74441 JA=J1
74442 JB=J2
74443 SMAX=ABS(SV(J1,J2))
74444 190 CONTINUE
74445 200 CONTINUE
74446 SMAX=0D0
74447 DO 220 J3=JA+1,JA+2
74448 J1=J3-3*((J3-1)/3)
74449 RL=SV(J1,JB)/SV(JA,JB)
74450 DO 210 J2=1,3
74451 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
74452 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
74453 JC=J1
74454 SMAX=ABS(SV(J1,J2))
74455 210 CONTINUE
74456 220 CONTINUE
74457 JB1=JB+1-3*(JB/3)
74458 JB2=JB+2-3*((JB+1)/3)
74459 P(N+I,JB1)=-SV(JC,JB2)
74460 P(N+I,JB2)=SV(JC,JB1)
74461 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
74462 & SV(JA,JB)
74463 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
74464 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74465 DO 230 J=1,3
74466 P(N+I,J)=SGN*P(N+I,J)/PA
74467 230 CONTINUE
74468 240 CONTINUE
74469
74470C...Middle axis orthogonal to other two. Fill other codes.
74471 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74472 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
74473 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
74474 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
74475 DO 260 I=1,3
74476 K(N+I,1)=31
74477 K(N+I,2)=95
74478 K(N+I,3)=I
74479 K(N+I,4)=0
74480 K(N+I,5)=0
74481 P(N+I,5)=0D0
74482 DO 250 J=1,5
74483 V(I,J)=0D0
74484 250 CONTINUE
74485 260 CONTINUE
74486
74487C...Calculate sphericity and aplanarity. Select storing option.
74488 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
74489 APL=1.5D0*P(N+3,4)
74490 MSTU(61)=N+1
74491 MSTU(62)=NP
74492 IF(MSTU(43).LE.1) MSTU(3)=3
74493 IF(MSTU(43).GE.2) N=N+3
74494
74495 RETURN
74496 END
74497
74498C*********************************************************************
74499
74500C...PYTHRU
74501C...Performs thrust analysis to give thrust, oblateness
74502C...and the related event axes.
74503
74504 SUBROUTINE PYTHRU(THR,OBL)
74505
74506C...Double precision and integer declarations.
74507 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74508 IMPLICIT INTEGER(I-N)
74509 INTEGER PYK,PYCHGE,PYCOMP
74510C...Parameter statement to help give large particle numbers.
74511 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74512 &KEXCIT=4000000,KDIMEN=5000000)
74513C...Commonblocks.
74514 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74516 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74517 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74518C...Local arrays.
74519 DIMENSION TDI(3),TPR(3)
74520
74521C...Take copy of particles that are to be considered in thrust analysis.
74522 NP=0
74523 PS=0D0
74524 DO 100 I=1,N
74525 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
74526 IF(MSTU(41).GE.2) THEN
74527 KC=PYCOMP(K(I,2))
74528 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74529 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74530 & K(I,2).EQ.KSUSY1+39) GOTO 100
74531 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74532 & GOTO 100
74533 ENDIF
74534 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
74535 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
74536 THR=-2D0
74537 OBL=-2D0
74538 RETURN
74539 ENDIF
74540 NP=NP+1
74541 K(N+NP,1)=23
74542 P(N+NP,1)=P(I,1)
74543 P(N+NP,2)=P(I,2)
74544 P(N+NP,3)=P(I,3)
74545 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74546 P(N+NP,5)=1D0
74547 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
74548 & P(N+NP,4)**(PARU(42)-1D0)
74549 PS=PS+P(N+NP,4)*P(N+NP,5)
74550 100 CONTINUE
74551
74552C...Very low multiplicities (0 or 1) not considered.
74553 IF(NP.LE.1) THEN
74554 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
74555 THR=-1D0
74556 OBL=-1D0
74557 RETURN
74558 ENDIF
74559
74560C...Loop over thrust and major. T axis along z direction in latter case.
74561 DO 320 ILD=1,2
74562 IF(ILD.EQ.2) THEN
74563 K(N+NP+1,1)=31
74564 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
74565 MSTU(33)=1
74566 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
74567 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
74568 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
74569 ENDIF
74570
74571C...Find and order particles with highest p (pT for major).
74572 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
74573 P(ILF,4)=0D0
74574 110 CONTINUE
74575 DO 160 I=N+1,N+NP
74576 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
74577 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
74578 IF(P(I,4).LE.P(ILF,4)) GOTO 140
74579 DO 120 J=1,5
74580 P(ILF+1,J)=P(ILF,J)
74581 120 CONTINUE
74582 130 CONTINUE
74583 ILF=N+NP+3
74584 140 DO 150 J=1,5
74585 P(ILF+1,J)=P(I,J)
74586 150 CONTINUE
74587 160 CONTINUE
74588
74589C...Find and order initial axes with highest thrust (major).
74590 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
74591 P(ILG,4)=0D0
74592 170 CONTINUE
74593 NC=2**(MIN(MSTU(44),NP)-1)
74594 DO 250 ILC=1,NC
74595 DO 180 J=1,3
74596 TDI(J)=0D0
74597 180 CONTINUE
74598 DO 200 ILF=1,MIN(MSTU(44),NP)
74599 SGN=P(N+NP+ILF+3,5)
74600 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
74601 DO 190 J=1,4-ILD
74602 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
74603 190 CONTINUE
74604 200 CONTINUE
74605 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
74606 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
74607 IF(TDS.LE.P(ILG,4)) GOTO 230
74608 DO 210 J=1,4
74609 P(ILG+1,J)=P(ILG,J)
74610 210 CONTINUE
74611 220 CONTINUE
74612 ILG=N+NP+MSTU(44)+4
74613 230 DO 240 J=1,3
74614 P(ILG+1,J)=TDI(J)
74615 240 CONTINUE
74616 P(ILG+1,4)=TDS
74617 250 CONTINUE
74618
74619C...Iterate direction of axis until stable maximum.
74620 P(N+NP+ILD,4)=0D0
74621 ILG=0
74622 260 ILG=ILG+1
74623 THP=0D0
74624 270 THPS=THP
74625 DO 280 J=1,3
74626 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
74627 IF(THP.GT.1D-10) TDI(J)=TPR(J)
74628 TPR(J)=0D0
74629 280 CONTINUE
74630 DO 300 I=N+1,N+NP
74631 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
74632 DO 290 J=1,4-ILD
74633 TPR(J)=TPR(J)+SGN*P(I,J)
74634 290 CONTINUE
74635 300 CONTINUE
74636 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
74637 IF(THP.GE.THPS+PARU(48)) GOTO 270
74638
74639C...Save good axis. Try new initial axis until a number of tries agree.
74640 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
74641 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
74642 IAGR=0
74643 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74644 DO 310 J=1,3
74645 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
74646 310 CONTINUE
74647 P(N+NP+ILD,4)=THP
74648 P(N+NP+ILD,5)=0D0
74649 ENDIF
74650 IAGR=IAGR+1
74651 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
74652 320 CONTINUE
74653
74654C...Find minor axis and value by orthogonality.
74655 SGN=(-1D0)**INT(PYR(0)+0.5D0)
74656 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
74657 P(N+NP+3,2)=SGN*P(N+NP+2,1)
74658 P(N+NP+3,3)=0D0
74659 THP=0D0
74660 DO 330 I=N+1,N+NP
74661 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
74662 330 CONTINUE
74663 P(N+NP+3,4)=THP/PS
74664 P(N+NP+3,5)=0D0
74665
74666C...Fill axis information. Rotate back to original coordinate system.
74667 DO 350 ILD=1,3
74668 K(N+ILD,1)=31
74669 K(N+ILD,2)=96
74670 K(N+ILD,3)=ILD
74671 K(N+ILD,4)=0
74672 K(N+ILD,5)=0
74673 DO 340 J=1,5
74674 P(N+ILD,J)=P(N+NP+ILD,J)
74675 V(N+ILD,J)=0D0
74676 340 CONTINUE
74677 350 CONTINUE
74678 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
74679
74680C...Calculate thrust and oblateness. Select storing option.
74681 THR=P(N+1,4)
74682 OBL=P(N+2,4)-P(N+3,4)
74683 MSTU(61)=N+1
74684 MSTU(62)=NP
74685 IF(MSTU(43).LE.1) MSTU(3)=3
74686 IF(MSTU(43).GE.2) N=N+3
74687
74688 RETURN
74689 END
74690
74691C*********************************************************************
74692
74693C...PYCLUS
74694C...Subdivides the particle content of an event into jets/clusters.
74695
74696 SUBROUTINE PYCLUS(NJET)
74697
74698C...Double precision and integer declarations.
74699 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74700 IMPLICIT INTEGER(I-N)
74701 INTEGER PYK,PYCHGE,PYCOMP
74702C...Parameter statement to help give large particle numbers.
74703 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74704 &KEXCIT=4000000,KDIMEN=5000000)
74705C...Commonblocks.
74706 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74707 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74708 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74709 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
74710C...Local arrays and saved variables.
74711 DIMENSION PS(5)
74712 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
74713
74714C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
74715 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
74716 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
74717 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
74718 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74719 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
74720 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
74721
74722C...If first time, reset. If reentering, skip preliminaries.
74723 IF(MSTU(48).LE.0) THEN
74724 NP=0
74725 DO 100 J=1,5
74726 PS(J)=0D0
74727 100 CONTINUE
74728 PSS=0D0
74729 PIMASS=PMAS(PYCOMP(211),1)
74730 ELSE
74731 NJET=NSAV
74732 IF(MSTU(43).GE.2) N=N-NJET
74733 DO 110 I=N+1,N+NJET
74734 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74735 110 CONTINUE
74736 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74737 R2ACC=PARU(44)**2
74738 ELSE
74739 R2ACC=PARU(45)*PS(5)**2
74740 ENDIF
74741 NLOOP=0
74742 GOTO 300
74743 ENDIF
74744
74745C...Find which particles are to be considered in cluster search.
74746 DO 140 I=1,N
74747 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
74748 IF(MSTU(41).GE.2) THEN
74749 KC=PYCOMP(K(I,2))
74750 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74751 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74752 & K(I,2).EQ.KSUSY1+39) GOTO 140
74753 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
74754 & GOTO 140
74755 ENDIF
74756 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
74757 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
74758 NJET=-1
74759 RETURN
74760 ENDIF
74761
74762C...Take copy of these particles, with space left for jets later on.
74763 NP=NP+1
74764 K(N+NP,3)=I
74765 DO 120 J=1,5
74766 P(N+NP,J)=P(I,J)
74767 120 CONTINUE
74768 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
74769 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
74770 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74771 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74772 DO 130 J=1,4
74773 PS(J)=PS(J)+P(N+NP,J)
74774 130 CONTINUE
74775 PSS=PSS+P(N+NP,5)
74776 140 CONTINUE
74777 DO 160 I=N+1,N+NP
74778 K(I+NP,3)=K(I,3)
74779 DO 150 J=1,5
74780 P(I+NP,J)=P(I,J)
74781 150 CONTINUE
74782 160 CONTINUE
74783 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
74784
74785C...Very low multiplicities not considered.
74786 IF(NP.LT.MSTU(47)) THEN
74787 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
74788 NJET=-1
74789 RETURN
74790 ENDIF
74791
74792C...Find precluster configuration. If too few jets, make harder cuts.
74793 NLOOP=0
74794 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
74795 R2ACC=PARU(44)**2
74796 ELSE
74797 R2ACC=PARU(45)*PS(5)**2
74798 ENDIF
74799 RINIT=1.25D0*PARU(43)
74800 IF(NP.LE.MSTU(47)+2) RINIT=0D0
74801 170 RINIT=0.8D0*RINIT
74802 NPRE=0
74803 NREM=NP
74804 DO 180 I=N+NP+1,N+2*NP
74805 K(I,4)=0
74806 180 CONTINUE
74807
74808C...Sum up small momentum region. Jet if enough absolute momentum.
74809 IF(MSTU(46).LE.2) THEN
74810 DO 190 J=1,4
74811 P(N+1,J)=0D0
74812 190 CONTINUE
74813 DO 210 I=N+NP+1,N+2*NP
74814 IF(P(I,5).GT.2D0*RINIT) GOTO 210
74815 NREM=NREM-1
74816 K(I,4)=1
74817 DO 200 J=1,4
74818 P(N+1,J)=P(N+1,J)+P(I,J)
74819 200 CONTINUE
74820 210 CONTINUE
74821 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
74822 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
74823 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74824 IF(NREM.EQ.0) GOTO 170
74825 ENDIF
74826
74827C...Find fastest remaining particle.
74828 220 NPRE=NPRE+1
74829 PMAX=0D0
74830 DO 230 I=N+NP+1,N+2*NP
74831 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
74832 IMAX=I
74833 PMAX=P(I,5)
74834 230 CONTINUE
74835 DO 240 J=1,5
74836 P(N+NPRE,J)=P(IMAX,J)
74837 240 CONTINUE
74838 NREM=NREM-1
74839 K(IMAX,4)=NPRE
74840
74841C...Sum up precluster around it according to pT separation.
74842 IF(MSTU(46).LE.2) THEN
74843 DO 260 I=N+NP+1,N+2*NP
74844 IF(K(I,4).NE.0) GOTO 260
74845 R2=R2T(I,IMAX)
74846 IF(R2.GT.RINIT**2) GOTO 260
74847 NREM=NREM-1
74848 K(I,4)=NPRE
74849 DO 250 J=1,4
74850 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
74851 250 CONTINUE
74852 260 CONTINUE
74853 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74854
74855C...Sum up precluster around it according to mass or
74856C...Durham pT separation.
74857 ELSE
74858 270 IMIN=0
74859 R2MIN=RINIT**2
74860 DO 280 I=N+NP+1,N+2*NP
74861 IF(K(I,4).NE.0) GOTO 280
74862 IF(MSTU(46).LE.4) THEN
74863 R2=R2M(I,N+NPRE)
74864 ELSE
74865 R2=R2D(I,N+NPRE)
74866 ENDIF
74867 IF(R2.GE.R2MIN) GOTO 280
74868 IMIN=I
74869 R2MIN=R2
74870 280 CONTINUE
74871 IF(IMIN.NE.0) THEN
74872 DO 290 J=1,4
74873 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
74874 290 CONTINUE
74875 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
74876 NREM=NREM-1
74877 K(IMIN,4)=NPRE
74878 GOTO 270
74879 ENDIF
74880 ENDIF
74881
74882C...Check if more preclusters to be found. Start over if too few.
74883 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
74884 IF(NREM.GT.0) GOTO 220
74885 NJET=NPRE
74886
74887C...Reassign all particles to nearest jet. Sum up new jet momenta.
74888 300 TSAV=0D0
74889 PSJT=0D0
74890 310 IF(MSTU(46).LE.1) THEN
74891 DO 330 I=N+1,N+NJET
74892 DO 320 J=1,4
74893 V(I,J)=0D0
74894 320 CONTINUE
74895 330 CONTINUE
74896 DO 360 I=N+NP+1,N+2*NP
74897 R2MIN=PSS**2
74898 DO 340 IJET=N+1,N+NJET
74899 IF(P(IJET,5).LT.RINIT) GOTO 340
74900 R2=R2T(I,IJET)
74901 IF(R2.GE.R2MIN) GOTO 340
74902 IMIN=IJET
74903 R2MIN=R2
74904 340 CONTINUE
74905 K(I,4)=IMIN-N
74906 DO 350 J=1,4
74907 V(IMIN,J)=V(IMIN,J)+P(I,J)
74908 350 CONTINUE
74909 360 CONTINUE
74910 PSJT=0D0
74911 DO 380 I=N+1,N+NJET
74912 DO 370 J=1,4
74913 P(I,J)=V(I,J)
74914 370 CONTINUE
74915 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
74916 PSJT=PSJT+P(I,5)
74917 380 CONTINUE
74918 ENDIF
74919
74920C...Find two closest jets.
74921 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
74922 DO 400 ITRY1=N+1,N+NJET-1
74923 DO 390 ITRY2=ITRY1+1,N+NJET
74924 IF(MSTU(46).LE.2) THEN
74925 R2=R2T(ITRY1,ITRY2)
74926 ELSEIF(MSTU(46).LE.4) THEN
74927 R2=R2M(ITRY1,ITRY2)
74928 ELSE
74929 R2=R2D(ITRY1,ITRY2)
74930 ENDIF
74931 IF(R2.GE.R2MIN) GOTO 390
74932 IMIN1=ITRY1
74933 IMIN2=ITRY2
74934 R2MIN=R2
74935 390 CONTINUE
74936 400 CONTINUE
74937
74938C...If allowed, join two closest jets and start over.
74939 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
74940 IREC=MIN(IMIN1,IMIN2)
74941 IDEL=MAX(IMIN1,IMIN2)
74942 DO 410 J=1,4
74943 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
74944 410 CONTINUE
74945 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
74946 DO 430 I=IDEL+1,N+NJET
74947 DO 420 J=1,5
74948 P(I-1,J)=P(I,J)
74949 420 CONTINUE
74950 430 CONTINUE
74951 IF(MSTU(46).GE.2) THEN
74952 DO 440 I=N+NP+1,N+2*NP
74953 IORI=N+K(I,4)
74954 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
74955 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
74956 440 CONTINUE
74957 ENDIF
74958 NJET=NJET-1
74959 GOTO 300
74960
74961C...Divide up broad jet if empty cluster in list of final ones.
74962 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
74963 DO 450 I=N+1,N+NJET
74964 K(I,5)=0
74965 450 CONTINUE
74966 DO 460 I=N+NP+1,N+2*NP
74967 K(N+K(I,4),5)=K(N+K(I,4),5)+1
74968 460 CONTINUE
74969 IEMP=0
74970 DO 470 I=N+1,N+NJET
74971 IF(K(I,5).EQ.0) IEMP=I
74972 470 CONTINUE
74973 IF(IEMP.NE.0) THEN
74974 NLOOP=NLOOP+1
74975 ISPL=0
74976 R2MAX=0D0
74977 DO 480 I=N+NP+1,N+2*NP
74978 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
74979 IJET=N+K(I,4)
74980 R2=R2T(I,IJET)
74981 IF(R2.LE.R2MAX) GOTO 480
74982 ISPL=I
74983 R2MAX=R2
74984 480 CONTINUE
74985 IF(ISPL.NE.0) THEN
74986 IJET=N+K(ISPL,4)
74987 DO 490 J=1,4
74988 P(IEMP,J)=P(ISPL,J)
74989 P(IJET,J)=P(IJET,J)-P(ISPL,J)
74990 490 CONTINUE
74991 P(IEMP,5)=P(ISPL,5)
74992 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
74993 IF(NLOOP.LE.2) GOTO 300
74994 ENDIF
74995 ENDIF
74996 ENDIF
74997
74998C...If generalized thrust has not yet converged, continue iteration.
74999 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
75000 &THEN
75001 TSAV=PSJT/PSS
75002 GOTO 310
75003 ENDIF
75004
75005C...Reorder jets according to energy.
75006 DO 510 I=N+1,N+NJET
75007 DO 500 J=1,5
75008 V(I,J)=P(I,J)
75009 500 CONTINUE
75010 510 CONTINUE
75011 DO 540 INEW=N+1,N+NJET
75012 PEMAX=0D0
75013 DO 520 ITRY=N+1,N+NJET
75014 IF(V(ITRY,4).LE.PEMAX) GOTO 520
75015 IMAX=ITRY
75016 PEMAX=V(ITRY,4)
75017 520 CONTINUE
75018 K(INEW,1)=31
75019 K(INEW,2)=97
75020 K(INEW,3)=INEW-N
75021 K(INEW,4)=0
75022 DO 530 J=1,5
75023 P(INEW,J)=V(IMAX,J)
75024 530 CONTINUE
75025 V(IMAX,4)=-1D0
75026 K(IMAX,5)=INEW
75027 540 CONTINUE
75028
75029C...Clean up particle-jet assignments and jet information.
75030 DO 550 I=N+NP+1,N+2*NP
75031 IORI=K(N+K(I,4),5)
75032 K(I,4)=IORI-N
75033 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
75034 K(IORI,4)=K(IORI,4)+1
75035 550 CONTINUE
75036 IEMP=0
75037 PSJT=0D0
75038 DO 570 I=N+1,N+NJET
75039 K(I,5)=0
75040 PSJT=PSJT+P(I,5)
75041 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
75042 DO 560 J=1,5
75043 V(I,J)=0D0
75044 560 CONTINUE
75045 IF(K(I,4).EQ.0) IEMP=I
75046 570 CONTINUE
75047
75048C...Select storing option. Output variables. Check for failure.
75049 MSTU(61)=N+1
75050 MSTU(62)=NP
75051 MSTU(63)=NPRE
75052 PARU(61)=PS(5)
75053 PARU(62)=PSJT/PSS
75054 PARU(63)=SQRT(R2MIN)
75055 IF(NJET.LE.1) PARU(63)=0D0
75056 IF(IEMP.NE.0) THEN
75057 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
75058 NJET=-1
75059 RETURN
75060 ENDIF
75061 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75062 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75063 NSAV=NJET
75064
75065 RETURN
75066 END
75067
75068C*********************************************************************
75069
75070C...PYCELL
75071C...Provides a simple way of jet finding in eta-phi-ET coordinates,
75072C...as used for calorimeters at hadron colliders.
75073
75074 SUBROUTINE PYCELL(NJET)
75075
75076C...Double precision and integer declarations.
75077 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75078 IMPLICIT INTEGER(I-N)
75079 INTEGER PYK,PYCHGE,PYCOMP
75080C...Parameter statement to help give large particle numbers.
75081 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75082 &KEXCIT=4000000,KDIMEN=5000000)
75083C...Commonblocks.
75084 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75085 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75086 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75087 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75088
75089C...Loop over all particles. Find cell that was hit by given particle.
75090 PTLRAT=1D0/SINH(PARU(51))**2
75091 NP=0
75092 NC=N
75093 DO 110 I=1,N
75094 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75095 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
75096 IF(MSTU(41).GE.2) THEN
75097 KC=PYCOMP(K(I,2))
75098 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75099 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75100 & K(I,2).EQ.KSUSY1+39) GOTO 110
75101 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75102 & GOTO 110
75103 ENDIF
75104 NP=NP+1
75105 PT=SQRT(P(I,1)**2+P(I,2)**2)
75106 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
75107 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
75108 & (ETA/PARU(51)+1D0))))
75109 PHI=PYANGL(P(I,1),P(I,2))
75110 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
75111 & (PHI/PARU(1)+1D0))))
75112 IETPH=MSTU(52)*IETA+IPHI
75113
75114C...Add to cell already hit, or book new cell.
75115 DO 100 IC=N+1,NC
75116 IF(IETPH.EQ.K(IC,3)) THEN
75117 K(IC,4)=K(IC,4)+1
75118 P(IC,5)=P(IC,5)+PT
75119 GOTO 110
75120 ENDIF
75121 100 CONTINUE
75122 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
75123 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75124 NJET=-2
75125 RETURN
75126 ENDIF
75127 NC=NC+1
75128 K(NC,3)=IETPH
75129 K(NC,4)=1
75130 K(NC,5)=2
75131 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
75132 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
75133 P(NC,5)=PT
75134 110 CONTINUE
75135
75136C...Smear true bin content by calorimeter resolution.
75137 IF(MSTU(53).GE.1) THEN
75138 DO 130 IC=N+1,NC
75139 PEI=P(IC,5)
75140 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
75141 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
75142 & COS(PARU(2)*PYR(0))
75143 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
75144 P(IC,5)=PEF
75145 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
75146 130 CONTINUE
75147 ENDIF
75148
75149C...Remove cells below threshold.
75150 IF(PARU(58).GT.0D0) THEN
75151 NCC=NC
75152 NC=N
75153 DO 140 IC=N+1,NCC
75154 IF(P(IC,5).GT.PARU(58)) THEN
75155 NC=NC+1
75156 K(NC,3)=K(IC,3)
75157 K(NC,4)=K(IC,4)
75158 K(NC,5)=K(IC,5)
75159 P(NC,1)=P(IC,1)
75160 P(NC,2)=P(IC,2)
75161 P(NC,5)=P(IC,5)
75162 ENDIF
75163 140 CONTINUE
75164 ENDIF
75165
75166C...Find initiator cell: the one with highest pT of not yet used ones.
75167 NJ=NC
75168 150 ETMAX=0D0
75169 DO 160 IC=N+1,NC
75170 IF(K(IC,5).NE.2) GOTO 160
75171 IF(P(IC,5).LE.ETMAX) GOTO 160
75172 ICMAX=IC
75173 ETA=P(IC,1)
75174 PHI=P(IC,2)
75175 ETMAX=P(IC,5)
75176 160 CONTINUE
75177 IF(ETMAX.LT.PARU(52)) GOTO 220
75178 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
75179 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
75180 NJET=-2
75181 RETURN
75182 ENDIF
75183 K(ICMAX,5)=1
75184 NJ=NJ+1
75185 K(NJ,4)=0
75186 K(NJ,5)=1
75187 P(NJ,1)=ETA
75188 P(NJ,2)=PHI
75189 P(NJ,3)=0D0
75190 P(NJ,4)=0D0
75191 P(NJ,5)=0D0
75192
75193C...Sum up unused cells within required distance of initiator.
75194 DO 170 IC=N+1,NC
75195 IF(K(IC,5).EQ.0) GOTO 170
75196 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
75197 DPHIA=ABS(P(IC,2)-PHI)
75198 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
75199 PHIC=P(IC,2)
75200 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
75201 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
75202 K(IC,5)=-K(IC,5)
75203 K(NJ,4)=K(NJ,4)+K(IC,4)
75204 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
75205 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
75206 P(NJ,5)=P(NJ,5)+P(IC,5)
75207 170 CONTINUE
75208
75209C...Reject cluster below minimum ET, else accept.
75210 IF(P(NJ,5).LT.PARU(53)) THEN
75211 NJ=NJ-1
75212 DO 180 IC=N+1,NC
75213 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
75214 180 CONTINUE
75215 ELSEIF(MSTU(54).LE.2) THEN
75216 P(NJ,3)=P(NJ,3)/P(NJ,5)
75217 P(NJ,4)=P(NJ,4)/P(NJ,5)
75218 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
75219 & P(NJ,4))
75220 DO 190 IC=N+1,NC
75221 IF(K(IC,5).LT.0) K(IC,5)=0
75222 190 CONTINUE
75223 ELSE
75224 DO 200 J=1,4
75225 P(NJ,J)=0D0
75226 200 CONTINUE
75227 DO 210 IC=N+1,NC
75228 IF(K(IC,5).GE.0) GOTO 210
75229 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
75230 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
75231 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
75232 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
75233 K(IC,5)=0
75234 210 CONTINUE
75235 ENDIF
75236 GOTO 150
75237
75238C...Arrange clusters in falling ET sequence.
75239 220 DO 250 I=1,NJ-NC
75240 ETMAX=0D0
75241 DO 230 IJ=NC+1,NJ
75242 IF(K(IJ,5).EQ.0) GOTO 230
75243 IF(P(IJ,5).LT.ETMAX) GOTO 230
75244 IJMAX=IJ
75245 ETMAX=P(IJ,5)
75246 230 CONTINUE
75247 K(IJMAX,5)=0
75248 K(N+I,1)=31
75249 K(N+I,2)=98
75250 K(N+I,3)=I
75251 K(N+I,4)=K(IJMAX,4)
75252 K(N+I,5)=0
75253 DO 240 J=1,5
75254 P(N+I,J)=P(IJMAX,J)
75255 V(N+I,J)=0D0
75256 240 CONTINUE
75257 250 CONTINUE
75258 NJET=NJ-NC
75259
75260C...Convert to massless or massive four-vectors.
75261 IF(MSTU(54).EQ.2) THEN
75262 DO 260 I=N+1,N+NJET
75263 ETA=P(I,3)
75264 P(I,1)=P(I,5)*COS(P(I,4))
75265 P(I,2)=P(I,5)*SIN(P(I,4))
75266 P(I,3)=P(I,5)*SINH(ETA)
75267 P(I,4)=P(I,5)*COSH(ETA)
75268 P(I,5)=0D0
75269 260 CONTINUE
75270 ELSEIF(MSTU(54).GE.3) THEN
75271 DO 270 I=N+1,N+NJET
75272 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
75273 270 CONTINUE
75274 ENDIF
75275
75276C...Information about storage.
75277 MSTU(61)=N+1
75278 MSTU(62)=NP
75279 MSTU(63)=NC-N
75280 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
75281 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
75282
75283 RETURN
75284 END
75285
75286C*********************************************************************
75287
75288C...PYJMAS
75289C...Determines, approximately, the two jet masses that minimize
75290C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
75291
75292 SUBROUTINE PYJMAS(PMH,PML)
75293
75294C...Double precision and integer declarations.
75295 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75296 IMPLICIT INTEGER(I-N)
75297 INTEGER PYK,PYCHGE,PYCOMP
75298C...Parameter statement to help give large particle numbers.
75299 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75300 &KEXCIT=4000000,KDIMEN=5000000)
75301C...Commonblocks.
75302 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75303 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75304 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75305 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75306C...Local arrays.
75307 DIMENSION SM(3,3),SAX(3),PS(3,5)
75308
75309C...Reset.
75310 NP=0
75311 DO 120 J1=1,3
75312 DO 100 J2=J1,3
75313 SM(J1,J2)=0D0
75314 100 CONTINUE
75315 DO 110 J2=1,4
75316 PS(J1,J2)=0D0
75317 110 CONTINUE
75318 120 CONTINUE
75319 PSS=0D0
75320 PIMASS=PMAS(PYCOMP(211),1)
75321
75322C...Take copy of particles that are to be considered in mass analysis.
75323 DO 170 I=1,N
75324 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
75325 IF(MSTU(41).GE.2) THEN
75326 KC=PYCOMP(K(I,2))
75327 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75328 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75329 & K(I,2).EQ.KSUSY1+39) GOTO 170
75330 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75331 & GOTO 170
75332 ENDIF
75333 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
75334 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
75335 PMH=-2D0
75336 PML=-2D0
75337 RETURN
75338 ENDIF
75339 NP=NP+1
75340 DO 130 J=1,5
75341 P(N+NP,J)=P(I,J)
75342 130 CONTINUE
75343 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
75344 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
75345 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
75346
75347C...Fill information in sphericity tensor and total momentum vector.
75348 DO 150 J1=1,3
75349 DO 140 J2=J1,3
75350 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
75351 140 CONTINUE
75352 150 CONTINUE
75353 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75354 DO 160 J=1,4
75355 PS(3,J)=PS(3,J)+P(N+NP,J)
75356 160 CONTINUE
75357 170 CONTINUE
75358
75359C...Very low multiplicities (0 or 1) not considered.
75360 IF(NP.LE.1) THEN
75361 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
75362 PMH=-1D0
75363 PML=-1D0
75364 RETURN
75365 ENDIF
75366 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
75367 &PS(3,3)**2))
75368
75369C...Find largest eigenvalue to matrix (third degree equation).
75370 DO 190 J1=1,3
75371 DO 180 J2=J1,3
75372 SM(J1,J2)=SM(J1,J2)/PSS
75373 180 CONTINUE
75374 190 CONTINUE
75375 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
75376 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
75377 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
75378 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
75379 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
75380 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
75381 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
75382
75383C...Find largest eigenvector by solving equation system.
75384 DO 210 J1=1,3
75385 SM(J1,J1)=SM(J1,J1)-SMA
75386 DO 200 J2=J1+1,3
75387 SM(J2,J1)=SM(J1,J2)
75388 200 CONTINUE
75389 210 CONTINUE
75390 SMAX=0D0
75391 DO 230 J1=1,3
75392 DO 220 J2=1,3
75393 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
75394 JA=J1
75395 JB=J2
75396 SMAX=ABS(SM(J1,J2))
75397 220 CONTINUE
75398 230 CONTINUE
75399 SMAX=0D0
75400 DO 250 J3=JA+1,JA+2
75401 J1=J3-3*((J3-1)/3)
75402 RL=SM(J1,JB)/SM(JA,JB)
75403 DO 240 J2=1,3
75404 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
75405 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
75406 JC=J1
75407 SMAX=ABS(SM(J1,J2))
75408 240 CONTINUE
75409 250 CONTINUE
75410 JB1=JB+1-3*(JB/3)
75411 JB2=JB+2-3*((JB+1)/3)
75412 SAX(JB1)=-SM(JC,JB2)
75413 SAX(JB2)=SM(JC,JB1)
75414 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
75415
75416C...Divide particles into two initial clusters by hemisphere.
75417 DO 270 I=N+1,N+NP
75418 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
75419 IS=1
75420 IF(PSAX.LT.0D0) IS=2
75421 K(I,3)=IS
75422 DO 260 J=1,4
75423 PS(IS,J)=PS(IS,J)+P(I,J)
75424 260 CONTINUE
75425 270 CONTINUE
75426 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
75427 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
75428
75429C...Reassign one particle at a time; find maximum decrease of m^2 sum.
75430 280 PMD=0D0
75431 IM=0
75432 DO 290 J=1,4
75433 PS(3,J)=PS(1,J)-PS(2,J)
75434 290 CONTINUE
75435 DO 300 I=N+1,N+NP
75436 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)
75437 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
75438 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
75439 IF(PMDI.LT.PMD) THEN
75440 PMD=PMDI
75441 IM=I
75442 ENDIF
75443 300 CONTINUE
75444
75445C...Loop back if significant reduction in sum of m^2.
75446 IF(PMD.LT.-PARU(48)*PMS) THEN
75447 PMS=PMS+PMD
75448 IS=K(IM,3)
75449 DO 310 J=1,4
75450 PS(IS,J)=PS(IS,J)-P(IM,J)
75451 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
75452 310 CONTINUE
75453 K(IM,3)=3-IS
75454 GOTO 280
75455 ENDIF
75456
75457C...Final masses and output.
75458 MSTU(61)=N+1
75459 MSTU(62)=NP
75460 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
75461 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
75462 PMH=MAX(PS(1,5),PS(2,5))
75463 PML=MIN(PS(1,5),PS(2,5))
75464
75465 RETURN
75466 END
75467
75468C*********************************************************************
75469
75470C...PYFOWO
75471C...Calculates the first few Fox-Wolfram moments.
75472
75473 SUBROUTINE PYFOWO(H10,H20,H30,H40)
75474
75475C...Double precision and integer declarations.
75476 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75477 IMPLICIT INTEGER(I-N)
75478 INTEGER PYK,PYCHGE,PYCOMP
75479C...Parameter statement to help give large particle numbers.
75480 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75481 &KEXCIT=4000000,KDIMEN=5000000)
75482C...Commonblocks.
75483 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75484 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75485 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75486 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75487
75488C...Copy momenta for particles and calculate H0.
75489 NP=0
75490 H0=0D0
75491 HD=0D0
75492 DO 110 I=1,N
75493 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
75494 IF(MSTU(41).GE.2) THEN
75495 KC=PYCOMP(K(I,2))
75496 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75497 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75498 & K(I,2).EQ.KSUSY1+39) GOTO 110
75499 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
75500 & GOTO 110
75501 ENDIF
75502 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
75503 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
75504 H10=-1D0
75505 H20=-1D0
75506 H30=-1D0
75507 H40=-1D0
75508 RETURN
75509 ENDIF
75510 NP=NP+1
75511 DO 100 J=1,3
75512 P(N+NP,J)=P(I,J)
75513 100 CONTINUE
75514 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
75515 H0=H0+P(N+NP,4)
75516 HD=HD+P(N+NP,4)**2
75517 110 CONTINUE
75518 H0=H0**2
75519
75520C...Very low multiplicities (0 or 1) not considered.
75521 IF(NP.LE.1) THEN
75522 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
75523 H10=-1D0
75524 H20=-1D0
75525 H30=-1D0
75526 H40=-1D0
75527 RETURN
75528 ENDIF
75529
75530C...Calculate H1 - H4.
75531 H10=0D0
75532 H20=0D0
75533 H30=0D0
75534 H40=0D0
75535 DO 130 I1=N+1,N+NP
75536 DO 120 I2=I1+1,N+NP
75537 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
75538 & (P(I1,4)*P(I2,4))
75539 H10=H10+P(I1,4)*P(I2,4)*CTHE
75540 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
75541 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
75542 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
75543 & 0.375D0)
75544 120 CONTINUE
75545 130 CONTINUE
75546
75547C...Calculate H1/H0 - H4/H0. Output.
75548 MSTU(61)=N+1
75549 MSTU(62)=NP
75550 H10=(HD+2D0*H10)/H0
75551 H20=(HD+2D0*H20)/H0
75552 H30=(HD+2D0*H30)/H0
75553 H40=(HD+2D0*H40)/H0
75554
75555 RETURN
75556 END
75557
75558C*********************************************************************
75559
75560C...PYTABU
75561C...Evaluates various properties of an event, with statistics
75562C...accumulated during the course of the run and
75563C...printed at the end.
75564
75565 SUBROUTINE PYTABU(MTABU)
75566
75567C...Double precision and integer declarations.
75568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75569 IMPLICIT INTEGER(I-N)
75570 INTEGER PYK,PYCHGE,PYCOMP
75571C...Parameter statement to help give large particle numbers.
75572 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
75573 &KEXCIT=4000000,KDIMEN=5000000)
75574C...Commonblocks.
75575 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75576 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75577 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75578 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75579 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
75580C...Local arrays, character variables, saved variables and data.
75581 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
75582 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
75583 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
75584 &KFDM(8),KFDC(200,0:8),NPDC(200)
75585 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
75586 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
75587 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
75588 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
75589 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
75590 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
75591 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
75592 &NEVDC/0/,NKFDC/0/,NREDC/0/
75593
75594C...Reset statistics on initial parton state.
75595 IF(MTABU.EQ.10) THEN
75596 NEVIS=0
75597 NKFIS=0
75598
75599C...Identify and order flavour content of initial state.
75600 ELSEIF(MTABU.EQ.11) THEN
75601 NEVIS=NEVIS+1
75602 KFM1=2*IABS(MSTU(161))
75603 IF(MSTU(161).GT.0) KFM1=KFM1-1
75604 KFM2=2*IABS(MSTU(162))
75605 IF(MSTU(162).GT.0) KFM2=KFM2-1
75606 KFMN=MIN(KFM1,KFM2)
75607 KFMX=MAX(KFM1,KFM2)
75608 DO 100 I=1,NKFIS
75609 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
75610 IKFIS=-I
75611 GOTO 110
75612 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
75613 & KFMX.LT.KFIS(I,2))) THEN
75614 IKFIS=I
75615 GOTO 110
75616 ENDIF
75617 100 CONTINUE
75618 IKFIS=NKFIS+1
75619 110 IF(IKFIS.LT.0) THEN
75620 IKFIS=-IKFIS
75621 ELSE
75622 IF(NKFIS.GE.100) RETURN
75623 DO 130 I=NKFIS,IKFIS,-1
75624 KFIS(I+1,1)=KFIS(I,1)
75625 KFIS(I+1,2)=KFIS(I,2)
75626 DO 120 J=0,10
75627 NPIS(I+1,J)=NPIS(I,J)
75628 120 CONTINUE
75629 130 CONTINUE
75630 NKFIS=NKFIS+1
75631 KFIS(IKFIS,1)=KFMN
75632 KFIS(IKFIS,2)=KFMX
75633 DO 140 J=0,10
75634 NPIS(IKFIS,J)=0
75635 140 CONTINUE
75636 ENDIF
75637 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
75638
75639C...Count number of partons in initial state.
75640 NP=0
75641 DO 160 I=1,N
75642 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
75643 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
75644 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
75645 & THEN
75646 ELSE
75647 IM=I
75648 150 IM=K(IM,3)
75649 IF(IM.LE.0.OR.IM.GT.N) THEN
75650 NP=NP+1
75651 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75652 NP=NP+1
75653 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
75654 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
75655 & .NE.0) THEN
75656 ELSE
75657 GOTO 150
75658 ENDIF
75659 ENDIF
75660 160 CONTINUE
75661 NPCO=MAX(NP,1)
75662 IF(NP.GE.6) NPCO=6
75663 IF(NP.GE.8) NPCO=7
75664 IF(NP.GE.11) NPCO=8
75665 IF(NP.GE.16) NPCO=9
75666 IF(NP.GE.26) NPCO=10
75667 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
75668 MSTU(62)=NP
75669
75670C...Write statistics on initial parton state.
75671 ELSEIF(MTABU.EQ.12) THEN
75672 FAC=1D0/MAX(1,NEVIS)
75673 WRITE(MSTU(11),5000) NEVIS
75674 DO 170 I=1,NKFIS
75675 KFMN=KFIS(I,1)
75676 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75677 KFM1=(KFMN+1)/2
75678 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75679 CALL PYNAME(KFM1,CHAU)
75680 CHIS(1)=CHAU(1:12)
75681 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
75682 KFMX=KFIS(I,2)
75683 IF(KFIS(I,1).EQ.0) KFMX=0
75684 KFM2=(KFMX+1)/2
75685 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75686 CALL PYNAME(KFM2,CHAU)
75687 CHIS(2)=CHAU(1:12)
75688 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
75689 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
75690 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
75691 170 CONTINUE
75692
75693C...Copy statistics on initial parton state into /PYJETS/.
75694 ELSEIF(MTABU.EQ.13) THEN
75695 FAC=1D0/MAX(1,NEVIS)
75696 DO 190 I=1,NKFIS
75697 KFMN=KFIS(I,1)
75698 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
75699 KFM1=(KFMN+1)/2
75700 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
75701 KFMX=KFIS(I,2)
75702 IF(KFIS(I,1).EQ.0) KFMX=0
75703 KFM2=(KFMX+1)/2
75704 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
75705 K(I,1)=32
75706 K(I,2)=99
75707 K(I,3)=KFM1
75708 K(I,4)=KFM2
75709 K(I,5)=NPIS(I,0)
75710 DO 180 J=1,5
75711 P(I,J)=FAC*NPIS(I,J)
75712 V(I,J)=FAC*NPIS(I,J+5)
75713 180 CONTINUE
75714 190 CONTINUE
75715 N=NKFIS
75716 DO 200 J=1,5
75717 K(N+1,J)=0
75718 P(N+1,J)=0D0
75719 V(N+1,J)=0D0
75720 200 CONTINUE
75721 K(N+1,1)=32
75722 K(N+1,2)=99
75723 K(N+1,5)=NEVIS
75724 MSTU(3)=1
75725
75726C...Reset statistics on number of particles/partons.
75727 ELSEIF(MTABU.EQ.20) THEN
75728 NEVFS=0
75729 NPRFS=0
75730 NFIFS=0
75731 NCHFS=0
75732 NKFFS=0
75733
75734C...Identify whether particle/parton is primary or not.
75735 ELSEIF(MTABU.EQ.21) THEN
75736 NEVFS=NEVFS+1
75737 MSTU(62)=0
75738 DO 260 I=1,N
75739 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
75740 MSTU(62)=MSTU(62)+1
75741 KC=PYCOMP(K(I,2))
75742 MPRI=0
75743 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
75744 MPRI=1
75745 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
75746 MPRI=1
75747 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
75748 MPRI=1
75749 ELSEIF(KC.EQ.0) THEN
75750 ELSEIF(K(K(I,3),1).EQ.13) THEN
75751 IM=K(K(I,3),3)
75752 IF(IM.LE.0.OR.IM.GT.N) THEN
75753 MPRI=1
75754 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
75755 MPRI=1
75756 ENDIF
75757 ELSEIF(KCHG(KC,2).EQ.0) THEN
75758 KCM=PYCOMP(K(K(I,3),2))
75759 IF(KCM.NE.0) THEN
75760 IF(KCHG(KCM,2).NE.0) MPRI=1
75761 ENDIF
75762 ENDIF
75763 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
75764 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
75765 ENDIF
75766 IF(K(I,1).LE.10) THEN
75767 NFIFS=NFIFS+1
75768 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
75769 ENDIF
75770
75771C...Fill statistics on number of particles/partons in event.
75772 KFA=IABS(K(I,2))
75773 KFS=3-ISIGN(1,K(I,2))-MPRI
75774 DO 210 IP=1,NKFFS
75775 IF(KFA.EQ.KFFS(IP)) THEN
75776 IKFFS=-IP
75777 GOTO 220
75778 ELSEIF(KFA.LT.KFFS(IP)) THEN
75779 IKFFS=IP
75780 GOTO 220
75781 ENDIF
75782 210 CONTINUE
75783 IKFFS=NKFFS+1
75784 220 IF(IKFFS.LT.0) THEN
75785 IKFFS=-IKFFS
75786 ELSE
75787 IF(NKFFS.GE.400) RETURN
75788 DO 240 IP=NKFFS,IKFFS,-1
75789 KFFS(IP+1)=KFFS(IP)
75790 DO 230 J=1,4
75791 NPFS(IP+1,J)=NPFS(IP,J)
75792 230 CONTINUE
75793 240 CONTINUE
75794 NKFFS=NKFFS+1
75795 KFFS(IKFFS)=KFA
75796 DO 250 J=1,4
75797 NPFS(IKFFS,J)=0
75798 250 CONTINUE
75799 ENDIF
75800 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
75801 260 CONTINUE
75802
75803C...Write statistics on particle/parton composition of events.
75804 ELSEIF(MTABU.EQ.22) THEN
75805 FAC=1D0/MAX(1,NEVFS)
75806 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
75807 DO 270 I=1,NKFFS
75808 CALL PYNAME(KFFS(I),CHAU)
75809 KC=PYCOMP(KFFS(I))
75810 MDCYF=0
75811 IF(KC.NE.0) MDCYF=MDCY(KC,1)
75812 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
75813 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
75814 270 CONTINUE
75815
75816C...Copy particle/parton composition information into /PYJETS/.
75817 ELSEIF(MTABU.EQ.23) THEN
75818 FAC=1D0/MAX(1,NEVFS)
75819 DO 290 I=1,NKFFS
75820 K(I,1)=32
75821 K(I,2)=99
75822 K(I,3)=KFFS(I)
75823 K(I,4)=0
75824 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
75825 DO 280 J=1,4
75826 P(I,J)=FAC*NPFS(I,J)
75827 V(I,J)=0D0
75828 280 CONTINUE
75829 P(I,5)=FAC*K(I,5)
75830 V(I,5)=0D0
75831 290 CONTINUE
75832 N=NKFFS
75833 DO 300 J=1,5
75834 K(N+1,J)=0
75835 P(N+1,J)=0D0
75836 V(N+1,J)=0D0
75837 300 CONTINUE
75838 K(N+1,1)=32
75839 K(N+1,2)=99
75840 K(N+1,5)=NEVFS
75841 P(N+1,1)=FAC*NPRFS
75842 P(N+1,2)=FAC*NFIFS
75843 P(N+1,3)=FAC*NCHFS
75844 MSTU(3)=1
75845
75846C...Reset factorial moments statistics.
75847 ELSEIF(MTABU.EQ.30) THEN
75848 NEVFM=0
75849 NMUFM=0
75850 DO 330 IM=1,3
75851 DO 320 IB=1,10
75852 DO 310 IP=1,4
75853 FM1FM(IM,IB,IP)=0D0
75854 FM2FM(IM,IB,IP)=0D0
75855 310 CONTINUE
75856 320 CONTINUE
75857 330 CONTINUE
75858
75859C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
75860 ELSEIF(MTABU.EQ.31) THEN
75861 NEVFM=NEVFM+1
75862 NLOW=N+MSTU(3)
75863 NUPP=NLOW
75864 DO 410 I=1,N
75865 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
75866 IF(MSTU(41).GE.2) THEN
75867 KC=PYCOMP(K(I,2))
75868 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
75869 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
75870 & K(I,2).EQ.KSUSY1+39) GOTO 410
75871 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
75872 & PYCHGE(K(I,2)).EQ.0) GOTO 410
75873 ENDIF
75874 PMR=0D0
75875 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
75876 IF(MSTU(42).GE.2) PMR=P(I,5)
75877 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
75878 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
75879 & 1D20)),P(I,3))
75880 IF(ABS(YETA).GT.PARU(57)) GOTO 410
75881 PHI=PYANGL(P(I,1),P(I,2))
75882 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
75883 IYETA=MAX(0,MIN(511,IYETA))
75884 IPHI=512D0*(PHI+PARU(1))/PARU(2)
75885 IPHI=MAX(0,MIN(511,IPHI))
75886 IYEP=0
75887 DO 340 IB=0,9
75888 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
75889 340 CONTINUE
75890
75891C...Order particles in (pseudo)rapidity and/or azimuth.
75892 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
75893 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
75894 RETURN
75895 ENDIF
75896 NUPP=NUPP+1
75897 IF(NUPP.EQ.NLOW+1) THEN
75898 K(NUPP,1)=IYETA
75899 K(NUPP,2)=IPHI
75900 K(NUPP,3)=IYEP
75901 ELSE
75902 DO 350 I1=NUPP-1,NLOW+1,-1
75903 IF(IYETA.GE.K(I1,1)) GOTO 360
75904 K(I1+1,1)=K(I1,1)
75905 350 CONTINUE
75906 360 K(I1+1,1)=IYETA
75907 DO 370 I1=NUPP-1,NLOW+1,-1
75908 IF(IPHI.GE.K(I1,2)) GOTO 380
75909 K(I1+1,2)=K(I1,2)
75910 370 CONTINUE
75911 380 K(I1+1,2)=IPHI
75912 DO 390 I1=NUPP-1,NLOW+1,-1
75913 IF(IYEP.GE.K(I1,3)) GOTO 400
75914 K(I1+1,3)=K(I1,3)
75915 390 CONTINUE
75916 400 K(I1+1,3)=IYEP
75917 ENDIF
75918 410 CONTINUE
75919 K(NUPP+1,1)=2**10
75920 K(NUPP+1,2)=2**10
75921 K(NUPP+1,3)=4**10
75922
75923C...Calculate sum of factorial moments in event.
75924 DO 480 IM=1,3
75925 DO 430 IB=1,10
75926 DO 420 IP=1,4
75927 FEVFM(IB,IP)=0D0
75928 420 CONTINUE
75929 430 CONTINUE
75930 DO 450 IB=1,10
75931 IF(IM.LE.2) IBIN=2**(10-IB)
75932 IF(IM.EQ.3) IBIN=4**(10-IB)
75933 IAGR=K(NLOW+1,IM)/IBIN
75934 NAGR=1
75935 DO 440 I=NLOW+2,NUPP+1
75936 ICUT=K(I,IM)/IBIN
75937 IF(ICUT.EQ.IAGR) THEN
75938 NAGR=NAGR+1
75939 ELSE
75940 IF(NAGR.EQ.1) THEN
75941 ELSEIF(NAGR.EQ.2) THEN
75942 FEVFM(IB,1)=FEVFM(IB,1)+2D0
75943 ELSEIF(NAGR.EQ.3) THEN
75944 FEVFM(IB,1)=FEVFM(IB,1)+6D0
75945 FEVFM(IB,2)=FEVFM(IB,2)+6D0
75946 ELSEIF(NAGR.EQ.4) THEN
75947 FEVFM(IB,1)=FEVFM(IB,1)+12D0
75948 FEVFM(IB,2)=FEVFM(IB,2)+24D0
75949 FEVFM(IB,3)=FEVFM(IB,3)+24D0
75950 ELSE
75951 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
75952 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
75953 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75954 & (NAGR-3D0)
75955 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
75956 & (NAGR-3D0)*(NAGR-4D0)
75957 ENDIF
75958 IAGR=ICUT
75959 NAGR=1
75960 ENDIF
75961 440 CONTINUE
75962 450 CONTINUE
75963
75964C...Add results to total statistics.
75965 DO 470 IB=10,1,-1
75966 DO 460 IP=1,4
75967 IF(FEVFM(1,IP).LT.0.5D0) THEN
75968 FEVFM(IB,IP)=0D0
75969 ELSEIF(IM.LE.2) THEN
75970 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75971 ELSE
75972 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
75973 ENDIF
75974 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
75975 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
75976 460 CONTINUE
75977 470 CONTINUE
75978 480 CONTINUE
75979 NMUFM=NMUFM+(NUPP-NLOW)
75980 MSTU(62)=NUPP-NLOW
75981
75982C...Write accumulated statistics on factorial moments.
75983 ELSEIF(MTABU.EQ.32) THEN
75984 FAC=1D0/MAX(1,NEVFM)
75985 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
75986 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
75987 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
75988 DO 510 IM=1,3
75989 WRITE(MSTU(11),5500)
75990 DO 500 IB=1,10
75991 BYETA=2D0*PARU(57)
75992 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
75993 BPHI=PARU(2)
75994 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
75995 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
75996 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
75997 DO 490 IP=1,4
75998 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
75999 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
76000 & FMOMA(IP)**2)))
76001 490 CONTINUE
76002 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
76003 & IP=1,4)
76004 500 CONTINUE
76005 510 CONTINUE
76006
76007C...Copy statistics on factorial moments into /PYJETS/.
76008 ELSEIF(MTABU.EQ.33) THEN
76009 FAC=1D0/MAX(1,NEVFM)
76010 DO 540 IM=1,3
76011 DO 530 IB=1,10
76012 I=10*(IM-1)+IB
76013 K(I,1)=32
76014 K(I,2)=99
76015 K(I,3)=1
76016 IF(IM.NE.2) K(I,3)=2**(IB-1)
76017 K(I,4)=1
76018 IF(IM.NE.1) K(I,4)=2**(IB-1)
76019 K(I,5)=0
76020 P(I,1)=2D0*PARU(57)/K(I,3)
76021 V(I,1)=PARU(2)/K(I,4)
76022 DO 520 IP=1,4
76023 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
76024 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
76025 & P(I,IP+1)**2)))
76026 520 CONTINUE
76027 530 CONTINUE
76028 540 CONTINUE
76029 N=30
76030 DO 550 J=1,5
76031 K(N+1,J)=0
76032 P(N+1,J)=0D0
76033 V(N+1,J)=0D0
76034 550 CONTINUE
76035 K(N+1,1)=32
76036 K(N+1,2)=99
76037 K(N+1,5)=NEVFM
76038 MSTU(3)=1
76039
76040C...Reset statistics on Energy-Energy Correlation.
76041 ELSEIF(MTABU.EQ.40) THEN
76042 NEVEE=0
76043 DO 560 J=1,25
76044 FE1EC(J)=0D0
76045 FE2EC(J)=0D0
76046 FE1EC(51-J)=0D0
76047 FE2EC(51-J)=0D0
76048 FE1EA(J)=0D0
76049 FE2EA(J)=0D0
76050 560 CONTINUE
76051
76052C...Find particles to include, with proper assumed mass.
76053 ELSEIF(MTABU.EQ.41) THEN
76054 NEVEE=NEVEE+1
76055 NLOW=N+MSTU(3)
76056 NUPP=NLOW
76057 ECM=0D0
76058 DO 570 I=1,N
76059 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
76060 IF(MSTU(41).GE.2) THEN
76061 KC=PYCOMP(K(I,2))
76062 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76063 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76064 & K(I,2).EQ.KSUSY1+39) GOTO 570
76065 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
76066 & PYCHGE(K(I,2)).EQ.0) GOTO 570
76067 ENDIF
76068 PMR=0D0
76069 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
76070 IF(MSTU(42).GE.2) PMR=P(I,5)
76071 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
76072 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
76073 RETURN
76074 ENDIF
76075 NUPP=NUPP+1
76076 P(NUPP,1)=P(I,1)
76077 P(NUPP,2)=P(I,2)
76078 P(NUPP,3)=P(I,3)
76079 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76080 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
76081 ECM=ECM+P(NUPP,4)
76082 570 CONTINUE
76083 IF(NUPP.EQ.NLOW) RETURN
76084
76085C...Analyze Energy-Energy Correlation in event.
76086 FAC=(2D0/ECM**2)*50D0/PARU(1)
76087 DO 580 J=1,50
76088 FEVEE(J)=0D0
76089 580 CONTINUE
76090 DO 600 I1=NLOW+2,NUPP
76091 DO 590 I2=NLOW+1,I1-1
76092 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
76093 & (P(I1,5)*P(I2,5))
76094 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
76095 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
76096 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
76097 590 CONTINUE
76098 600 CONTINUE
76099 DO 610 J=1,25
76100 FE1EC(J)=FE1EC(J)+FEVEE(J)
76101 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
76102 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
76103 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
76104 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
76105 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
76106 610 CONTINUE
76107 MSTU(62)=NUPP-NLOW
76108
76109C...Write statistics on Energy-Energy Correlation.
76110 ELSEIF(MTABU.EQ.42) THEN
76111 FAC=1D0/MAX(1,NEVEE)
76112 WRITE(MSTU(11),5700) NEVEE
76113 DO 620 J=1,25
76114 FEEC1=FAC*FE1EC(J)
76115 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
76116 FEEC2=FAC*FE1EC(51-J)
76117 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
76118 FEECA=FAC*FE1EA(J)
76119 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
76120 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
76121 & FEEC2,FEES2,FEECA,FEESA
76122 620 CONTINUE
76123
76124C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
76125 ELSEIF(MTABU.EQ.43) THEN
76126 FAC=1D0/MAX(1,NEVEE)
76127 DO 630 I=1,25
76128 K(I,1)=32
76129 K(I,2)=99
76130 K(I,3)=0
76131 K(I,4)=0
76132 K(I,5)=0
76133 P(I,1)=FAC*FE1EC(I)
76134 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
76135 P(I,2)=FAC*FE1EC(51-I)
76136 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
76137 P(I,3)=FAC*FE1EA(I)
76138 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
76139 P(I,4)=PARU(1)*(I-1)/50D0
76140 P(I,5)=PARU(1)*I/50D0
76141 V(I,4)=3.6D0*(I-1)
76142 V(I,5)=3.6D0*I
76143 630 CONTINUE
76144 N=25
76145 DO 640 J=1,5
76146 K(N+1,J)=0
76147 P(N+1,J)=0D0
76148 V(N+1,J)=0D0
76149 640 CONTINUE
76150 K(N+1,1)=32
76151 K(N+1,2)=99
76152 K(N+1,5)=NEVEE
76153 MSTU(3)=1
76154
76155C...Reset statistics on decay channels.
76156 ELSEIF(MTABU.EQ.50) THEN
76157 NEVDC=0
76158 NKFDC=0
76159 NREDC=0
76160
76161C...Identify and order flavour content of final state.
76162 ELSEIF(MTABU.EQ.51) THEN
76163 NEVDC=NEVDC+1
76164 NDS=0
76165 DO 670 I=1,N
76166 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
76167 NDS=NDS+1
76168 IF(NDS.GT.8) THEN
76169 NREDC=NREDC+1
76170 RETURN
76171 ENDIF
76172 KFM=2*IABS(K(I,2))
76173 IF(K(I,2).LT.0) KFM=KFM-1
76174 DO 650 IDS=NDS-1,1,-1
76175 IIN=IDS+1
76176 IF(KFM.LT.KFDM(IDS)) GOTO 660
76177 KFDM(IDS+1)=KFDM(IDS)
76178 650 CONTINUE
76179 IIN=1
76180 660 KFDM(IIN)=KFM
76181 670 CONTINUE
76182
76183C...Find whether old or new final state.
76184 DO 690 IDC=1,NKFDC
76185 IF(NDS.LT.KFDC(IDC,0)) THEN
76186 IKFDC=IDC
76187 GOTO 700
76188 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
76189 DO 680 I=1,NDS
76190 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
76191 IKFDC=IDC
76192 GOTO 700
76193 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
76194 GOTO 690
76195 ENDIF
76196 680 CONTINUE
76197 IKFDC=-IDC
76198 GOTO 700
76199 ENDIF
76200 690 CONTINUE
76201 IKFDC=NKFDC+1
76202 700 IF(IKFDC.LT.0) THEN
76203 IKFDC=-IKFDC
76204 ELSEIF(NKFDC.GE.200) THEN
76205 NREDC=NREDC+1
76206 RETURN
76207 ELSE
76208 DO 720 IDC=NKFDC,IKFDC,-1
76209 NPDC(IDC+1)=NPDC(IDC)
76210 DO 710 I=0,8
76211 KFDC(IDC+1,I)=KFDC(IDC,I)
76212 710 CONTINUE
76213 720 CONTINUE
76214 NKFDC=NKFDC+1
76215 KFDC(IKFDC,0)=NDS
76216 DO 730 I=1,NDS
76217 KFDC(IKFDC,I)=KFDM(I)
76218 730 CONTINUE
76219 NPDC(IKFDC)=0
76220 ENDIF
76221 NPDC(IKFDC)=NPDC(IKFDC)+1
76222
76223C...Write statistics on decay channels.
76224 ELSEIF(MTABU.EQ.52) THEN
76225 FAC=1D0/MAX(1,NEVDC)
76226 WRITE(MSTU(11),5900) NEVDC
76227 DO 750 IDC=1,NKFDC
76228 DO 740 I=1,KFDC(IDC,0)
76229 KFM=KFDC(IDC,I)
76230 KF=(KFM+1)/2
76231 IF(2*KF.NE.KFM) KF=-KF
76232 CALL PYNAME(KF,CHAU)
76233 CHDC(I)=CHAU(1:12)
76234 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
76235 740 CONTINUE
76236 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
76237 750 CONTINUE
76238 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
76239
76240C...Copy statistics on decay channels into /PYJETS/.
76241 ELSEIF(MTABU.EQ.53) THEN
76242 FAC=1D0/MAX(1,NEVDC)
76243 DO 780 IDC=1,NKFDC
76244 K(IDC,1)=32
76245 K(IDC,2)=99
76246 K(IDC,3)=0
76247 K(IDC,4)=0
76248 K(IDC,5)=KFDC(IDC,0)
76249 DO 760 J=1,5
76250 P(IDC,J)=0D0
76251 V(IDC,J)=0D0
76252 760 CONTINUE
76253 DO 770 I=1,KFDC(IDC,0)
76254 KFM=KFDC(IDC,I)
76255 KF=(KFM+1)/2
76256 IF(2*KF.NE.KFM) KF=-KF
76257 IF(I.LE.5) P(IDC,I)=KF
76258 IF(I.GE.6) V(IDC,I-5)=KF
76259 770 CONTINUE
76260 V(IDC,5)=FAC*NPDC(IDC)
76261 780 CONTINUE
76262 N=NKFDC
76263 DO 790 J=1,5
76264 K(N+1,J)=0
76265 P(N+1,J)=0D0
76266 V(N+1,J)=0D0
76267 790 CONTINUE
76268 K(N+1,1)=32
76269 K(N+1,2)=99
76270 K(N+1,5)=NEVDC
76271 V(N+1,5)=FAC*NREDC
76272 MSTU(3)=1
76273 ENDIF
76274
76275C...Format statements for output on unit MSTU(11) (default 6).
76276 5000 FORMAT(///20X,'Event statistics - initial state'/
76277 &20X,'based on an analysis of ',I6,' events'//
76278 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
76279 &'according to fragmenting system multiplicity'/
76280 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
76281 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
76282 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
76283 5200 FORMAT(///20X,'Event statistics - final state'/
76284 &20X,'based on an analysis of ',I7,' events'//
76285 &5X,'Mean primary multiplicity =',F10.4/
76286 &5X,'Mean final multiplicity =',F10.4/
76287 &5X,'Mean charged multiplicity =',F10.4//
76288 &5X,'Number of particles produced per event (directly and via ',
76289 &'decays/branchings)'/
76290 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
76291 &8X,'Total'/35X,'prim seco prim seco'/)
76292 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
76293 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
76294 &20X,'based on an analysis of ',I6,' events'//
76295 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
76296 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
76297 5500 FORMAT(10X)
76298 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
76299 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
76300 &20X,'based on an analysis of ',I6,' events'//
76301 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
76302 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
76303 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
76304 5900 FORMAT(///20X,'Decay channel analysis - final state'/
76305 &20X,'based on an analysis of ',I6,' events'//
76306 &2X,'Probability',10X,'Complete final state'/)
76307 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
76308 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
76309 &'or table overflow)')
76310
76311 RETURN
76312 END
76313
76314C*********************************************************************
76315
76316C...PYEEVT
76317C...Handles the generation of an e+e- annihilation jet event.
76318
76319 SUBROUTINE PYEEVT(KFL,ECM)
76320
76321C...Double precision and integer declarations.
76322 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76323 IMPLICIT INTEGER(I-N)
76324 INTEGER PYK,PYCHGE,PYCOMP
76325C...Commonblocks.
76326 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76327 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76328 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76329 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76330
76331C...Check input parameters.
76332 IF(MSTU(12).NE.12345) CALL PYLIST(0)
76333 IF(KFL.LT.0.OR.KFL.GT.8) THEN
76334 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
76335 IF(MSTU(21).GE.1) RETURN
76336 ENDIF
76337 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
76338 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
76339 IF(ECM.LT.ECMMIN) THEN
76340 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
76341 IF(MSTU(21).GE.1) RETURN
76342 ENDIF
76343
76344C...Check consistency of MSTJ options set.
76345 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
76346 CALL PYERRM(6,
76347 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
76348 MSTJ(110)=1
76349 ENDIF
76350 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
76351 CALL PYERRM(6,
76352 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
76353 MSTJ(111)=0
76354 ENDIF
76355
76356C...Initialize alpha_strong and total cross-section.
76357 MSTU(111)=MSTJ(108)
76358 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
76359 &MSTU(111)=1
76360 PARU(112)=PARJ(121)
76361 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
76362 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
76363 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
76364 &XTOT)
76365 IF(MSTJ(116).GE.3) MSTJ(116)=1
76366 PARJ(171)=0D0
76367
76368C...Add initial e+e- to event record (documentation only).
76369 NTRY=0
76370 100 NTRY=NTRY+1
76371 IF(NTRY.GT.100) THEN
76372 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
76373 RETURN
76374 ENDIF
76375 MSTU(24)=0
76376 NC=0
76377 IF(MSTJ(115).GE.2) THEN
76378 NC=NC+2
76379 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
76380 K(NC-1,1)=21
76381 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
76382 K(NC,1)=21
76383 ENDIF
76384
76385C...Radiative photon (in initial state).
76386 MK=0
76387 ECMC=ECM
76388 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
76389 &THEK,PHIK,ALPK)
76390 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
76391 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
76392 NC=NC+1
76393 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
76394 K(NC,3)=MIN(MSTJ(115)/2,1)
76395 ENDIF
76396
76397C...Virtual exchange boson (gamma or Z0).
76398 IF(MSTJ(115).GE.3) THEN
76399 NC=NC+1
76400 KF=22
76401 IF(MSTJ(102).EQ.2) KF=23
76402 MSTU10=MSTU(10)
76403 MSTU(10)=1
76404 P(NC,5)=ECMC
76405 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
76406 K(NC,1)=21
76407 K(NC,3)=1
76408 MSTU(10)=MSTU10
76409 ENDIF
76410
76411C...Choice of flavour and jet configuration.
76412 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
76413 IF(KFLC.EQ.0) GOTO 100
76414 CALL PYXJET(ECMC,NJET,CUT)
76415 KFLN=21
76416 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
76417 &X12,X14)
76418 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
76419 IF(NJET.EQ.2) MSTJ(120)=1
76420
76421C...Fill jet configuration and origin.
76422 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
76423 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
76424 &ECMC)
76425 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
76426 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
76427 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76428 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
76429 &-KFLC,ECMC,X1,X2,X4,X12,X14)
76430 IF(MSTU(24).NE.0) GOTO 100
76431 DO 110 IP=NC+1,N
76432 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
76433 110 CONTINUE
76434
76435C...Angular orientation according to matrix element.
76436 IF(MSTJ(106).EQ.1) THEN
76437 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
76438 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
76439 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
76440 ENDIF
76441
76442C...Rotation and boost from radiative photon.
76443 IF(MK.EQ.1) THEN
76444 DBEK=-PAK/(ECM-PAK)
76445 NMIN=NC+1-MSTJ(115)/3
76446 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
76447 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
76448 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
76449 ENDIF
76450
76451C...Generate parton shower. Rearrange along strings and check.
76452 IF(MSTJ(101).EQ.5) THEN
76453 CALL PYSHOW(N-1,N,ECMC)
76454 MSTJ14=MSTJ(14)
76455 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
76456 IF(MSTJ(105).GE.0) MSTU(28)=0
76457 CALL PYPREP(0)
76458 MSTJ(14)=MSTJ14
76459 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
76460 ENDIF
76461
76462C...Fragmentation/decay generation. Information for PYTABU.
76463 IF(MSTJ(105).EQ.1) CALL PYEXEC
76464 MSTU(161)=KFLC
76465 MSTU(162)=-KFLC
76466
76467 RETURN
76468 END
76469
76470C*********************************************************************
76471
76472C...PYXTEE
76473C...Calculates total cross-section, including initial state
76474C...radiation effects.
76475
76476 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
76477
76478C...Double precision and integer declarations.
76479 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76480 IMPLICIT INTEGER(I-N)
76481 INTEGER PYK,PYCHGE,PYCOMP
76482C...Commonblocks.
76483 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76484 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76485 SAVE /PYDAT1/,/PYDAT2/
76486
76487C...Status, (optimized) Q^2 scale, alpha_strong.
76488 PARJ(151)=ECM
76489 MSTJ(119)=10*MSTJ(102)+KFL
76490 IF(MSTJ(111).EQ.0) THEN
76491 Q2R=ECM**2
76492 ELSEIF(MSTU(111).EQ.0) THEN
76493 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76494 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76495 Q2R=PARJ(168)*ECM**2
76496 ELSE
76497 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76498 & (2D0*PARU(112)/ECM)**2))
76499 Q2R=PARJ(168)*ECM**2
76500 ENDIF
76501 ALSPI=PYALPS(Q2R)/PARU(1)
76502
76503C...QCD corrections factor in R.
76504 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
76505 RQCD=1D0
76506 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
76507 RQCD=1D0+ALSPI
76508 ELSEIF(MSTJ(109).EQ.0) THEN
76509 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76510 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
76511 & LOG(PARJ(168))*ALSPI**2)
76512 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
76513 RQCD=1D0+(3D0/4D0)*ALSPI
76514 ELSE
76515 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
76516 ENDIF
76517
76518C...Calculate Z0 width if default value not acceptable.
76519 IF(MSTJ(102).GE.3) THEN
76520 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
76521 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
76522 DO 100 KFLC=5,6
76523 VQ=1D0
76524 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
76525 & (2D0*PYMASS(KFLC)/ ECM)**2))
76526 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
76527 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
76528 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
76529 100 CONTINUE
76530 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
76531 & (1D0-PARU(102)))
76532 ENDIF
76533
76534C...Calculate propagator and related constants for QFD case.
76535 POLL=1D0-PARJ(131)*PARJ(132)
76536 IF(MSTJ(102).GE.2) THEN
76537 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76538 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76539 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
76540 VE=4D0*PARU(102)-1D0
76541 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
76542 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76543 HF1I=SFI*SF1I
76544 HF1W=SFW*SF1W
76545 ENDIF
76546
76547C...Loop over different flavours: charge, velocity.
76548 RTOT=0D0
76549 RQQ=0D0
76550 RQV=0D0
76551 RVA=0D0
76552 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
76553 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
76554 MSTJ(93)=1
76555 PMQ=PYMASS(KFLC)
76556 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
76557 QF=KCHG(KFLC,1)/3D0
76558 VQ=1D0
76559 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
76560
76561C...Calculate R and sum of charges for QED or QFD case.
76562 RQQ=RQQ+3D0*QF**2*POLL
76563 IF(MSTJ(102).LE.1) THEN
76564 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
76565 ELSE
76566 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76567 RQV=RQV-6D0*QF*VF*SF1I
76568 RVA=RVA+3D0*(VF**2+1D0)*SF1W
76569 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
76570 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
76571 ENDIF
76572 110 CONTINUE
76573 RSUM=RQQ
76574 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
76575
76576C...Calculate cross-section, including QCD corrections.
76577 PARJ(141)=RQQ
76578 PARJ(142)=RTOT
76579 PARJ(143)=RTOT*RQCD
76580 PARJ(144)=PARJ(143)
76581 PARJ(145)=PARJ(141)*86.8D0/ECM**2
76582 PARJ(146)=PARJ(142)*86.8D0/ECM**2
76583 PARJ(147)=PARJ(143)*86.8D0/ECM**2
76584 PARJ(148)=PARJ(147)
76585 PARJ(157)=RSUM*RQCD
76586 PARJ(158)=0D0
76587 PARJ(159)=0D0
76588 XTOT=PARJ(147)
76589 IF(MSTJ(107).LE.0) RETURN
76590
76591C...Virtual cross-section.
76592 XKL=PARJ(135)
76593 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76594 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
76595 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
76596 &1.526D0*LOG(ECM**2/0.932D0)
76597
76598C...Soft and hard radiative cross-section in QED case.
76599 IF(MSTJ(102).LE.1) THEN
76600 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
76601 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
76602 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
76603
76604C...Soft and hard radiative cross-section in QFD case.
76605 ELSE
76606 SZM=1D0-(PARJ(123)/ECM)**2
76607 SZW=PARJ(123)*PARJ(124)/ECM**2
76608 PARJ(161)=-RQQ/RSUM
76609 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
76610 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
76611 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
76612 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
76613 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
76614 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
76615 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
76616 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
76617 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
76618 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
76619 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
76620 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
76621 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
76622 ENDIF
76623
76624C...Total cross-section and fraction of hard photon events.
76625 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
76626 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
76627 PARJ(144)=PARJ(157)
76628 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76629 XTOT=PARJ(148)
76630
76631 RETURN
76632 END
76633
76634C*********************************************************************
76635
76636C...PYRADK
76637C...Generates initial state photon radiation.
76638
76639 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
76640
76641C...Double precision and integer declarations.
76642 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76643 IMPLICIT INTEGER(I-N)
76644 INTEGER PYK,PYCHGE,PYCOMP
76645C...Commonblocks.
76646 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76647 SAVE /PYDAT1/
76648
76649C...Function: cumulative hard photon spectrum in QFD case.
76650 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
76651 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
76652
76653C...Determine whether radiative photon or not.
76654 MK=0
76655 PAK=0D0
76656 IF(PARJ(160).LT.PYR(0)) RETURN
76657 MK=1
76658
76659C...Photon energy range. Find photon momentum in QED case.
76660 XKL=PARJ(135)
76661 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
76662 IF(MSTJ(102).LE.1) THEN
76663 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
76664 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
76665
76666C...Ditto in QFD case, by numerical inversion of integrated spectrum.
76667 ELSE
76668 SZM=1D0-(PARJ(123)/ECM)**2
76669 SZW=PARJ(123)*PARJ(124)/ECM**2
76670 FXKL=FXK(XKL)
76671 FXKU=FXK(XKU)
76672 FXKD=1D-4*(FXKU-FXKL)
76673 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
76674 NXK=0
76675 110 NXK=NXK+1
76676 XK=0.5D0*(XKL+XKU)
76677 FXKV=FXK(XK)
76678 IF(FXKV.GT.FXKR) THEN
76679 XKU=XK
76680 FXKU=FXKV
76681 ELSE
76682 XKL=XK
76683 FXKL=FXKV
76684 ENDIF
76685 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
76686 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
76687 ENDIF
76688 PAK=0.5D0*ECM*XK
76689
76690C...Photon polar and azimuthal angle.
76691 PME=2D0*(PYMASS(11)/ECM)**2
76692 120 CTHM=PME*(2D0/PME)**PYR(0)
76693 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
76694 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
76695 CTHE=1D0-CTHM
76696 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
76697 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
76698 THEK=PYANGL(CTHE,STHE)
76699 PHIK=PARU(2)*PYR(0)
76700
76701C...Rotation angle for hadronic system.
76702 SGN=1D0
76703 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
76704 &PYR(0)) SGN=-1D0
76705 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
76706 &(2D0-XK*(1D0-SGN*CTHE)))
76707
76708 RETURN
76709 END
76710
76711C*********************************************************************
76712
76713C...PYXKFL
76714C...Selects flavour for produced qqbar pair.
76715
76716 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
76717
76718C...Double precision and integer declarations.
76719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76720 IMPLICIT INTEGER(I-N)
76721 INTEGER PYK,PYCHGE,PYCOMP
76722C...Commonblocks.
76723 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76724 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76725 SAVE /PYDAT1/,/PYDAT2/
76726
76727C...Calculate maximum weight in QED or QFD case.
76728 IF(MSTJ(102).LE.1) THEN
76729 RFMAX=4D0/9D0
76730 ELSE
76731 POLL=1D0-PARJ(131)*PARJ(132)
76732 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
76733 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
76734 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
76735 VE=4D0*PARU(102)-1D0
76736 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
76737 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
76738 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
76739 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
76740 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
76741 & 1D0)*HF1W)
76742 ENDIF
76743
76744C...Choose flavour. Gives charge and velocity.
76745 NTRY=0
76746 100 NTRY=NTRY+1
76747 IF(NTRY.GT.100) THEN
76748 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
76749 KFLC=0
76750 RETURN
76751 ENDIF
76752 KFLC=KFL
76753 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
76754 MSTJ(93)=1
76755 PMQ=PYMASS(KFLC)
76756 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
76757 QF=KCHG(KFLC,1)/3D0
76758 VQ=1D0
76759 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
76760
76761C...Calculate weight in QED or QFD case.
76762 IF(MSTJ(102).LE.1) THEN
76763 RF=QF**2
76764 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
76765 ELSE
76766 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
76767 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
76768 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
76769 & VQ**3*HF1W
76770 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
76771 ENDIF
76772
76773C...Weighting or new event (radiative photon). Cross-section update.
76774 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
76775 PARJ(158)=PARJ(158)+1D0
76776 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
76777 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
76778 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
76779 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
76780 PARJ(148)=PARJ(144)*86.8D0/ECM**2
76781
76782 RETURN
76783 END
76784
76785C*********************************************************************
76786
76787C...PYXJET
76788C...Selects number of jets in matrix element approach.
76789
76790 SUBROUTINE PYXJET(ECM,NJET,CUT)
76791
76792C...Double precision and integer declarations.
76793 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76794 IMPLICIT INTEGER(I-N)
76795 INTEGER PYK,PYCHGE,PYCOMP
76796C...Commonblocks.
76797 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76798 SAVE /PYDAT1/
76799C...Local array and data.
76800 DIMENSION ZHUT(5)
76801 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
76802
76803C...Trivial result for two-jets only, including parton shower.
76804 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76805 CUT=0D0
76806
76807C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
76808 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
76809 CF=4D0/3D0
76810 IF(MSTJ(109).EQ.2) CF=1D0
76811 IF(MSTJ(111).EQ.0) THEN
76812 Q2=ECM**2
76813 Q2R=ECM**2
76814 ELSEIF(MSTU(111).EQ.0) THEN
76815 PARJ(169)=MIN(1D0,PARJ(129))
76816 Q2=PARJ(169)*ECM**2
76817 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
76818 & ((33D0-2D0*MSTU(112))*PARU(111)))))
76819 Q2R=PARJ(168)*ECM**2
76820 ELSE
76821 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
76822 Q2=PARJ(169)*ECM**2
76823 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
76824 & (2D0*PARU(112)/ECM)**2))
76825 Q2R=PARJ(168)*ECM**2
76826 ENDIF
76827
76828C...alpha_strong for R and R itself.
76829 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
76830 IF(IABS(MSTJ(101)).EQ.1) THEN
76831 RQCD=1D0+ALSPI
76832 ELSEIF(MSTJ(109).EQ.0) THEN
76833 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
76834 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
76835 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
76836 ELSE
76837 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
76838 ENDIF
76839
76840C...alpha_strong for jet rate. Initial value for y cut.
76841 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76842 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
76843 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
76844 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
76845 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76846
76847C...Parametrization of first order three-jet cross-section.
76848 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
76849 PARJ(152)=0D0
76850 ELSE
76851 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
76852 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
76853 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
76854 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
76855 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
76856 & PARJ(152)=0D0
76857 ENDIF
76858
76859C...Parametrization of second order three-jet cross-section.
76860 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
76861 & CUT.GE.0.25D0) THEN
76862 PARJ(153)=0D0
76863 ELSEIF(MSTJ(110).LE.1) THEN
76864 CT=LOG(1D0/CUT-2D0)
76865 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
76866 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
76867
76868C...Interpolation in second/first order ratio for Zhu parametrization.
76869 ELSEIF(MSTJ(110).EQ.2) THEN
76870 IZA=0
76871 DO 110 IY=1,5
76872 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
76873 110 CONTINUE
76874 IF(IZA.NE.0) THEN
76875 ZHURAT=ZHUT(IZA)
76876 ELSE
76877 IZ=100D0*CUT
76878 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
76879 ENDIF
76880 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
76881 ENDIF
76882
76883C...Shift in second order three-jet cross-section with optimized Q^2.
76884 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
76885 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
76886 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
76887
76888C...Parametrization of second order four-jet cross-section.
76889 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
76890 PARJ(154)=0D0
76891 ELSE
76892 CT=LOG(1D0/CUT-5D0)
76893 IF(CUT.LE.0.018D0) THEN
76894 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
76895 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
76896 & 0.4059D0*CT**2)
76897 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
76898 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76899 ELSE
76900 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
76901 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
76902 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
76903 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
76904 & 0.002093D0*CT**3)
76905 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
76906 ENDIF
76907 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
76908 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
76909 ENDIF
76910
76911C...If negative three-jet rate, change y' optimization parameter.
76912 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
76913 & PARJ(169).LT.0.99D0) THEN
76914 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76915 Q2=PARJ(169)*ECM**2
76916 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76917 GOTO 100
76918 ENDIF
76919
76920C...If too high cross-section, use harder cuts, or fail.
76921 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
76922 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
76923 & PARJ(169).LT.0.99D0) THEN
76924 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
76925 Q2=PARJ(169)*ECM**2
76926 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
76927 GOTO 100
76928 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
76929 CALL PYERRM(26,
76930 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
76931 ENDIF
76932 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
76933 & PARJ(154))**(-1D0/3D0)
76934 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
76935 GOTO 100
76936 ENDIF
76937
76938C...Scalar gluon (first order only).
76939 ELSE
76940 ALSPI=PYALPS(ECM**2)/PARU(1)
76941 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
76942 PARJ(152)=0D0
76943 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
76944 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
76945 PARJ(153)=0D0
76946 PARJ(154)=0D0
76947 ENDIF
76948
76949C...Select number of jets.
76950 PARJ(150)=CUT
76951 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
76952 NJET=2
76953 ELSEIF(MSTJ(101).LE.0) THEN
76954 NJET=MIN(4,2-MSTJ(101))
76955 ELSE
76956 RNJ=PYR(0)
76957 NJET=2
76958 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
76959 IF(PARJ(154).GT.RNJ) NJET=4
76960 ENDIF
76961
76962 RETURN
76963 END
76964
76965C*********************************************************************
76966
76967C...PYX3JT
76968C...Selects the kinematical variables of three-jet events.
76969
76970 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
76971
76972C...Double precision and integer declarations.
76973 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76974 IMPLICIT INTEGER(I-N)
76975 INTEGER PYK,PYCHGE,PYCOMP
76976C...Commonblocks.
76977 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76978 SAVE /PYDAT1/
76979C...Local array.
76980 DIMENSION ZHUP(5,12)
76981
76982C...Coefficients of Zhu second order parametrization.
76983 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
76984 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
76985 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
76986 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
76987 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
76988 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
76989 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
76990 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
76991 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
76992 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
76993 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
76994
76995C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
76996 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
76997 &X**7/49D0
76998
76999C...Event type. Mass effect factors and other common constants.
77000 MSTJ(120)=2
77001 MSTJ(121)=0
77002 PMQ=PYMASS(KFL)
77003 QME=(2D0*PMQ/ECM)**2
77004 IF(MSTJ(109).NE.1) THEN
77005 CUTL=LOG(CUT)
77006 CUTD=LOG(1D0/CUT-2D0)
77007 IF(MSTJ(109).EQ.0) THEN
77008 CF=4D0/3D0
77009 CN=3D0
77010 TR=2D0
77011 WTMX=MIN(20D0,37D0-6D0*CUTD)
77012 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
77013 ELSE
77014 CF=1D0
77015 CN=0D0
77016 TR=12D0
77017 WTMX=0D0
77018 ENDIF
77019
77020C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
77021 ALS2PI=PARU(118)/PARU(2)
77022 WTOPT=0D0
77023 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
77024 & LOG(PARJ(169))*ALS2PI
77025 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
77026
77027C...Choose three-jet events in allowed region.
77028 100 NJET=3
77029 110 Y13L=CUTL+CUTD*PYR(0)
77030 Y23L=CUTL+CUTD*PYR(0)
77031 Y13=EXP(Y13L)
77032 Y23=EXP(Y23L)
77033 Y12=1D0-Y13-Y23
77034 IF(Y12.LE.CUT) GOTO 110
77035 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
77036
77037C...Second order corrections.
77038 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
77039 Y12L=LOG(Y12)
77040 Y13M=LOG(1D0-Y13)
77041 Y23M=LOG(1D0-Y23)
77042 Y12M=LOG(1D0-Y12)
77043 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
77044 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
77045 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
77046 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
77047 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
77048 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
77049 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
77050 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
77051 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
77052 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
77053 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
77054 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
77055 & TR*(2D0*CUTL/3D0-10D0/9D0)+
77056 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
77057 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
77058 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
77059 & Y13*Y23)/(Y12+Y13)**2)/WT1+
77060 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
77061 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
77062 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
77063 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
77064 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
77065 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
77066 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
77067 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77068 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77069 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
77070
77071 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
77072C...Second order corrections; Zhu parametrization of ERT.
77073 ZX=(Y23-Y13)**2
77074 ZY=1D0-Y12
77075 IZA=0
77076 DO 120 IY=1,5
77077 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
77078 120 CONTINUE
77079 IF(IZA.NE.0) THEN
77080 IZ=IZA
77081 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77082 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77083 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77084 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77085 ELSE
77086 IZ=100D0*CUT
77087 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77088 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77089 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77090 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77091 IZ=IZ+1
77092 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
77093 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
77094 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
77095 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
77096 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
77097 ENDIF
77098 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
77099 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
77100 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
77101 ENDIF
77102
77103C...Impose mass cuts (gives two jets). For fixed jet number new try.
77104 X1=1D0-Y23
77105 X2=1D0-Y13
77106 X3=1D0-Y12
77107 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
77108 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
77109 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
77110 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
77111 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
77112
77113C...Scalar gluon model (first order only, no mass effects).
77114 ELSE
77115 130 NJET=3
77116 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
77117 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
77118 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
77119 X1=1D0-0.5D0*(X3+YD)
77120 X2=1D0-0.5D0*(X3-YD)
77121 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
77122 IF(MSTJ(102).GE.2) THEN
77123 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
77124 & X3**2*PYR(0)) NJET=2
77125 ENDIF
77126 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
77127 ENDIF
77128
77129 RETURN
77130 END
77131
77132C*********************************************************************
77133
77134C...PYX4JT
77135C...Selects the kinematical variables of four-jet events.
77136
77137 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
77138
77139C...Double precision and integer declarations.
77140 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77141 IMPLICIT INTEGER(I-N)
77142 INTEGER PYK,PYCHGE,PYCOMP
77143C...Commonblocks.
77144 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77145 SAVE /PYDAT1/
77146C...Local arrays.
77147 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
77148
77149C...Common constants. Colour factors for QCD and Abelian gluon theory.
77150 PMQ=PYMASS(KFL)
77151 QME=(2D0*PMQ/ECM)**2
77152 CT=LOG(1D0/CUT-5D0)
77153 IF(MSTJ(109).EQ.0) THEN
77154 CF=4D0/3D0
77155 CN=3D0
77156 TR=2.5D0
77157 ELSE
77158 CF=1D0
77159 CN=0D0
77160 TR=15D0
77161 ENDIF
77162
77163C...Choice of process (qqbargg or qqbarqqbar).
77164 100 NJET=4
77165 IT=1
77166 IF(PARJ(155).GT.PYR(0)) IT=2
77167 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
77168 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
77169 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
77170 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
77171 ID=1
77172
77173C...Sample the five kinematical variables (for qqgg preweighted in y34).
77174 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77175 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
77176 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
77177 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
77178 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
77179 VT=PYR(0)
77180 CP=COS(PARU(1)*PYR(0))
77181 Y14=(Y134-Y34)*VT
77182 Y13=Y134-Y14-Y34
77183 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
77184 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
77185 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
77186 Y23=Y234-Y34-Y24
77187 Y12=1D0-Y134-Y23-Y24
77188 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
77189 Y123=Y12+Y13+Y23
77190 Y124=Y12+Y14+Y24
77191
77192C...Calculate matrix elements for qqgg or qqqq process.
77193 IC=0
77194 WTTOT=0D0
77195 120 IC=IC+1
77196 IF(IT.EQ.1) THEN
77197 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
77198 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
77199 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
77200 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
77201 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
77202 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
77203 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
77204 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
77205 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
77206 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
77207 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
77208 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
77209 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
77210 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
77211 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
77212 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
77213 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
77214 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
77215 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
77216 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
77217 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
77218 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
77219 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
77220 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
77221 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
77222 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
77223 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
77224 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
77225 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
77226 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
77227 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
77228 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
77229 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
77230 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
77231 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
77232 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
77233 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
77234 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
77235 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
77236 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
77237 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
77238 & CN*WTC(IC))/8D0
77239 ELSE
77240 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
77241 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
77242 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
77243 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
77244 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
77245 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
77246 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
77247 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
77248 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
77249 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
77250 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
77251 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
77252 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
77253 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
77254 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
77255 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
77256 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
77257 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
77258 ENDIF
77259
77260C...Permutations of momenta in matrix element. Weighting.
77261 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
77262 YSAV=Y13
77263 Y13=Y14
77264 Y14=YSAV
77265 YSAV=Y23
77266 Y23=Y24
77267 Y24=YSAV
77268 YSAV=Y123
77269 Y123=Y124
77270 Y124=YSAV
77271 ENDIF
77272 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
77273 YSAV=Y13
77274 Y13=Y23
77275 Y23=YSAV
77276 YSAV=Y14
77277 Y14=Y24
77278 Y24=YSAV
77279 YSAV=Y134
77280 Y134=Y234
77281 Y234=YSAV
77282 ENDIF
77283 IF(IC.LE.3) GOTO 120
77284 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
77285 IC=5
77286
77287C...qqgg events: string configuration and event type.
77288 IF(IT.EQ.1) THEN
77289 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
77290 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
77291 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
77292 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
77293 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
77294 IF(ID.EQ.2) GOTO 130
77295 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
77296 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
77297 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
77298 IF(ID.EQ.2) GOTO 130
77299 ENDIF
77300 MSTJ(120)=3
77301 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
77302 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
77303 KFLN=21
77304
77305C...Mass cuts. Kinematical variables out.
77306 IF(Y12.LE.CUT+QME) NJET=2
77307 IF(NJET.EQ.2) GOTO 150
77308 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
77309 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
77310 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
77311 X2=1D0-Y124
77312 X12=(1D0-Q12)*Y13+Q12*Y23
77313 X14=Y12-0.5D0*QME
77314 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77315
77316C...qqbarqqbar events: string configuration, choose new flavour.
77317 ELSE
77318 IF(ID.EQ.1) THEN
77319 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
77320 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
77321 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
77322 IF(WTR.LT.WTD(4)) ID=4
77323 IF(ID.GE.2) GOTO 130
77324 ENDIF
77325 MSTJ(120)=5
77326 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
77327 140 KFLN=1+INT(5D0*PYR(0))
77328 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
77329 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
77330 IF(KFLN.GT.MSTJ(104)) NJET=2
77331 PMQN=PYMASS(KFLN)
77332 QMEN=(2D0*PMQN/ECM)**2
77333
77334C...Mass cuts. Kinematical variables out.
77335 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
77336 IF(NJET.EQ.2) GOTO 150
77337 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
77338 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
77339 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
77340 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
77341 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
77342 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
77343 & Q13*Y23)
77344 X14=Y24-0.5D0*QME
77345 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
77346 & Q13*Y14)
77347 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
77348 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
77349 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
77350 ENDIF
77351 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
77352
77353 RETURN
77354 END
77355
77356C*********************************************************************
77357
77358C...PYXDIF
77359C...Gives the angular orientation of events.
77360
77361 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
77362
77363C...Double precision and integer declarations.
77364 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77365 IMPLICIT INTEGER(I-N)
77366 INTEGER PYK,PYCHGE,PYCOMP
77367C...Commonblocks.
77368 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77369 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77370 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77371 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77372
77373C...Charge. Factors depending on polarization for QED case.
77374 QF=KCHG(KFL,1)/3D0
77375 POLL=1D0-PARJ(131)*PARJ(132)
77376 POLD=PARJ(132)-PARJ(131)
77377 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
77378 HF1=POLL
77379 HF2=0D0
77380 HF3=PARJ(133)**2
77381 HF4=0D0
77382
77383C...Factors depending on flavour, energy and polarization for QFD case.
77384 ELSE
77385 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
77386 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
77387 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
77388 AE=-1D0
77389 VE=4D0*PARU(102)-1D0
77390 AF=SIGN(1D0,QF)
77391 VF=AF-4D0*QF*PARU(102)
77392 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
77393 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
77394 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
77395 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
77396 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
77397 & SFW*SFF**2*(VE**2-AE**2))
77398 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
77399 & SFF*AE
77400 ENDIF
77401
77402C...Mass factor. Differential cross-sections for two-jet events.
77403 SQ2=SQRT(2D0)
77404 QME=0D0
77405 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
77406 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
77407 IF(NJET.EQ.2) THEN
77408 SIGU=4D0*SQRT(1D0-QME)
77409 SIGL=2D0*QME*SQRT(1D0-QME)
77410 SIGT=0D0
77411 SIGI=0D0
77412 SIGA=0D0
77413 SIGP=4D0
77414
77415C...Kinematical variables. Reduce four-jet event to three-jet one.
77416 ELSE
77417 IF(NJET.EQ.3) THEN
77418 X1=2D0*P(NC+1,4)/ECM
77419 X2=2D0*P(NC+3,4)/ECM
77420 ELSE
77421 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
77422 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
77423 X1=2D0*P(NC+1,4)/ECMR
77424 X2=2D0*P(NC+4,4)/ECMR
77425 ENDIF
77426
77427C...Differential cross-sections for three-jet (or reduced four-jet).
77428 XQ=(1D0-X1)/(1D0-X2)
77429 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
77430 ST12=SQRT(1D0-CT12**2)
77431 IF(MSTJ(109).NE.1) THEN
77432 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
77433 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
77434 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
77435 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
77436 & X2)*XQ
77437 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
77438 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
77439 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
77440 SIGA=X2**2*ST12/SQ2
77441 SIGP=2D0*(X1**2-X2**2*CT12)
77442
77443C...Differential cross-sect for scalar gluons (no mass effects).
77444 ELSE
77445 X3=2D0-X1-X2
77446 XT=X2*ST12
77447 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
77448 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
77449 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
77450 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
77451 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
77452 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
77453 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
77454 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
77455 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
77456 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
77457 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
77458 ENDIF
77459 ENDIF
77460
77461C...Upper bounds for differential cross-section.
77462 HF1A=ABS(HF1)
77463 HF2A=ABS(HF2)
77464 HF3A=ABS(HF3)
77465 HF4A=ABS(HF4)
77466 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
77467 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
77468 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
77469 &2D0*HF2A*ABS(SIGP)
77470
77471C...Generate angular orientation according to differential cross-sect.
77472 100 CHI=PARU(2)*PYR(0)
77473 CTHE=2D0*PYR(0)-1D0
77474 PHI=PARU(2)*PYR(0)
77475 CCHI=COS(CHI)
77476 SCHI=SIN(CHI)
77477 C2CHI=COS(2D0*CHI)
77478 S2CHI=SIN(2D0*CHI)
77479 THE=ACOS(CTHE)
77480 STHE=SIN(THE)
77481 C2PHI=COS(2D0*(PHI-PARJ(134)))
77482 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77483 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
77484 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
77485 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
77486 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
77487 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
77488 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
77489 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
77490 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
77491
77492 RETURN
77493 END
77494
77495C*********************************************************************
77496
77497C...PYONIA
77498C...Generates Upsilon and toponium decays into three gluons
77499C...or two gluons and a photon.
77500
77501 SUBROUTINE PYONIA(KFL,ECM)
77502
77503C...Double precision and integer declarations.
77504 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77505 IMPLICIT INTEGER(I-N)
77506 INTEGER PYK,PYCHGE,PYCOMP
77507C...Commonblocks.
77508 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77509 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77510 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77511 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77512
77513C...Printout. Check input parameters.
77514 IF(MSTU(12).NE.12345) CALL PYLIST(0)
77515 IF(KFL.LT.0.OR.KFL.GT.8) THEN
77516 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
77517 IF(MSTU(21).GE.1) RETURN
77518 ENDIF
77519 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
77520 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
77521 IF(MSTU(21).GE.1) RETURN
77522 ENDIF
77523
77524C...Initial e+e- and onium state (optional).
77525 NC=0
77526 IF(MSTJ(115).GE.2) THEN
77527 NC=NC+2
77528 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
77529 K(NC-1,1)=21
77530 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
77531 K(NC,1)=21
77532 ENDIF
77533 KFLC=IABS(KFL)
77534 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
77535 NC=NC+1
77536 KF=110*KFLC+3
77537 MSTU10=MSTU(10)
77538 MSTU(10)=1
77539 P(NC,5)=ECM
77540 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
77541 K(NC,1)=21
77542 K(NC,3)=1
77543 MSTU(10)=MSTU10
77544 ENDIF
77545
77546C...Choose x1 and x2 according to matrix element.
77547 NTRY=0
77548 100 X1=PYR(0)
77549 X2=PYR(0)
77550 X3=2D0-X1-X2
77551 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
77552 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
77553 NTRY=NTRY+1
77554 NJET=3
77555 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
77556 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
77557
77558C...Photon-gluon-gluon events. Small system modifications. Jet origin.
77559 MSTU(111)=MSTJ(108)
77560 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
77561 &MSTU(111)=1
77562 PARU(112)=PARJ(121)
77563 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
77564 QF=0D0
77565 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
77566 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
77567 MK=0
77568 ECMC=ECM
77569 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
77570 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
77571 & NJET=2
77572 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
77573 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
77574 ELSE
77575 MK=1
77576 ECMC=SQRT(1D0-X1)*ECM
77577 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
77578 K(NC+1,1)=1
77579 K(NC+1,2)=22
77580 K(NC+1,4)=0
77581 K(NC+1,5)=0
77582 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
77583 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
77584 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
77585 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
77586 NJET=2
77587 IF(ECMC.LT.4D0*PARJ(127)) THEN
77588 MSTU10=MSTU(10)
77589 MSTU(10)=1
77590 P(NC+2,5)=ECMC
77591 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
77592 MSTU(10)=MSTU10
77593 NJET=0
77594 ENDIF
77595 ENDIF
77596 DO 110 IP=NC+1,N
77597 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
77598 110 CONTINUE
77599
77600C...Differential cross-sections. Upper limit for cross-section.
77601 IF(MSTJ(106).EQ.1) THEN
77602 SQ2=SQRT(2D0)
77603 HF1=1D0-PARJ(131)*PARJ(132)
77604 HF3=PARJ(133)**2
77605 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
77606 ST13=SQRT(1D0-CT13**2)
77607 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
77608 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
77609 SIGT=0.5D0*SIGL
77610 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
77611 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
77612 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
77613
77614C...Angular orientation of event.
77615 120 CHI=PARU(2)*PYR(0)
77616 CTHE=2D0*PYR(0)-1D0
77617 PHI=PARU(2)*PYR(0)
77618 CCHI=COS(CHI)
77619 SCHI=SIN(CHI)
77620 C2CHI=COS(2D0*CHI)
77621 S2CHI=SIN(2D0*CHI)
77622 THE=ACOS(CTHE)
77623 STHE=SIN(THE)
77624 C2PHI=COS(2D0*(PHI-PARJ(134)))
77625 S2PHI=SIN(2D0*(PHI-PARJ(134)))
77626 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
77627 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
77628 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
77629 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
77630 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
77631 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
77632 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
77633 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
77634 ENDIF
77635
77636C...Generate parton shower. Rearrange along strings and check.
77637 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
77638 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
77639 MSTJ14=MSTJ(14)
77640 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
77641 IF(MSTJ(105).GE.0) MSTU(28)=0
77642 CALL PYPREP(0)
77643 MSTJ(14)=MSTJ14
77644 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
77645 ENDIF
77646
77647C...Generate fragmentation. Information for PYTABU:
77648 IF(MSTJ(105).EQ.1) CALL PYEXEC
77649 MSTU(161)=110*KFLC+3
77650 MSTU(162)=0
77651
77652 RETURN
77653 END
77654
77655C*********************************************************************
77656
77657C...PYBOOK
77658C...Books a histogram.
77659
77660 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
77661
77662C...Double precision declaration.
77663 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77664 IMPLICIT INTEGER(I-N)
77665C...Commonblock.
77666 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77667 SAVE /PYBINS/
77668C...Local character variables.
77669 CHARACTER TITLE*(*), TITFX*60
77670
77671C...Check that input is sensible. Find initial address in memory.
77672 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77673 &'(PYBOOK:) not allowed histogram number')
77674 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
77675 &'(PYBOOK:) not allowed number of bins')
77676 IF(XL.GE.XU) CALL PYERRM(28,
77677 &'(PYBOOK:) x limits in wrong order')
77678 INDX(ID)=IHIST(4)
77679 IHIST(4)=IHIST(4)+28+NX
77680 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
77681 &'(PYBOOK:) out of histogram space')
77682 IS=INDX(ID)
77683
77684C...Store histogram size and reset contents.
77685 BIN(IS+1)=NX
77686 BIN(IS+2)=XL
77687 BIN(IS+3)=XU
77688 BIN(IS+4)=(XU-XL)/NX
77689 CALL PYNULL(ID)
77690
77691C...Store title by conversion to integer to double precision.
77692 TITFX=TITLE//' '
77693 DO 100 IT=1,20
77694 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
77695 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
77696 100 CONTINUE
77697
77698 RETURN
77699 END
77700
77701C*********************************************************************
77702
77703C...PYFILL
77704C...Fills entry in histogram.
77705
77706 SUBROUTINE PYFILL(ID,X,W)
77707
77708C...Double precision declaration.
77709 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77710 IMPLICIT INTEGER(I-N)
77711C...Commonblock.
77712 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77713 SAVE /PYBINS/
77714
77715C...Find initial address in memory. Increase number of entries.
77716 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77717 &'(PYFILL:) not allowed histogram number')
77718 IS=INDX(ID)
77719 IF(IS.EQ.0) CALL PYERRM(28,
77720 &'(PYFILL:) filling unbooked histogram')
77721 BIN(IS+5)=BIN(IS+5)+1D0
77722
77723C...Find bin in x, including under/overflow, and fill.
77724 IF(X.LT.BIN(IS+2)) THEN
77725 BIN(IS+6)=BIN(IS+6)+W
77726 ELSEIF(X.GE.BIN(IS+3)) THEN
77727 BIN(IS+8)=BIN(IS+8)+W
77728 ELSE
77729 BIN(IS+7)=BIN(IS+7)+W
77730 IX=(X-BIN(IS+2))/BIN(IS+4)
77731 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
77732 BIN(IS+9+IX)=BIN(IS+9+IX)+W
77733 ENDIF
77734
77735 RETURN
77736 END
77737
77738C*********************************************************************
77739
77740C...PYFACT
77741C...Multiplies histogram contents by factor.
77742
77743 SUBROUTINE PYFACT(ID,F)
77744
77745C...Double precision declaration.
77746 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77747 IMPLICIT INTEGER(I-N)
77748C...Commonblock.
77749 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77750 SAVE /PYBINS/
77751
77752C...Find initial address in memory. Multiply all contents bins.
77753 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
77754 &'(PYFACT:) not allowed histogram number')
77755 IS=INDX(ID)
77756 IF(IS.EQ.0) CALL PYERRM(28,
77757 &'(PYFACT:) scaling unbooked histogram')
77758 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
77759 BIN(IX)=F*BIN(IX)
77760 100 CONTINUE
77761
77762 RETURN
77763 END
77764
77765C*********************************************************************
77766
77767C...PYOPER
77768C...Performs operations between histograms.
77769
77770 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
77771
77772C...Double precision declaration.
77773 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77774 IMPLICIT INTEGER(I-N)
77775C...Commonblock.
77776 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77777 SAVE /PYBINS/
77778C...Character variable.
77779 CHARACTER OPER*(*)
77780
77781C...Find initial addresses in memory, and histogram size.
77782 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
77783 &'(PYFACT:) not allowed histogram number')
77784 IS1=INDX(ID1)
77785 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
77786 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
77787 NX=NINT(BIN(IS3+1))
77788 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
77789
77790C...Update info on number of histogram entries.
77791 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
77792 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
77793 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
77794 BIN(IS3+5)=BIN(IS1+5)
77795 ENDIF
77796
77797C...Operations on pair of histograms: addition, subtraction,
77798C...multiplication, division.
77799 IF(OPER.EQ.'+') THEN
77800 DO 100 IX=6,8+NX
77801 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
77802 100 CONTINUE
77803 ELSEIF(OPER.EQ.'-') THEN
77804 DO 110 IX=6,8+NX
77805 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
77806 110 CONTINUE
77807 ELSEIF(OPER.EQ.'*') THEN
77808 DO 120 IX=6,8+NX
77809 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
77810 120 CONTINUE
77811 ELSEIF(OPER.EQ.'/') THEN
77812 DO 130 IX=6,8+NX
77813 FA2=F2*BIN(IS2+IX)
77814 IF(ABS(FA2).LE.1D-20) THEN
77815 BIN(IS3+IX)=0D0
77816 ELSE
77817 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
77818 ENDIF
77819 130 CONTINUE
77820
77821C...Operations on single histogram: multiplication+addition,
77822C...square root+addition, logarithm+addition.
77823 ELSEIF(OPER.EQ.'A') THEN
77824 DO 140 IX=6,8+NX
77825 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
77826 140 CONTINUE
77827 ELSEIF(OPER.EQ.'S') THEN
77828 DO 150 IX=6,8+NX
77829 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
77830 150 CONTINUE
77831 ELSEIF(OPER.EQ.'L') THEN
77832 ZMIN=1D20
77833 DO 160 IX=9,8+NX
77834 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
77835 & ZMIN=0.8D0*BIN(IS1+IX)
77836 160 CONTINUE
77837 DO 170 IX=6,8+NX
77838 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
77839 170 CONTINUE
77840
77841C...Operation on two or three histograms: average and
77842C...standard deviation.
77843 ELSEIF(OPER.EQ.'M') THEN
77844 DO 180 IX=6,8+NX
77845 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77846 BIN(IS2+IX)=0D0
77847 ELSE
77848 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
77849 ENDIF
77850 IF(ID3.NE.0) THEN
77851 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
77852 BIN(IS3+IX)=0D0
77853 ELSE
77854 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
77855 & BIN(IS2+IX)**2))
77856 ENDIF
77857 ENDIF
77858 BIN(IS1+IX)=F1*BIN(IS1+IX)
77859 180 CONTINUE
77860 ENDIF
77861
77862 RETURN
77863 END
77864
77865C*********************************************************************
77866
77867C...PYHIST
77868C...Prints and resets all histograms.
77869
77870 SUBROUTINE PYHIST
77871
77872C...Double precision declaration.
77873 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77874 IMPLICIT INTEGER(I-N)
77875C...Commonblock.
77876 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77877 SAVE /PYBINS/
77878
77879C...Loop over histograms, print and reset used ones.
77880 DO 100 ID=1,IHIST(1)
77881 IS=INDX(ID)
77882 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
77883 CALL PYPLOT(ID)
77884 CALL PYNULL(ID)
77885 ENDIF
77886 100 CONTINUE
77887
77888 RETURN
77889 END
77890
77891C*********************************************************************
77892
77893C...PYPLOT
77894C...Prints a histogram (but does not reset it).
77895
77896 SUBROUTINE PYPLOT(ID)
77897
77898C...Double precision declaration.
77899 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77900 IMPLICIT INTEGER(I-N)
77901C...Commonblocks.
77902 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77903 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
77904 SAVE /PYDAT1/,/PYBINS/
77905C...Local arrays and character variables.
77906 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
77907 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
77908
77909C...Steps in histogram scale. Character sequence.
77910 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
77911 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
77912
77913C...Find initial address in memory; skip if empty histogram.
77914 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
77915 IS=INDX(ID)
77916 IF(IS.EQ.0) RETURN
77917 IF(NINT(BIN(IS+5)).LE.0) THEN
77918 WRITE(MSTU(11),5000) ID
77919 RETURN
77920 ENDIF
77921
77922C...Number of histogram lines and x bins.
77923 LIN=IHIST(3)-18
77924 NX=NINT(BIN(IS+1))
77925
77926C...Extract title by conversion from double precision via integer.
77927 DO 100 IT=1,20
77928 IEQ=NINT(BIN(IS+8+NX+IT))
77929 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
77930 & //CHAR(MOD(IEQ,256))
77931 100 CONTINUE
77932
77933C...Find time; print title.
77934 CALL PYTIME(IDATI)
77935 IF(IDATI(1).GT.0) THEN
77936 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
77937 ELSE
77938 WRITE(MSTU(11),5200) ID, TITLE
77939 ENDIF
77940
77941C...Find minimum and maximum bin content.
77942 YMIN=BIN(IS+9)
77943 YMAX=BIN(IS+9)
77944 DO 110 IX=IS+10,IS+8+NX
77945 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
77946 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
77947 110 CONTINUE
77948
77949C...Determine scale and step size for y axis.
77950 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
77951 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
77952 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
77953 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
77954 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
77955 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
77956 DELY=DYAC(1)
77957 DO 120 IDEL=1,9
77958 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
77959 120 CONTINUE
77960 DY=DELY*10D0**IPOT
77961
77962C...Convert bin contents to integer form; fractional fill in top row.
77963 DO 130 IX=1,NX
77964 CTA=ABS(BIN(IS+8+IX))/DY
77965 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
77966 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
77967 130 CONTINUE
77968 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
77969 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
77970
77971C...Print histogram row by row.
77972 DO 150 IR=IRMA,IRMI,-1
77973 IF(IR.EQ.0) GOTO 150
77974 OUT=' '
77975 DO 140 IX=1,NX
77976 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
77977 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
77978 140 CONTINUE
77979 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
77980 150 CONTINUE
77981
77982C...Print sign and value of bin contents.
77983 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
77984 OUT=' '
77985 DO 160 IX=1,NX
77986 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
77987 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
77988 160 CONTINUE
77989 WRITE(MSTU(11),5400) OUT
77990 DO 180 IR=4,1,-1
77991 DO 170 IX=1,NX
77992 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
77993 170 CONTINUE
77994 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
77995 180 CONTINUE
77996
77997C...Print sign and value of lower bin edge.
77998 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
77999 & 10.0001D0)-10
78000 OUT=' '
78001 DO 190 IX=1,NX
78002 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
78003 & OUT(IX:IX)=CHA(11)
78004 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
78005 190 CONTINUE
78006 WRITE(MSTU(11),5600) OUT
78007 DO 210 IR=3,1,-1
78008 DO 200 IX=1,NX
78009 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
78010 200 CONTINUE
78011 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
78012 210 CONTINUE
78013 ENDIF
78014
78015C...Calculate and print statistics.
78016 CSUM=0D0
78017 CXSUM=0D0
78018 CXXSUM=0D0
78019 DO 220 IX=1,NX
78020 CTA=ABS(BIN(IS+8+IX))
78021 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
78022 CSUM=CSUM+CTA
78023 CXSUM=CXSUM+CTA*X
78024 CXXSUM=CXXSUM+CTA*X**2
78025 220 CONTINUE
78026 XMEAN=CXSUM/MAX(CSUM,1D-20)
78027 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
78028 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
78029 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
78030
78031C...Formats for output.
78032 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
78033 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
78034 &I2,':',I2/)
78035 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
78036 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
78037 5400 FORMAT(/8X,'Contents',3X,A100)
78038 5500 FORMAT(9X,'*10**',I2,3X,A100)
78039 5600 FORMAT(/8X,'Low edge',3X,A100)
78040 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
78041 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
78042 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
78043
78044 RETURN
78045 END
78046
78047C*********************************************************************
78048
78049C...PYNULL
78050C...Resets bin contents of a histogram.
78051
78052 SUBROUTINE PYNULL(ID)
78053
78054C...Double precision declaration.
78055 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78056 IMPLICIT INTEGER(I-N)
78057C...Commonblock.
78058 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78059 SAVE /PYBINS/
78060
78061 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
78062 IS=INDX(ID)
78063 IF(IS.EQ.0) RETURN
78064 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
78065 BIN(IX)=0D0
78066 100 CONTINUE
78067
78068 RETURN
78069 END
78070
78071C*********************************************************************
78072
78073C...PYDUMP
78074C...Dumps histogram contents on file for reading by other program.
78075C...Can also read back own dump.
78076
78077 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
78078
78079C...Double precision declaration.
78080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78081 IMPLICIT INTEGER(I-N)
78082C...Commonblock.
78083 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
78084 SAVE /PYBINS/
78085C...Local arrays and character variables.
78086 DIMENSION IHI(*),ISS(100),VAL(5)
78087 CHARACTER TITLE*60,FORMAT*13
78088
78089C...Dump all histograms that have been booked,
78090C...including titles and ranges, one after the other.
78091 IF(MDUMP.EQ.1) THEN
78092
78093C...Loop over histograms and find which are wanted and booked.
78094 IF(NHI.LE.0) THEN
78095 NW=IHIST(1)
78096 ELSE
78097 NW=NHI
78098 ENDIF
78099 DO 130 IW=1,NW
78100 IF(NHI.EQ.0) THEN
78101 ID=IW
78102 ELSE
78103 ID=IHI(IW)
78104 ENDIF
78105 IS=INDX(ID)
78106 IF(IS.NE.0) THEN
78107
78108C...Write title, histogram size, filling statistics.
78109 NX=NINT(BIN(IS+1))
78110 DO 100 IT=1,20
78111 IEQ=NINT(BIN(IS+8+NX+IT))
78112 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
78113 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
78114 100 CONTINUE
78115 WRITE(LFN,5100) ID,TITLE
78116 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
78117 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
78118 & BIN(IS+8)
78119
78120
78121C...Write histogram contents, in groups of five.
78122 DO 120 IXG=1,(NX+4)/5
78123 DO 110 IXV=1,5
78124 IX=5*IXG+IXV-5
78125 IF(IX.LE.NX) THEN
78126 VAL(IXV)=BIN(IS+8+IX)
78127 ELSE
78128 VAL(IXV)=0D0
78129 ENDIF
78130 110 CONTINUE
78131 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
78132 120 CONTINUE
78133
78134C...Go to next histogram; finish.
78135 ELSEIF(NHI.GT.0) THEN
78136 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78137 ENDIF
78138 130 CONTINUE
78139
78140C...Read back in histograms dumped MDUMP=1.
78141 ELSEIF(MDUMP.EQ.2) THEN
78142
78143C...Read histogram number, title and range, and book.
78144 140 READ(LFN,5100,END=170) ID,TITLE
78145 READ(LFN,5200) NX,XL,XU
78146 CALL PYBOOK(ID,TITLE,NX,XL,XU)
78147 IS=INDX(ID)
78148
78149C...Read filling statistics.
78150 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
78151 BIN(IS+5)=DBLE(NENTRY)
78152
78153C...Read histogram contents, in groups of five.
78154 DO 160 IXG=1,(NX+4)/5
78155 READ(LFN,5400) (VAL(IXV),IXV=1,5)
78156 DO 150 IXV=1,5
78157 IX=5*IXG+IXV-5
78158 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
78159 150 CONTINUE
78160 160 CONTINUE
78161
78162C...Go to next histogram; finish.
78163 GOTO 140
78164 170 CONTINUE
78165
78166C...Write histogram contents in column format,
78167C...convenient e.g. for GNUPLOT input.
78168 ELSEIF(MDUMP.EQ.3) THEN
78169
78170C...Find addresses to wanted histograms.
78171 NSS=0
78172 IF(NHI.LE.0) THEN
78173 NW=IHIST(1)
78174 ELSE
78175 NW=NHI
78176 ENDIF
78177 DO 180 IW=1,NW
78178 IF(NHI.EQ.0) THEN
78179 ID=IW
78180 ELSE
78181 ID=IHI(IW)
78182 ENDIF
78183 IS=INDX(ID)
78184 IF(IS.NE.0.AND.NSS.LT.100) THEN
78185 NSS=NSS+1
78186 ISS(NSS)=IS
78187 ELSEIF(NSS.GE.100) THEN
78188 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
78189 ELSEIF(NHI.GT.0) THEN
78190 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
78191 ENDIF
78192 180 CONTINUE
78193
78194C...Check that they have common number of x bins. Fix format.
78195 NX=NINT(BIN(ISS(1)+1))
78196 DO 190 IW=2,NSS
78197 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
78198 CALL PYERRM(8,'(PYDUMP:) different number of bins')
78199 RETURN
78200 ENDIF
78201 190 CONTINUE
78202 FORMAT='(1P,000E12.4)'
78203 WRITE(FORMAT(5:7),'(I3)') NSS+1
78204
78205C...Write histogram contents; first column x values.
78206 DO 200 IX=1,NX
78207 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
78208 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
78209 200 CONTINUE
78210
78211 ENDIF
78212
78213C...Formats for output.
78214 5100 FORMAT(I5,5X,A60)
78215 5200 FORMAT(I5,1P,2D12.4)
78216 5300 FORMAT(I12,1P,3D12.4)
78217 5400 FORMAT(1P,5D12.4)
78218
78219 RETURN
78220 END
78221
78222C*********************************************************************
78223
78224C...PYSTOP
78225C...Allows users to handle STOP statemens
78226
78227 SUBROUTINE PYSTOP(MCOD)
78228
78229C...Double precision and integer declarations.
78230 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78231 IMPLICIT INTEGER(I-N)
78232 INTEGER PYK,PYCHGE,PYCOMP
78233C...Commonblocks.
78234 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78235 SAVE /PYDAT1/
78236
78237
78238C...Write message, then stop
78239 WRITE(MSTU(11),5000) MCOD
78240 STOP
78241
78242
78243C...Formats for output.
78244 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
78245 END
78246
78247C*********************************************************************
78248
78249C...PYKCUT
78250C...Dummy routine, which the user can replace in order to make cuts on
78251C...the kinematics on the parton level before the matrix elements are
78252C...evaluated and the event is generated. The cross-section estimates
78253C...will automatically take these cuts into account, so the given
78254C...values are for the allowed phase space region only. MCUT=0 means
78255C...that the event has passed the cuts, MCUT=1 that it has failed.
78256
78257 SUBROUTINE PYKCUT(MCUT)
78258
78259C...Double precision and integer declarations.
78260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78261 IMPLICIT INTEGER(I-N)
78262 INTEGER PYK,PYCHGE,PYCOMP
78263C...Commonblocks.
78264 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78265 COMMON/PYINT1/MINT(400),VINT(400)
78266 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78267 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78268
78269C...Set default value (accepting event) for MCUT.
78270 MCUT=0
78271
78272C...Read out subprocess number.
78273 ISUB=MINT(1)
78274 ISTSB=ISET(ISUB)
78275
78276C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78277 TAU=VINT(21)
78278 YST=VINT(22)
78279 CTH=0D0
78280 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78281 TAUP=0D0
78282 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78283
78284C...Calculate x_1, x_2, x_F.
78285 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
78286 X1=SQRT(TAU)*EXP(YST)
78287 X2=SQRT(TAU)*EXP(-YST)
78288 ELSE
78289 X1=SQRT(TAUP)*EXP(YST)
78290 X2=SQRT(TAUP)*EXP(-YST)
78291 ENDIF
78292 XF=X1-X2
78293
78294C...Calculate shat, that, uhat, p_T^2.
78295 SHAT=TAU*VINT(2)
78296 SQM3=VINT(63)
78297 SQM4=VINT(64)
78298 RM3=SQM3/SHAT
78299 RM4=SQM4/SHAT
78300 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
78301 RPTS=4D0*VINT(71)**2/SHAT
78302 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
78303 RM34=2D0*RM3*RM4
78304 RSQM=1D0+RM34
78305 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
78306 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
78307 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
78308 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
78309
78310C...Decisions by user to be put here.
78311
78312C...Stop program if this routine is ever called.
78313C...You should not copy these lines to your own routine.
78314 WRITE(MSTU(11),5000)
78315 CALL PYSTOP(6)
78316
78317C...Format for error printout.
78318 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
78319 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78320 &1X,'Execution stopped!')
78321
78322 RETURN
78323 END
78324
78325C*********************************************************************
78326
78327C...PYEVWT
78328C...Dummy routine, which the user can replace in order to multiply the
78329C...standard PYTHIA differential cross-section by a process- and
78330C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
78331C...to generation of weighted events, with weight 1/WTXS, while for
78332C...MSTP(142)=2 it corresponds to a modification of the underlying
78333C...physics.
78334
78335 SUBROUTINE PYEVWT(WTXS)
78336
78337C...Double precision and integer declarations.
78338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78339 IMPLICIT INTEGER(I-N)
78340 INTEGER PYK,PYCHGE,PYCOMP
78341C...Commonblocks.
78342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78343 COMMON/PYINT1/MINT(400),VINT(400)
78344 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
78345 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
78346
78347C...Set default weight for WTXS.
78348 WTXS=1D0
78349
78350C...Read out subprocess number.
78351 ISUB=MINT(1)
78352 ISTSB=ISET(ISUB)
78353
78354C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
78355 TAU=VINT(21)
78356 YST=VINT(22)
78357 CTH=0D0
78358 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
78359 TAUP=0D0
78360 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
78361
78362C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
78363 X1=VINT(41)
78364 X2=VINT(42)
78365 XF=X1-X2
78366 SHAT=VINT(44)
78367 THAT=VINT(45)
78368 UHAT=VINT(46)
78369 PT2=VINT(48)
78370
78371C...Modifications by user to be put here.
78372
78373C...Stop program if this routine is ever called.
78374C...You should not copy these lines to your own routine.
78375 WRITE(MSTU(11),5000)
78376 CALL PYSTOP(4)
78377
78378C...Format for error printout.
78379 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
78380 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78381 &1X,'Execution stopped!')
78382
78383 RETURN
78384 END
78385
78386C*********************************************************************
78387
78388C...UPINIT
78389C...Dummy routine, to be replaced by a user implementing external
78390C...processes. Is supposed to fill the HEPRUP commonblock with info
78391C...on incoming beams and allowed processes.
78392
78393C...New example: handles a standard Les Houches Events File.
78394
78395 SUBROUTINE UPINIT
78396
78397C...Double precision and integer declarations.
78398 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78399 IMPLICIT INTEGER(I-N)
78400
78401C...PYTHIA commonblock: only used to provide read unit MSTP(161).
78402 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78403 SAVE /PYPARS/
78404
78405C...User process initialization commonblock.
78406 INTEGER MAXPUP
78407 PARAMETER (MAXPUP=100)
78408 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78409 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78410 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78411 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78412 &LPRUP(MAXPUP)
78413 SAVE /HEPRUP/
78414
78415C...Lines to read in assumed never longer than 200 characters.
78416 PARAMETER (MAXLEN=200)
78417 CHARACTER*(MAXLEN) STRING
78418
78419C...Format for reading lines.
78420 CHARACTER*6 STRFMT
78421 STRFMT='(A000)'
78422 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78423
78424C...Loop until finds line beginning with "<init>" or "<init ".
78425 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
78426 IBEG=0
78427 110 IBEG=IBEG+1
78428C...Allow indentation.
78429 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
78430 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
78431 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
78432
78433C...Read first line of initialization info.
78434 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
78435 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78436
78437C...Read NPRUP subsequent lines with information on each process.
78438 DO 120 IPR=1,NPRUP
78439 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
78440 & XMAXUP(IPR),LPRUP(IPR)
78441 120 CONTINUE
78442 RETURN
78443
78444C...Error exit: give up if initalization does not work.
78445 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
78446 WRITE(*,*) ' Event generation will be stopped.'
78447 CALL PYSTOP(12)
78448
78449 RETURN
78450 END
78451
78452C...Old example: handles a simple Pythia 6.4 initialization file.
78453
78454c SUBROUTINE UPINIT
78455
78456C...Double precision and integer declarations.
78457c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78458c IMPLICIT INTEGER(I-N)
78459
78460C...Commonblocks.
78461c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78462c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78463c SAVE /PYDAT1/,/PYPARS/
78464
78465C...User process initialization commonblock.
78466c INTEGER MAXPUP
78467c PARAMETER (MAXPUP=100)
78468c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
78469c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
78470c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
78471c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
78472c &LPRUP(MAXPUP)
78473c SAVE /HEPRUP/
78474
78475C...Read info from file.
78476c IF(MSTP(161).GT.0) THEN
78477c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
78478c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
78479c DO 100 IPR=1,NPRUP
78480c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
78481c & XMAXUP(IPR),LPRUP(IPR)
78482c 100 CONTINUE
78483c RETURN
78484C...Error or prematurely reached end of file.
78485c 110 WRITE(MSTU(11),5000)
78486c STOP
78487
78488C...Else not implemented.
78489c ELSE
78490c WRITE(MSTU(11),5100)
78491c STOP
78492c ENDIF
78493
78494C...Format for error printout.
78495c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
78496c &1X,'Execution stopped!')
78497c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
78498c &1X,'Dummy routine in PYTHIA file called instead.'/
78499c &1X,'Execution stopped!')
78500
78501c RETURN
78502c END
78503
78504C*********************************************************************
78505
78506C...UPEVNT
78507C...Dummy routine, to be replaced by a user implementing external
78508C...processes. Depending on cross section model chosen, it either has
78509C...to generate a process of the type IDPRUP requested, or pick a type
78510C...itself and generate this event. The event is to be stored in the
78511C...HEPEUP commonblock, including (often) an event weight.
78512
78513C...New example: handles a standard Les Houches Events File.
78514
78515 SUBROUTINE UPEVNT
78516
78517C...Double precision and integer declarations.
78518 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78519 IMPLICIT INTEGER(I-N)
78520
78521C...PYTHIA commonblock: only used to provide read unit MSTP(162).
78522 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78523 SAVE /PYPARS/
78524
78525C...User process event common block.
78526 INTEGER MAXNUP
78527 PARAMETER (MAXNUP=500)
78528 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78529 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78530 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78531 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78532 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78533 SAVE /HEPEUP/
78534
78535C...Lines to read in assumed never longer than 200 characters.
78536 PARAMETER (MAXLEN=200)
78537 CHARACTER*(MAXLEN) STRING
78538
78539C...Format for reading lines.
78540 CHARACTER*6 STRFMT
78541 STRFMT='(A000)'
78542 WRITE(STRFMT(3:5),'(I3)') MAXLEN
78543
78544C...Loop until finds line beginning with "<event>" or "<event ".
78545 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
78546 IBEG=0
78547 110 IBEG=IBEG+1
78548C...Allow indentation.
78549 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
78550 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
78551 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
78552
78553C...Read first line of event info.
78554 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
78555 &AQEDUP,AQCDUP
78556
78557C...Read NUP subsequent lines with information on each particle.
78558 DO 120 I=1,NUP
78559 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
78560 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78561 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78562 120 CONTINUE
78563 RETURN
78564
78565C...Error exit, typically when no more events.
78566 130 WRITE(*,*) ' Failed to read LHEF event information.'
78567 WRITE(*,*) ' Will assume end of file has been reached.'
78568 NUP=0
78569 MSTI(51)=1
78570
78571 RETURN
78572 END
78573
78574C...Old example: handles a simple Pythia 6.4 event file.
78575
78576c SUBROUTINE UPEVNT
78577
78578C...Double precision and integer declarations.
78579c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78580c IMPLICIT INTEGER(I-N)
78581
78582C...Commonblocks.
78583c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78584c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
78585c SAVE /PYDAT1/,/PYPARS/
78586
78587C...User process event common block.
78588c INTEGER MAXNUP
78589c PARAMETER (MAXNUP=500)
78590c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
78591c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
78592c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
78593c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
78594c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
78595c SAVE /HEPEUP/
78596
78597C...Read info from file.
78598c IF(MSTP(162).GT.0) THEN
78599c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
78600c & AQEDUP,AQCDUP
78601c DO 100 I=1,NUP
78602c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
78603c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
78604c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
78605c 100 CONTINUE
78606c RETURN
78607C...Special when reached end of file or other error.
78608c 110 NUP=0
78609
78610C...Else not implemented.
78611c ELSE
78612c WRITE(MSTU(11),5000)
78613c STOP
78614c ENDIF
78615
78616C...Format for error printout.
78617c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
78618c &1X,'Dummy routine in PYTHIA file called instead.'/
78619c &1X,'Execution stopped!')
78620
78621c RETURN
78622c END
78623
78624C*********************************************************************
78625
78626C...UPVETO
78627C...Dummy routine, to be replaced by user, to veto event generation
78628C...on the parton level, after parton showers but before multiple
78629C...interactions, beam remnants and hadronization is added.
78630C...If resonances like W, Z, top, Higgs and SUSY particles are handed
78631C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
78632C...be undecayed at this stage; if decayed their decay products will
78633C...have been allowed to shower.
78634
78635C...All partons at the end of the shower phase are stored in the
78636C...HEPEVT commonblock. The interesting information is
78637C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
78638C...IDHEP(I) = the particle ID code according to PDG conventions,
78639C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
78640C...All ISTHEP entries are 1, while the rest is zeroed.
78641
78642C...The user decision is to be conveyed by the IVETO value.
78643C...IVETO = 0 : retain current event and generate in full;
78644C... = 1 : abort generation of current event and move to next.
78645
78646 SUBROUTINE UPVETO(IVETO)
78647
78648C...HEPEVT commonblock.
78649 PARAMETER (NMXHEP=4000)
78650 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
78651 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
78652 DOUBLE PRECISION PHEP,VHEP
78653 SAVE /HEPEVT/
78654
78655C...Next few lines allow you to see what info PYVETO extracted from
78656C...the full event record for the first two events.
78657C...Delete if you don't want it.
78658 DATA NLIST/0/
78659 SAVE NLIST
78660 IF(NLIST.LE.2) THEN
78661 WRITE(*,*) ' Full event record at time of UPVETO call:'
78662 CALL PYLIST(1)
78663 WRITE(*,*) ' Part of event record made available to UPVETO:'
78664 CALL PYLIST(5)
78665 NLIST=NLIST+1
78666 ENDIF
78667
78668C...Make decision here.
78669 IVETO = 0
78670
78671 RETURN
78672 END
78673
78674C*********************************************************************
78675C...SUGRA
78676C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
78677
78678 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
78679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78680 IMPLICIT INTEGER(I-N)
78681 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
78682 INTEGER IMODL
78683C...Commonblocks.
78684 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78685 SAVE /PYDAT1/
78686
78687C...Stop program if this routine is ever called.
78688 WRITE(MSTU(11),5000)
78689 CALL PYSTOP(110)
78690
78691C...Format for error printout.
78692 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78693 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
78694 &1X,'Execution stopped!')
78695
78696 RETURN
78697 END
78698
78699C*********************************************************************
78700
78701C...VISAJE
78702C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78703
78704 FUNCTION VISAJE()
78705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78706 IMPLICIT INTEGER(I-N)
78707 CHARACTER*40 VISAJE
78708
78709C...Commonblocks.
78710 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78711 SAVE /PYDAT1/
78712
78713C...Assign default value.
78714 VISAJE='Undefined'
78715
78716C...Stop program if this routine is ever called.
78717 WRITE(MSTU(11),5000)
78718 CALL PYSTOP(110)
78719
78720C...Format for error printout.
78721 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78722 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
78723 &1X,'Execution stopped!')
78724
78725 RETURN
78726 END
78727
78728C*********************************************************************
78729
78730C...SSMSSM
78731C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
78732
78733 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
78734 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
78735 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
78736 &IDUM1,IDUM2)
78737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78738 IMPLICIT INTEGER(I-N)
78739 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
78740 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
78741 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
78742C...Commonblocks.
78743 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78744 SAVE /PYDAT1/
78745
78746C...Stop program if this routine is ever called.
78747 WRITE(MSTU(11),5000)
78748 CALL PYSTOP(110)
78749
78750C...Format for error printout.
78751 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
78752 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
78753 &1X,'Execution stopped!')
78754 RETURN
78755 END
78756
78757C*********************************************************************
78758
78759C...FHSETFLAGS
78760C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78761
78762 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
78763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78764 IMPLICIT INTEGER(I-N)
78765Cmssmpart = 4 # full MSSM [recommended]
78766Cfieldren = 0 # MSbar field ren. [strongly recommended]
78767Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
78768Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
78769Cp2approx = 0 # no approximation [recommended]
78770Clooplevel= 2 # include 2-loop corrections
78771Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
78772Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
78773
78774C...Commonblocks.
78775 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78776 SAVE /PYDAT1/
78777
78778C...Stop program if this routine is ever called.
78779 WRITE(MSTU(11),5000)
78780 CALL PYSTOP(103)
78781
78782C...Format for error printout.
78783 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78784 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
78785 &1X,'Execution stopped!')
78786 RETURN
78787 END
78788
78789C*********************************************************************
78790
78791C...FHSETPARA
78792C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78793
78794 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
78795 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
78796 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
78797 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
78798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78799 IMPLICIT INTEGER(I-N)
78800
78801 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78802 DOUBLE COMPLEX DMU,
78803 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78804 & DM1, DM2, DM3
78805
78806C...Commonblocks.
78807 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78808 SAVE /PYDAT1/
78809
78810C...Stop program if this routine is ever called.
78811 WRITE(MSTU(11),5000)
78812 CALL PYSTOP(103)
78813
78814C...Format for error printout.
78815 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78816 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78817 &1X,'Execution stopped!')
78818 RETURN
78819 END
78820
78821C*********************************************************************
78822
78823C...FHHIGGSCORR
78824C...Dummy function, to be removed when FEYNHIGGS is to be linked.
78825
78826 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
78827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78828 IMPLICIT INTEGER(I-N)
78829
78830C...FeynHiggs variables
78831 DOUBLE PRECISION RMHIGG(4)
78832 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
78833 DOUBLE COMPLEX DMU,
78834 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
78835 & DM1, DM2, DM3
78836
78837C...Commonblocks.
78838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78839 SAVE /PYDAT1/
78840
78841C...Stop program if this routine is ever called.
78842 WRITE(MSTU(11),5000)
78843 CALL PYSTOP(103)
78844
78845C...Format for error printout.
78846 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
78847 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
78848 &1X,'Execution stopped!')
78849 RETURN
78850 END
78851
78852C*********************************************************************
78853
78854C...PYTAUD
78855C...Dummy routine, to be replaced by user, to handle the decay of a
78856C...polarized tau lepton.
78857C...Input:
78858C...ITAU is the position where the decaying tau is stored in /PYJETS/.
78859C...IORIG is the position where the mother of the tau is stored;
78860C... is 0 when the mother is not stored.
78861C...KFORIG is the flavour of the mother of the tau;
78862C... is 0 when the mother is not known.
78863C...Note that IORIG=0 does not necessarily imply KFORIG=0;
78864C... e.g. in B hadron semileptonic decays the W propagator
78865C... is not explicitly stored but the W code is still unambiguous.
78866C...Output:
78867C...NDECAY is the number of decay products in the current tau decay.
78868C...These decay products should be added to the /PYJETS/ common block,
78869C...in positions N+1 through N+NDECAY. For each product I you must
78870C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
78871C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
78872
78873 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
78874
78875C...Double precision and integer declarations.
78876 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78877 IMPLICIT INTEGER(I-N)
78878 INTEGER PYK,PYCHGE,PYCOMP
78879C...Commonblocks.
78880 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78881 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78882 SAVE /PYJETS/,/PYDAT1/
78883
78884C...Stop program if this routine is ever called.
78885C...You should not copy these lines to your own routine.
78886 NDECAY=ITAU+IORIG+KFORIG
78887 WRITE(MSTU(11),5000)
78888 CALL PYSTOP(10)
78889
78890C...Format for error printout.
78891 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
78892 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
78893 &1X,'Execution stopped!')
78894
78895 RETURN
78896 END
78897
78898C*********************************************************************
78899
78900C...PYTIME
78901C...Finds current date and time.
78902C...Since this task is not standardized in Fortran 77, the routine
78903C...is dummy, to be replaced by the user. Examples are given for
78904C...the Fortran 90 routine and DEC Fortran 77, and what to do if
78905C...you do not have access to suitable routines.
78906
78907 SUBROUTINE PYTIME(IDATI)
78908
78909C...Double precision and integer declarations.
78910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78911 IMPLICIT INTEGER(I-N)
78912 INTEGER PYK,PYCHGE,PYCOMP
78913 CHARACTER*8 ATIME
78914C...Local array.
78915 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
78916
78917C...Example 0: if you do not have suitable routines.
78918 DO 100 J=1,6
78919 IDATI(J)=0
78920 100 CONTINUE
78921
78922C...Example 1: Fortran 90 routine.
78923C CALL DATE_AND_TIME(VALUES=IVAL)
78924C IDATI(1)=IVAL(1)
78925C IDATI(2)=IVAL(2)
78926C IDATI(3)=IVAL(3)
78927C IDATI(4)=IVAL(5)
78928C IDATI(5)=IVAL(6)
78929C IDATI(6)=IVAL(7)
78930
78931C...Example 2: DEC Fortran 77. AIX.
78932C CALL IDATE(IMON,IDAY,IYEAR)
78933C IDATI(1)=IYEAR
78934C IDATI(2)=IMON
78935C IDATI(3)=IDAY
78936C CALL ITIME(IHOUR,IMIN,ISEC)
78937C IDATI(4)=IHOUR
78938C IDATI(5)=IMIN
78939C IDATI(6)=ISEC
78940
78941C...Example 3: DEC Fortran, IRIX, IRIX64.
78942C CALL IDATE(IMON,IDAY,IYEAR)
78943C IDATI(1)=IYEAR
78944C IDATI(2)=IMON
78945C IDATI(3)=IDAY
78946C CALL TIME(ATIME)
78947C IHOUR=0
78948C IMIN=0
78949C ISEC=0
78950C READ(ATIME(1:2),'(I2)') IHOUR
78951C READ(ATIME(4:5),'(I2)') IMIN
78952C READ(ATIME(7:8),'(I2)') ISEC
78953C IDATI(4)=IHOUR
78954C IDATI(5)=IMIN
78955C IDATI(6)=ISEC
78956
78957C...Example 4: GNU LINUX libU77, SunOS.
78958C CALL IDATE(IDTEMP)
78959C IDATI(1)=IDTEMP(3)
78960C IDATI(2)=IDTEMP(2)
78961C IDATI(3)=IDTEMP(1)
78962C CALL ITIME(IDTEMP)
78963C IDATI(4)=IDTEMP(1)
78964C IDATI(5)=IDTEMP(2)
78965C IDATI(6)=IDTEMP(3)
78966
78967C...Common code to ensure right century.
78968 IDATI(1)=2000+MOD(IDATI(1),100)
78969
78970 RETURN
78971 END
be4253b2 78972C... ALICE interface to PDFLIB with possibility to select nuclear structure
78973C... functions.
78974C...
78975C... The MSTP array in the PYPARS common block is used to enable and
78976C... select the nuclear structure functions.
78977C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
78978C... =1: internal PYTHIA acording to MSTP(51)
78979C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
78980C... MSTP( 51) = 1000xNPGROUP+NPSET
78981C... MSTP(151) = 1000xNAGROUP+NASET
78982C... MSTP(192) : Mass number of nucleus side 1
78983C... MSTP(193) : Mass number of nucleus side 2
78984C...
78985C...
78986C... MINT(124) : side (1 or 2)
78987
78988
78989 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
78990C...
78991 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78992 IMPLICIT INTEGER(I-N)
78993C...Interface to PDFLIB.
78994 COMMON/LW50512/QCDL4,QCDL5
78995 SAVE /LW50512/
78996 DOUBLE PRECISION QCDL4,QCDL5
78997 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
78998 SAVE /LW50513/
78999 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
79000C...
79001 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79002 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
79003 DOUBLE PRECISION VALUE(20)
79004 CHARACTER*20 PARM(20)
79005 write(6,*) MSTP(52)
79006 write(6,*) PARM
79007 write(6,*) VALUE
79008
79009 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
79010 PARM(5)='NATYPE'
79011 VALUE(5)=4
79012 PARM(6)='NAGROUP'
79013 VALUE(6)=MSTP(191)/1000
79014 PARM(7)='NASET'
79015 VALUE(7)=MOD(MSTP(191),1000)
79016 CALL PDFSET(PARM,VALUE,
79017 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
79018 > QCDL4,QCDL5,
79019 > XMIN,XMAX,Q2MIN,Q2MAX)
79020 IF (MSTP(194) .EQ. 0) THEN
79021 CALL SETLHAPARM("EKS98")
66f02a7f 79022 ELSE IF (MSTP(194) .EQ. 9) THEN
79023 CALL SETLHAPARM("EPS09LO")
79024 ELSE IF (MSTP(194) .EQ. 19) THEN
79025 CALL SETLHAPARM("EPS09NLO")
79026 ELSE IF (MSTP(194) .EQ. 8) THEN
be4253b2 79027 CALL SETLHAPARM("EPS08")
66f02a7f 79028 ELSE
79029 CALL SETLHAPARM("EPS09LO")
be4253b2 79030 ENDIF
79031 ELSE
79032 write(6,*) "-> pdfset"
79033 CALL PDFSET(PARM,VALUE,
79034 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
79035 > QCDL4,QCDL5,
79036 > XMIN,XMAX,Q2MIN,Q2MAX)
79037 ENDIF
79038 write(6,*) "done"
79039 END
79040
79041
79042
79043 SUBROUTINE STRUCTM_ALICE
79044 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79045C...
79046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79047 IMPLICIT INTEGER(I-N)
79048 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
79049 COMMON/PYINT1/MINT(400),VINT(400)
79050C write(6,*) "structm_alice->"
79051 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
79052 A=MSTP(191+MINT(124))
79053C write(6,*) mint(124), "-> structa ", A
79054 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79055 ELSE
79056C write(6,*) mint(124), "-> structm "
79057 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
79058 ENDIF
79059 END
79060